1;;; mlsupport.el --- run-time support for mocklisp code 2 3;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, 4;; 2006, 2007 Free Software Foundation, Inc. 5 6;; Maintainer: FSF 7;; Keywords: extensions 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; This package provides equivalents of certain primitives from Gosling 29;; Emacs (including the commercial UniPress versions). These have an 30;; ml- prefix to distinguish them from native GNU Emacs functions with 31;; similar names. The package mlconvert.el translates Mocklisp code 32;; to use these names. 33 34;;; Code: 35 36(defmacro ml-defun (&rest defs) 37 (list 'ml-defun-1 (list 'quote defs))) 38 39(defun ml-defun-1 (args) 40 (while args 41 (fset (car (car args)) (cons 'mocklisp (cdr (car args)))) 42 (setq args (cdr args)))) 43 44(defmacro declare-buffer-specific (&rest vars) 45 (cons 'progn (mapcar (function (lambda (var) (list 'make-variable-buffer-local (list 'quote var)))) vars))) 46 47(defun ml-set-default (varname value) 48 (set-default (intern varname) value)) 49 50; Lossage: must make various things default missing args to the prefix arg 51; Alternatively, must make provide-prefix-argument do something hairy. 52 53(defun >> (val count) (lsh val (- count))) 54(defun novalue () nil) 55 56(defun ml-not (arg) (if (zerop arg) 1 0)) 57 58(defun provide-prefix-arg (arg form) 59 (funcall (car form) arg)) 60 61(defun define-keymap (name) 62 (fset (intern name) (make-keymap))) 63 64;; Make it work to use ml-use-...-map on "esc" and such. 65(fset 'esc-map esc-map) 66(fset 'ctl-x-map ctl-x-map) 67 68(defun ml-use-local-map (name) 69 (use-local-map (intern (concat name "-map")))) 70 71(defun ml-use-global-map (name) 72 (use-global-map (intern (concat name "-map")))) 73 74(defun local-bind-to-key (name key) 75 (or (current-local-map) 76 (use-local-map (make-keymap))) 77 (define-key (current-local-map) 78 (if (integerp key) 79 (if (>= key 128) 80 (concat (char-to-string meta-prefix-char) 81 (char-to-string (- key 128))) 82 (char-to-string key)) 83 key) 84 (intern name))) 85 86(defun bind-to-key (name key) 87 (define-key global-map (if (integerp key) (char-to-string key) key) 88 (intern name))) 89 90(defun ml-autoload (name file) 91 (autoload (intern name) file)) 92 93(defun ml-define-string-macro (name defn) 94 (fset (intern name) defn)) 95 96(defun push-back-character (char) 97 (setq unread-command-events (list char))) 98 99(defun to-col (column) 100 (indent-to column 0)) 101 102(defmacro is-bound (&rest syms) 103 (cons 'and (mapcar (function (lambda (sym) (list 'boundp (list 'quote sym)))) syms))) 104 105(defmacro declare-global (&rest syms) 106 (cons 'progn (mapcar (function (lambda (sym) (list 'defvar sym nil))) syms))) 107 108(defmacro error-occurred (&rest body) 109 (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t))) 110 111(defun return-prefix-argument (value) 112 (setq prefix-arg value)) 113 114(defun ml-prefix-argument () 115 (if (null current-prefix-arg) 1 116 (if (listp current-prefix-arg) (car current-prefix-arg) 117 (if (eq current-prefix-arg '-) -1 118 current-prefix-arg)))) 119 120(defun ml-print (varname) 121 (interactive "vPrint variable: ") 122 (if (boundp varname) 123 (message "%s => %s" (symbol-name varname) (symbol-value varname)) 124 (message "%s has no value" (symbol-name varname)))) 125 126(defun ml-set (str val) (set (intern str) val)) 127 128(defun ml-message (&rest args) (message "%s" (apply 'concat args))) 129 130(defun kill-to-end-of-line () 131 (ml-prefix-argument-loop 132 (if (eolp) 133 (kill-region (point) (1+ (point))) 134 (kill-region (point) (if (search-forward ?\n nil t) 135 (1- (point)) (point-max)))))) 136 137(defun set-auto-fill-hook (arg) 138 (setq auto-fill-function (intern arg))) 139 140(defun auto-execute (function pattern) 141 (if (/= (aref pattern 0) ?*) 142 (error "Only patterns starting with * supported in auto-execute")) 143 (setq auto-mode-alist (cons (cons (concat "\\." (substring pattern 1) 144 "\\'") 145 function) 146 auto-mode-alist))) 147 148(defun move-to-comment-column () 149 (indent-to comment-column)) 150 151(defun erase-region () 152 (delete-region (point) (mark))) 153 154(defun delete-region-to-buffer (bufname) 155 (copy-to-buffer bufname (point) (mark)) 156 (delete-region (point) (mark))) 157 158(defun copy-region-to-buffer (bufname) 159 (copy-to-buffer bufname (point) (mark))) 160 161(defun append-region-to-buffer (bufname) 162 (append-to-buffer bufname (point) (mark))) 163 164(defun prepend-region-to-buffer (bufname) 165 (prepend-to-buffer bufname (point) (mark))) 166 167(defun delete-next-character () 168 (delete-char (ml-prefix-argument))) 169 170(defun delete-next-word () 171 (delete-region (point) (progn (forward-word (ml-prefix-argument)) (point)))) 172 173(defun delete-previous-word () 174 (delete-region (point) (progn (backward-word (ml-prefix-argument)) (point)))) 175 176(defun delete-previous-character () 177 (delete-backward-char (ml-prefix-argument))) 178 179(defun forward-character () 180 (forward-char (ml-prefix-argument))) 181 182(defun backward-character () 183 (backward-char (ml-prefix-argument))) 184 185(defun ml-newline () 186 (newline (ml-prefix-argument))) 187 188(defun ml-next-line () 189 (next-line (ml-prefix-argument))) 190 191(defun ml-previous-line () 192 (previous-line (ml-prefix-argument))) 193 194(defun delete-to-kill-buffer () 195 (kill-region (point) (mark))) 196 197(defun narrow-region () 198 (narrow-to-region (point) (mark))) 199 200(defun ml-newline-and-indent () 201 (let ((column (current-indentation))) 202 (newline (ml-prefix-argument)) 203 (indent-to column))) 204 205(defun newline-and-backup () 206 (open-line (ml-prefix-argument))) 207 208(defun quote-char () 209 (quoted-insert (ml-prefix-argument))) 210 211(defun ml-current-column () 212 (1+ (current-column))) 213 214(defun ml-current-indent () 215 (1+ (current-indentation))) 216 217(defun region-around-match (&optional n) 218 (set-mark (match-beginning n)) 219 (goto-char (match-end n))) 220 221(defun region-to-string () 222 (buffer-substring (min (point) (mark)) (max (point) (mark)))) 223 224(defun use-abbrev-table (name) 225 (let ((symbol (intern (concat name "-abbrev-table")))) 226 (or (boundp symbol) 227 (define-abbrev-table symbol nil)) 228 (symbol-value symbol))) 229 230(defun define-hooked-local-abbrev (name exp hook) 231 (define-abbrev local-abbrev-table name exp (intern hook))) 232 233(defun define-hooked-global-abbrev (name exp hook) 234 (define-abbrev global-abbrev-table name exp (intern hook))) 235 236(defun case-word-lower () 237 (ml-casify-word 'downcase-region)) 238 239(defun case-word-upper () 240 (ml-casify-word 'upcase-region)) 241 242(defun case-word-capitalize () 243 (ml-casify-word 'capitalize-region)) 244 245(defun ml-casify-word (fun) 246 (save-excursion 247 (forward-char 1) 248 (forward-word -1) 249 (funcall fun (point) 250 (progn (forward-word (ml-prefix-argument)) 251 (point))))) 252 253(defun case-region-lower () 254 (downcase-region (point) (mark))) 255 256(defun case-region-upper () 257 (upcase-region (point) (mark))) 258 259(defun case-region-capitalize () 260 (capitalize-region (point) (mark))) 261 262(defvar saved-command-line-args nil) 263 264(defun argc () 265 (or saved-command-line-args 266 (setq saved-command-line-args command-line-args 267 command-line-args ())) 268 (length command-line-args)) 269 270(defun argv (i) 271 (or saved-command-line-args 272 (setq saved-command-line-args command-line-args 273 command-line-args ())) 274 (nth i saved-command-line-args)) 275 276(defun invisible-argc () 277 (length (or saved-command-line-args 278 command-line-args))) 279 280(defun invisible-argv (i) 281 (nth i (or saved-command-line-args 282 command-line-args))) 283 284(defun exit-emacs () 285 (interactive) 286 (condition-case () 287 (exit-recursive-edit) 288 (error (kill-emacs)))) 289 290;; Lisp function buffer-size returns total including invisible; 291;; mocklisp wants just visible. 292(defun ml-buffer-size () 293 (- (point-max) (point-min))) 294 295(defun previous-command () 296 last-command) 297 298(defun beginning-of-window () 299 (goto-char (window-start))) 300 301(defun end-of-window () 302 (goto-char (window-start)) 303 (vertical-motion (- (window-height) 2))) 304 305(defun ml-search-forward (string) 306 (search-forward string nil nil (ml-prefix-argument))) 307 308(defun ml-re-search-forward (string) 309 (re-search-forward string nil nil (ml-prefix-argument))) 310 311(defun ml-search-backward (string) 312 (search-backward string nil nil (ml-prefix-argument))) 313 314(defun ml-re-search-backward (string) 315 (re-search-backward string nil nil (ml-prefix-argument))) 316 317(defvar use-users-shell 1 318 "Mocklisp compatibility variable; 1 means use shell from SHELL env var. 3190 means use /bin/sh.") 320 321(defvar use-csh-option-f 1 322 "Mocklisp compatibility variable; 1 means pass -f when calling csh.") 323 324(defun filter-region (command) 325 (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh")) 326 (csh (equal (file-name-nondirectory shell) "csh"))) 327 (call-process-region (point) (mark) shell t t nil 328 (if (and csh use-csh-option-f) "-cf" "-c") 329 (concat "exec " command)))) 330 331(defun execute-monitor-command (command) 332 (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh")) 333 (csh (equal (file-name-nondirectory shell) "csh"))) 334 (call-process shell nil t t 335 (if (and csh use-csh-option-f) "-cf" "-c") 336 (concat "exec " command)))) 337 338(defun use-syntax-table (name) 339 (set-syntax-table (symbol-value (intern (concat name "-syntax-table"))))) 340 341(defun line-to-top-of-window () 342 (recenter (1- (ml-prefix-argument)))) 343 344(defun ml-previous-page (&optional arg) 345 (let ((count (or arg (ml-prefix-argument)))) 346 (while (> count 0) 347 (scroll-down nil) 348 (setq count (1- count))) 349 (while (< count 0) 350 (scroll-up nil) 351 (setq count (1+ count))))) 352 353(defun ml-next-page () 354 (previous-page (- (ml-prefix-argument)))) 355 356(defun page-next-window (&optional arg) 357 (let ((count (or arg (ml-prefix-argument)))) 358 (while (> count 0) 359 (scroll-other-window nil) 360 (setq count (1- count))) 361 (while (< count 0) 362 (scroll-other-window '-) 363 (setq count (1+ count))))) 364 365(defun ml-next-window () 366 (select-window (next-window))) 367 368(defun ml-previous-window () 369 (select-window (previous-window))) 370 371(defun scroll-one-line-up () 372 (scroll-up (ml-prefix-argument))) 373 374(defun scroll-one-line-down () 375 (scroll-down (ml-prefix-argument))) 376 377(defun split-current-window () 378 (split-window (selected-window))) 379 380(defun last-key-struck () last-command-char) 381 382(defun execute-mlisp-line (string) 383 (eval (read string))) 384 385(defun move-dot-to-x-y (x y) 386 (goto-char (window-start (selected-window))) 387 (vertical-motion (1- y)) 388 (move-to-column (1- x))) 389 390(defun ml-modify-syntax-entry (string) 391 (let ((i 5) 392 (len (length string)) 393 (datastring (substring string 0 2))) 394 (if (= (aref string 0) ?\-) 395 (aset datastring 0 ?\ )) 396 (if (= (aref string 2) ?\{) 397 (if (= (aref string 4) ?\ ) 398 (aset datastring 0 ?\<) 399 (error "Two-char comment delimiter: use modify-syntax-entry directly"))) 400 (if (= (aref string 3) ?\}) 401 (if (= (aref string 4) ?\ ) 402 (aset datastring 0 ?\>) 403 (error "Two-char comment delimiter: use modify-syntax-entry directly"))) 404 (while (< i len) 405 (modify-syntax-entry (aref string i) datastring) 406 (setq i (1+ i)) 407 (if (and (< i len) 408 (= (aref string i) ?\-)) 409 (let ((c (aref string (1- i))) 410 (lim (aref string (1+ i)))) 411 (while (<= c lim) 412 (modify-syntax-entry c datastring) 413 (setq c (1+ c))) 414 (setq i (+ 2 i))))))) 415 416 417 418(defun ml-substr (string from to) 419 (let ((length (length string))) 420 (if (< from 0) (setq from (+ from length))) 421 (if (< to 0) (setq to (+ to length))) 422 (substring string from (+ from to)))) 423 424(defun ml-concat (&rest args) 425 (let ((newargs nil) this) 426 (while args 427 (setq this (car args)) 428 (if (numberp this) 429 (setq this (number-to-string this))) 430 (setq newargs (cons this newargs) 431 args (cdr args))) 432 (apply 'concat (nreverse newargs)))) 433 434(provide 'mlsupport) 435 436;;; arch-tag: b0ad09bc-8cb2-4be0-8888-2e874839bcbc 437;;; mlsupport.el ends here 438