1 ;;; mlsupport.el --- run-time support for mocklisp code
3 ;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008 Free Software Foundation, Inc.
7 ;; Keywords: extensions
9 ;; This file is part of GNU Emacs.
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 3 of the License, or
14 ;; (at your option) any later version.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This file has been obsolete since Emacs 22.1.
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.
36 (defmacro ml-defun
(&rest defs
)
37 (list 'ml-defun-1
(list 'quote defs
)))
39 (defun ml-defun-1 (args)
41 (fset (car (car args
)) (cons 'mocklisp
(cdr (car args
))))
42 (setq args
(cdr args
))))
44 (defmacro declare-buffer-specific
(&rest vars
)
45 (cons 'progn
(mapcar (function (lambda (var) (list 'make-variable-buffer-local
(list 'quote var
)))) vars
)))
47 (defun ml-set-default (varname value
)
48 (set-default (intern varname
) value
))
50 ; Lossage: must make various things default missing args to the prefix arg
51 ; Alternatively, must make provide-prefix-argument do something hairy.
53 (defun >> (val count
) (lsh val
(- count
)))
54 (defun novalue () nil
)
56 (defun ml-not (arg) (if (zerop arg
) 1 0))
58 (defun provide-prefix-arg (arg form
)
59 (funcall (car form
) arg
))
61 (defun define-keymap (name)
62 (fset (intern name
) (make-keymap)))
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
)
68 (defun ml-use-local-map (name)
69 (use-local-map (intern (concat name
"-map"))))
71 (defun ml-use-global-map (name)
72 (use-global-map (intern (concat name
"-map"))))
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)
80 (concat (char-to-string meta-prefix-char
)
81 (char-to-string (- key
128)))
86 (defun bind-to-key (name key
)
87 (define-key global-map
(if (integerp key
) (char-to-string key
) key
)
90 (defun ml-autoload (name file
)
91 (autoload (intern name
) file
))
93 (defun ml-define-string-macro (name defn
)
94 (fset (intern name
) defn
))
96 (defun push-back-character (char)
97 (setq unread-command-events
(list char
)))
99 (defun to-col (column)
100 (indent-to column
0))
102 (defmacro is-bound
(&rest syms
)
103 (cons 'and
(mapcar (function (lambda (sym) (list 'boundp
(list 'quote sym
)))) syms
)))
105 (defmacro declare-global
(&rest syms
)
106 (cons 'progn
(mapcar (function (lambda (sym) (list 'defvar sym nil
))) syms
)))
108 (defmacro error-occurred
(&rest body
)
109 (list 'condition-case nil
(cons 'progn
(append body
'(nil))) '(error t
)))
111 (defun return-prefix-argument (value)
112 (setq prefix-arg value
))
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
))))
120 (defun ml-print (varname)
121 (interactive "vPrint variable: ")
123 (message "%s => %s" (symbol-name varname
) (symbol-value varname
))
124 (message "%s has no value" (symbol-name varname
))))
126 (defun ml-set (str val
) (set (intern str
) val
))
128 (defun ml-message (&rest args
) (message "%s" (apply 'concat args
)))
130 (defun set-auto-fill-hook (arg)
131 (setq auto-fill-function
(intern arg
)))
133 (defun auto-execute (function pattern
)
134 (if (/= (aref pattern
0) ?
*)
135 (error "Only patterns starting with * supported in auto-execute"))
136 (setq auto-mode-alist
(cons (cons (concat "\\." (substring pattern
1)
141 (defun move-to-comment-column ()
142 (indent-to comment-column
))
144 (defun erase-region ()
145 (delete-region (point) (mark)))
147 (defun delete-region-to-buffer (bufname)
148 (copy-to-buffer bufname
(point) (mark))
149 (delete-region (point) (mark)))
151 (defun copy-region-to-buffer (bufname)
152 (copy-to-buffer bufname
(point) (mark)))
154 (defun append-region-to-buffer (bufname)
155 (append-to-buffer bufname
(point) (mark)))
157 (defun prepend-region-to-buffer (bufname)
158 (prepend-to-buffer bufname
(point) (mark)))
160 (defun delete-next-character ()
161 (delete-char (ml-prefix-argument)))
163 (defun delete-next-word ()
164 (delete-region (point) (progn (forward-word (ml-prefix-argument)) (point))))
166 (defun delete-previous-word ()
167 (delete-region (point) (progn (backward-word (ml-prefix-argument)) (point))))
169 (defun delete-previous-character ()
170 (delete-backward-char (ml-prefix-argument)))
172 (defun forward-character ()
173 (forward-char (ml-prefix-argument)))
175 (defun backward-character ()
176 (backward-char (ml-prefix-argument)))
179 (newline (ml-prefix-argument)))
181 (defun ml-next-line ()
182 (forward-line (ml-prefix-argument)))
184 (defun ml-previous-line ()
185 (forward-line (- (ml-prefix-argument))))
187 (defun delete-to-kill-buffer ()
188 (kill-region (point) (mark)))
190 (defun narrow-region ()
191 (narrow-to-region (point) (mark)))
193 (defun ml-newline-and-indent ()
194 (let ((column (current-indentation)))
195 (newline (ml-prefix-argument))
198 (defun newline-and-backup ()
199 (open-line (ml-prefix-argument)))
202 (quoted-insert (ml-prefix-argument)))
204 (defun ml-current-column ()
205 (1+ (current-column)))
207 (defun ml-current-indent ()
208 (1+ (current-indentation)))
210 (defun region-around-match (&optional n
)
211 (set-mark (match-beginning n
))
212 (goto-char (match-end n
)))
214 (defun region-to-string ()
215 (buffer-substring (min (point) (mark)) (max (point) (mark))))
217 (defun use-abbrev-table (name)
218 (let ((symbol (intern (concat name
"-abbrev-table"))))
220 (define-abbrev-table symbol nil
))
221 (symbol-value symbol
)))
223 (defun define-hooked-local-abbrev (name exp hook
)
224 (define-abbrev local-abbrev-table name exp
(intern hook
)))
226 (defun define-hooked-global-abbrev (name exp hook
)
227 (define-abbrev global-abbrev-table name exp
(intern hook
)))
229 (defun case-word-lower ()
230 (ml-casify-word 'downcase-region
))
232 (defun case-word-upper ()
233 (ml-casify-word 'upcase-region
))
235 (defun case-word-capitalize ()
236 (ml-casify-word 'capitalize-region
))
238 (defun ml-casify-word (fun)
243 (progn (forward-word (ml-prefix-argument))
246 (defun case-region-lower ()
247 (downcase-region (point) (mark)))
249 (defun case-region-upper ()
250 (upcase-region (point) (mark)))
252 (defun case-region-capitalize ()
253 (capitalize-region (point) (mark)))
255 (defvar saved-command-line-args nil
)
258 (or saved-command-line-args
259 (setq saved-command-line-args command-line-args
260 command-line-args
()))
261 (length command-line-args
))
264 (or saved-command-line-args
265 (setq saved-command-line-args command-line-args
266 command-line-args
()))
267 (nth i saved-command-line-args
))
269 (defun invisible-argc ()
270 (length (or saved-command-line-args
273 (defun invisible-argv (i)
274 (nth i
(or saved-command-line-args
280 (exit-recursive-edit)
281 (error (kill-emacs))))
283 ;; Lisp function buffer-size returns total including invisible;
284 ;; mocklisp wants just visible.
285 (defun ml-buffer-size ()
286 (- (point-max) (point-min)))
288 (defun previous-command ()
291 (defun beginning-of-window ()
292 (goto-char (window-start)))
294 (defun end-of-window ()
295 (goto-char (window-start))
296 (vertical-motion (- (window-height) 2)))
298 (defun ml-search-forward (string)
299 (search-forward string nil nil
(ml-prefix-argument)))
301 (defun ml-re-search-forward (string)
302 (re-search-forward string nil nil
(ml-prefix-argument)))
304 (defun ml-search-backward (string)
305 (search-backward string nil nil
(ml-prefix-argument)))
307 (defun ml-re-search-backward (string)
308 (re-search-backward string nil nil
(ml-prefix-argument)))
310 (defvar use-users-shell
1
311 "Mocklisp compatibility variable; 1 means use shell from SHELL env var.
312 0 means use /bin/sh.")
314 (defvar use-csh-option-f
1
315 "Mocklisp compatibility variable; 1 means pass -f when calling csh.")
317 (defun filter-region (command)
318 (let* ((shell (if (/= use-users-shell
0) shell-file-name
"/bin/sh"))
319 (csh (equal (file-name-nondirectory shell
) "csh")))
320 (call-process-region (point) (mark) shell t t nil
321 (if (and csh use-csh-option-f
) "-cf" "-c")
322 (concat "exec " command
))))
324 (defun execute-monitor-command (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 shell nil t t
328 (if (and csh use-csh-option-f
) "-cf" "-c")
329 (concat "exec " command
))))
331 (defun use-syntax-table (name)
332 (set-syntax-table (symbol-value (intern (concat name
"-syntax-table")))))
334 (defun line-to-top-of-window ()
335 (recenter (1- (ml-prefix-argument))))
337 (defun ml-previous-page (&optional arg
)
338 (let ((count (or arg
(ml-prefix-argument))))
341 (setq count
(1- count
)))
344 (setq count
(1+ count
)))))
346 (defun ml-next-page ()
347 (ml-previous-page (- (ml-prefix-argument))))
349 (defun page-next-window (&optional arg
)
350 (let ((count (or arg
(ml-prefix-argument))))
352 (scroll-other-window nil
)
353 (setq count
(1- count
)))
355 (scroll-other-window '-
)
356 (setq count
(1+ count
)))))
358 (defun ml-next-window ()
359 (select-window (next-window)))
361 (defun ml-previous-window ()
362 (select-window (previous-window)))
364 (defun scroll-one-line-up ()
365 (scroll-up (ml-prefix-argument)))
367 (defun scroll-one-line-down ()
368 (scroll-down (ml-prefix-argument)))
370 (defun split-current-window ()
371 (split-window (selected-window)))
373 (defun last-key-struck () last-command-char
)
375 (defun execute-mlisp-line (string)
376 (eval (read string
)))
378 (defun move-dot-to-x-y (x y
)
379 (goto-char (window-start (selected-window)))
380 (vertical-motion (1- y
))
381 (move-to-column (1- x
)))
383 (defun ml-modify-syntax-entry (string)
385 (len (length string
))
386 (datastring (substring string
0 2)))
387 (if (= (aref string
0) ?\-
)
388 (aset datastring
0 ?\
))
389 (if (= (aref string
2) ?\
{)
390 (if (= (aref string
4) ?\
)
391 (aset datastring
0 ?\
<)
392 (error "Two-char comment delimiter: use modify-syntax-entry directly")))
393 (if (= (aref string
3) ?\
})
394 (if (= (aref string
4) ?\
)
395 (aset datastring
0 ?\
>)
396 (error "Two-char comment delimiter: use modify-syntax-entry directly")))
398 (modify-syntax-entry (aref string i
) datastring
)
401 (= (aref string i
) ?\-
))
402 (let ((c (aref string
(1- i
)))
403 (lim (aref string
(1+ i
))))
405 (modify-syntax-entry c datastring
)
407 (setq i
(+ 2 i
)))))))
411 (defun ml-substr (string from to
)
412 (let ((length (length string
)))
413 (if (< from
0) (setq from
(+ from length
)))
414 (if (< to
0) (setq to
(+ to length
)))
415 (substring string from
(+ from to
))))
417 (defun ml-concat (&rest args
)
418 (let ((newargs nil
) this
)
420 (setq this
(car args
))
422 (setq this
(number-to-string this
)))
423 (setq newargs
(cons this newargs
)
425 (apply 'concat
(nreverse newargs
))))
429 ;; arch-tag: b0ad09bc-8cb2-4be0-8888-2e874839bcbc
430 ;;; mlsupport.el ends here