]> code.delx.au - gnu-emacs/blob - lisp/subr.el
* subr.el (event-basic-type): Deal with listy events properly.
[gnu-emacs] / lisp / subr.el
1 ;;; subr.el --- basic lisp subroutines for Emacs
2
3 ;;; Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc.
4
5 ;; This file is part of GNU Emacs.
6
7 ;; GNU Emacs is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 2, or (at your option)
10 ;; any later version.
11
12 ;; GNU Emacs is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
16
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU Emacs; see the file COPYING. If not, write to
19 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 ;;; Code:
22
23 \f
24 ;;;; Lisp language features.
25
26 (defmacro lambda (&rest cdr)
27 "Return a lambda expression.
28 A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
29 self-quoting; the result of evaluating the lambda expression is the
30 expression itself. The lambda expression may then be treated as a
31 function, i. e. stored as the function value of a symbol, passed to
32 funcall or mapcar, etcetera.
33 ARGS should take the same form as an argument list for a `defun'.
34 DOCSTRING should be a string, as described for `defun'. It may be omitted.
35 INTERACTIVE should be a call to the function `interactive', which see.
36 It may also be omitted.
37 BODY should be a list of lisp expressions."
38 ;; Note that this definition should not use backquotes; subr.el should not
39 ;; depend on backquote.el.
40 (list 'function (cons 'lambda cdr)))
41
42 ;;(defmacro defun-inline (name args &rest body)
43 ;; "Create an \"inline defun\" (actually a macro).
44 ;;Use just like `defun'."
45 ;; (nconc (list 'defmacro name '(&rest args))
46 ;; (if (stringp (car body))
47 ;; (prog1 (list (car body))
48 ;; (setq body (or (cdr body) body))))
49 ;; (list (list 'cons (list 'quote
50 ;; (cons 'lambda (cons args body)))
51 ;; 'args))))
52
53 \f
54 ;;;; Window tree functions.
55
56 (defun one-window-p (&optional nomini)
57 "Returns non-nil if there is only one window.
58 Optional arg NOMINI non-nil means don't count the minibuffer
59 even if it is active."
60 (let ((base-window (selected-window)))
61 (if (and nomini (eq base-window (minibuffer-window)))
62 (setq base-window (next-window base-window)))
63 (eq base-window
64 (next-window base-window (if nomini 'arg)))))
65
66 (defun walk-windows (proc &optional minibuf all-frames)
67 "Cycle through all visible windows, calling PROC for each one.
68 PROC is called with a window as argument.
69 Optional second arg MINIBUF t means count the minibuffer window
70 even if not active. If MINIBUF is neither t nor nil it means
71 not to count the minibuffer even if it is active.
72
73 Optional third arg ALL-FRAMES, if t, means include all frames.
74 ALL-FRAMES nil or omitted means cycle within the selected frame,
75 but include the minibuffer window (if MINIBUF says so) that that
76 frame uses, even if it is on another frame.
77 If ALL-FRAMES is neither nil nor t, stick strictly to the selected frame."
78 (let* ((walk-windows-start (selected-window))
79 (walk-windows-current walk-windows-start))
80 (while (progn
81 (setq walk-windows-current
82 (next-window walk-windows-current minibuf all-frames))
83 (funcall proc walk-windows-current)
84 (not (eq walk-windows-current walk-windows-start))))))
85
86 \f
87 ;;;; Keymap support.
88
89 (defun undefined ()
90 (interactive)
91 (ding))
92
93 ;Prevent the \{...} documentation construct
94 ;from mentioning keys that run this command.
95 (put 'undefined 'suppress-keymap t)
96
97 (defun suppress-keymap (map &optional nodigits)
98 "Make MAP override all normally self-inserting keys to be undefined.
99 Normally, as an exception, digits and minus-sign are set to make prefix args,
100 but optional second arg NODIGITS non-nil treats them like other chars."
101 (let ((i 0))
102 (while (<= i 127)
103 (if (eql (lookup-key global-map (char-to-string i)) 'self-insert-command)
104 (define-key map (char-to-string i) 'undefined))
105 (setq i (1+ i))))
106 (or nodigits
107 (let (loop)
108 (define-key map "-" 'negative-argument)
109 ;; Make plain numbers do numeric args.
110 (setq loop ?0)
111 (while (<= loop ?9)
112 (define-key map (char-to-string loop) 'digit-argument)
113 (setq loop (1+ loop))))))
114
115 ;Moved to keymap.c
116 ;(defun copy-keymap (keymap)
117 ; "Return a copy of KEYMAP"
118 ; (while (not (keymapp keymap))
119 ; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
120 ; (if (vectorp keymap)
121 ; (copy-sequence keymap)
122 ; (copy-alist keymap)))
123
124 (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix)
125 "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
126 In other words, OLDDEF is replaced with NEWDEF where ever it appears.
127 If optional fourth argument OLDMAP is specified, we redefine
128 in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP."
129 (or prefix (setq prefix ""))
130 (let* ((scan (or oldmap keymap))
131 (vec1 (vector nil))
132 (prefix1 (vconcat prefix vec1)))
133 ;; Scan OLDMAP, finding each char or event-symbol that
134 ;; has any definition, and act on it with hack-key.
135 (while (consp scan)
136 (if (consp (car scan))
137 (let ((char (car (car scan)))
138 (defn (cdr (car scan))))
139 ;; The inside of this let duplicates exactly
140 ;; the inside of the following let that handles array elements.
141 (aset vec1 0 char)
142 (aset prefix1 (length prefix) char)
143 (let (inner-def)
144 ;; Skip past menu-prompt.
145 (while (stringp (car-safe defn))
146 (setq defn (cdr defn)))
147 (setq inner-def defn)
148 (while (and (symbolp inner-def)
149 (fboundp inner-def))
150 (setq inner-def (symbol-function inner-def)))
151 (if (eq defn olddef)
152 (define-key keymap prefix1 newdef)
153 (if (keymapp defn)
154 (substitute-key-definition olddef newdef keymap
155 inner-def
156 prefix1)))))
157 (if (arrayp (car scan))
158 (let* ((array (car scan))
159 (len (length array))
160 (i 0))
161 (while (< i len)
162 (let ((char i) (defn (aref array i)))
163 ;; The inside of this let duplicates exactly
164 ;; the inside of the previous let.
165 (aset vec1 0 char)
166 (aset prefix1 (length prefix) char)
167 (let (inner-def)
168 ;; Skip past menu-prompt.
169 (while (stringp (car-safe defn))
170 (setq defn (cdr defn)))
171 (setq inner-def defn)
172 (while (and (symbolp inner-def)
173 (fboundp inner-def))
174 (setq inner-def (symbol-function inner-def)))
175 (if (eq defn olddef)
176 (define-key keymap prefix1 newdef)
177 (if (keymapp defn)
178 (substitute-key-definition olddef newdef keymap
179 inner-def
180 prefix1)))))
181 (setq i (1+ i))))))
182 (setq scan (cdr scan)))))
183
184 (defun keyboard-translate (from to)
185 "Translate character FROM to TO at a low level.
186 This function creates a `keyboard-translate-table' if necessary
187 and then modifies one entry in it."
188 (or (arrayp keyboard-translate-table)
189 (setq keyboard-translate-table ""))
190 (if (or (> from (length keyboard-translate-table))
191 (> to (length keyboard-translate-table)))
192 (progn
193 (let* ((i (length keyboard-translate-table))
194 (table (make-string (- 256 i) 0)))
195 (while (< i 256)
196 (aset table i i)
197 (setq i (1+ i)))
198 (setq keyboard-translate-table table))))
199 (aset keyboard-translate-table from to))
200
201 \f
202 ;;;; The global keymap tree.
203
204 ;;; global-map, esc-map, and ctl-x-map have their values set up in
205 ;;; keymap.c; we just give them docstrings here.
206
207 (defvar global-map nil
208 "Default global keymap mapping Emacs keyboard input into commands.
209 The value is a keymap which is usually (but not necessarily) Emacs's
210 global map.")
211
212 (defvar esc-map nil
213 "Default keymap for ESC (meta) commands.
214 The normal global definition of the character ESC indirects to this keymap.")
215
216 (defvar ctl-x-map nil
217 "Default keymap for C-x commands.
218 The normal global definition of the character C-x indirects to this keymap.")
219
220 (defvar ctl-x-4-map (make-sparse-keymap)
221 "Keymap for subcommands of C-x 4")
222 (defalias 'ctl-x-4-prefix ctl-x-4-map)
223 (define-key ctl-x-map "4" 'ctl-x-4-prefix)
224
225 (defvar ctl-x-5-map (make-sparse-keymap)
226 "Keymap for frame commands.")
227 (defalias 'ctl-x-5-prefix ctl-x-5-map)
228 (define-key ctl-x-map "5" 'ctl-x-5-prefix)
229
230 \f
231 ;;;; Event manipulation functions.
232
233 ;; This code exists specifically to make sure that the
234 ;; resulting number does not appear in the .elc file.
235 ;; The number is negative on most machines, but not on all!
236 (defconst listify-key-sequence-1
237 (lsh 1 7))
238 (setq listify-key-sequence-1 (logior (lsh 1 23) listify-key-sequence-1))
239
240 (defun listify-key-sequence (key)
241 "Convert a key sequence to a list of events."
242 (if (vectorp key)
243 (append key nil)
244 (mapcar (function (lambda (c)
245 (if (> c 127)
246 (logxor c listify-key-sequence-1)
247 c)))
248 (append key nil))))
249
250 (defsubst eventp (obj)
251 "True if the argument is an event object."
252 (or (integerp obj)
253 (and (symbolp obj)
254 (get obj 'event-symbol-elements))
255 (and (consp obj)
256 (symbolp (car obj))
257 (get (car obj) 'event-symbol-elements))))
258
259 (defun event-modifiers (event)
260 "Returns a list of symbols representing the modifier keys in event EVENT.
261 The elements of the list may include `meta', `control',
262 `shift', `hyper', `super', `alt', `click', `drag', and `down'."
263 (let ((type event))
264 (if (listp type)
265 (setq type (car type)))
266 (if (symbolp type)
267 (cdr (get type 'event-symbol-elements))
268 (let ((list nil))
269 (or (zerop (logand type (lsh 1 23)))
270 (setq list (cons 'meta list)))
271 (or (and (zerop (logand type (lsh 1 22)))
272 (>= (logand type 127) 32))
273 (setq list (cons 'control list)))
274 (or (and (zerop (logand type (lsh 1 21)))
275 (= (logand type 255) (downcase (logand type 255))))
276 (setq list (cons 'shift list)))
277 (or (zerop (logand type (lsh 1 20)))
278 (setq list (cons 'hyper list)))
279 (or (zerop (logand type (lsh 1 19)))
280 (setq list (cons 'super list)))
281 (or (zerop (logand type (lsh 1 18)))
282 (setq list (cons 'alt list)))
283 list))))
284
285 (defun event-basic-type (event)
286 "Returns the basic type of the given event (all modifiers removed).
287 The value is an ASCII printing character (not upper case) or a symbol."
288 (if (consp event)
289 (setq event (car event)))
290 (if (symbolp event)
291 (car (get event 'event-symbol-elements))
292 (let ((base (logand event (1- (lsh 1 18)))))
293 (downcase (if (< base 32) (logior base 64) base)))))
294
295 (defsubst mouse-movement-p (object)
296 "Return non-nil if OBJECT is a mouse movement event."
297 (and (consp object)
298 (eq (car object) 'mouse-movement)))
299
300 (defsubst event-start (event)
301 "Return the starting position of EVENT.
302 If EVENT is a mouse press or a mouse click, this returns the location
303 of the event.
304 If EVENT is a drag, this returns the drag's starting position.
305 The return value is of the form
306 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
307 The `posn-' functions access elements of such lists."
308 (nth 1 event))
309
310 (defsubst event-end (event)
311 "Return the ending location of EVENT. EVENT should be a click or drag event.
312 If EVENT is a click event, this function is the same as `event-start'.
313 The return value is of the form
314 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
315 The `posn-' functions access elements of such lists."
316 (nth (1- (length event)) event))
317
318 (defsubst posn-window (position)
319 "Return the window in POSITION.
320 POSITION should be a list of the form
321 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
322 as returned by the `event-start' and `event-end' functions."
323 (nth 0 position))
324
325 (defsubst posn-point (position)
326 "Return the buffer location in POSITION.
327 POSITION should be a list of the form
328 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
329 as returned by the `event-start' and `event-end' functions."
330 (nth 1 position))
331
332 (defsubst posn-col-row (position)
333 "Return the row and column in POSITION.
334 POSITION should be a list of the form
335 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
336 as returned by the `event-start' and `event-end' functions."
337 (nth 2 position))
338
339 (defsubst posn-timestamp (position)
340 "Return the timestamp of POSITION.
341 POSITION should be a list of the form
342 (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP)
343 as returned by the `event-start' and `event-end' functions."
344 (nth 3 position))
345
346 \f
347 ;;;; Obsolescent names for functions.
348
349 (defalias 'make-syntax-table 'copy-syntax-table)
350 (defalias 'dot 'point)
351 (defalias 'dot-marker 'point-marker)
352 (defalias 'dot-min 'point-min)
353 (defalias 'dot-max 'point-max)
354 (defalias 'window-dot 'window-point)
355 (defalias 'set-window-dot 'set-window-point)
356 (defalias 'read-input 'read-string)
357 (defalias 'send-string 'process-send-string)
358 (defalias 'send-region 'process-send-region)
359 (defalias 'show-buffer 'set-window-buffer)
360 (defalias 'buffer-flush-undo 'buffer-disable-undo)
361 (defalias 'eval-current-buffer 'eval-buffer)
362 (defalias 'compiled-function-p 'byte-code-function-p)
363
364 ;;; This name isn't mentioned in the manual, and we've been hoping to
365 ;;; phase it out, but there's still a lot of code out there, even for
366 ;;; Emacs 18.59, which uses mod. I'm going to let the byte compiler's
367 ;;; make-obsolete function to poke people a little more, and leave the
368 ;;; `mod' name around for a while longer.
369 (defalias 'mod '%)
370
371 ;; Some programs still use this as a function.
372 (defun baud-rate ()
373 "Obsolete function returning the value of the `baud-rate' variable.
374 Please convert your programs to use the variable `baud-rate' directly."
375 baud-rate)
376
377 \f
378 ;;;; Alternate names for functions - these are not being phased out.
379
380 (defalias 'string= 'string-equal)
381 (defalias 'string< 'string-lessp)
382 (defalias 'move-marker 'set-marker)
383 (defalias 'eql 'eq)
384 (defalias 'not 'null)
385 (defalias 'rplaca 'setcar)
386 (defalias 'rplacd 'setcdr)
387 (defalias 'beep 'ding) ;preserve lingual purity
388 (defalias 'indent-to-column 'indent-to)
389 (defalias 'backward-delete-char 'delete-backward-char)
390 (defalias 'search-forward-regexp (symbol-function 're-search-forward))
391 (defalias 'search-backward-regexp (symbol-function 're-search-backward))
392 (defalias 'int-to-string 'number-to-string)
393
394 ;;; Should this be an obsolete name? If you decide it should, you get
395 ;;; to go through all the sources and change them.
396 (defalias 'string-to-int 'string-to-number)
397 \f
398 ;;;; Hook manipulation functions.
399
400 (defun run-hooks (&rest hooklist)
401 "Takes hook names and runs each one in turn. Major mode functions use this.
402 Each argument should be a symbol, a hook variable.
403 These symbols are processed in the order specified.
404 If a hook symbol has a non-nil value, that value may be a function
405 or a list of functions to be called to run the hook.
406 If the value is a function, it is called with no arguments.
407 If it is a list, the elements are called, in order, with no arguments."
408 (while hooklist
409 (let ((sym (car hooklist)))
410 (and (boundp sym)
411 (symbol-value sym)
412 (let ((value (symbol-value sym)))
413 (if (and (listp value) (not (eq (car value) 'lambda)))
414 (mapcar 'funcall value)
415 (funcall value)))))
416 (setq hooklist (cdr hooklist))))
417
418 ;; Tell C code how to call this function.
419 (defconst run-hooks 'run-hooks
420 "Variable by which C primitives find the function `run-hooks'.
421 Don't change it.")
422
423 (defun add-hook (hook function &optional append)
424 "Add to the value of HOOK the function FUNCTION unless already present (it
425 becomes the first hook on the list unless optional APPEND is non-nil, in
426 which case it becomes the last). HOOK should be a symbol, and FUNCTION may be
427 any valid function. HOOK's value should be a list of functions, not a single
428 function. If HOOK is void, it is first set to nil."
429 (or (boundp hook) (set hook nil))
430 (or (if (consp function)
431 ;; Clever way to tell whether a given lambda-expression
432 ;; is equal to anything in the hook.
433 (let ((tail (assoc (cdr function) (symbol-value hook))))
434 (equal function tail))
435 (memq function (symbol-value hook)))
436 (set hook
437 (if append
438 (nconc (symbol-value hook) (list function))
439 (cons function (symbol-value hook))))))
440
441 \f
442 ;;;; Specifying things to do after certain files are loaded.
443
444 (defun eval-after-load (file form)
445 "Arrange that, if FILE is ever loaded, FORM will be run at that time.
446 This makes or adds to an entry on `after-load-alist'.
447 FILE should be the name of a library, with no directory name."
448 (or (assoc file after-load-alist)
449 (setq after-load-alist (cons (list file) after-load-alist)))
450 (nconc (assoc file after-load-alist) (list form))
451 form)
452
453 (defun eval-next-after-load (file)
454 "Read the following input sexp, and run it whenever FILE is loaded.
455 This makes or adds to an entry on `after-load-alist'.
456 FILE should be the name of a library, with no directory name."
457 (eval-after-load file (read)))
458
459 \f
460 ;;;; Input and display facilities.
461
462 (defun read-quoted-char (&optional prompt)
463 "Like `read-char', except that if the first character read is an octal
464 digit, we read up to two more octal digits and return the character
465 represented by the octal number consisting of those digits.
466 Optional argument PROMPT specifies a string to use to prompt the user."
467 (let ((count 0) (code 0) char)
468 (while (< count 3)
469 (let ((inhibit-quit (zerop count))
470 (help-form nil))
471 (and prompt (message "%s-" prompt))
472 (setq char (read-char))
473 (if inhibit-quit (setq quit-flag nil)))
474 (cond ((null char))
475 ((and (<= ?0 char) (<= char ?7))
476 (setq code (+ (* code 8) (- char ?0))
477 count (1+ count))
478 (and prompt (message (setq prompt
479 (format "%s %c" prompt char)))))
480 ((> count 0)
481 (setq unread-command-events (list char) count 259))
482 (t (setq code char count 259))))
483 (logand 255 code)))
484
485 (defun force-mode-line-update (&optional all)
486 "Force the mode-line of the current buffer to be redisplayed.
487 With optional non-nil ALL then force then force redisplay of all mode-lines."
488 (if all (save-excursion (set-buffer (other-buffer))))
489 (set-buffer-modified-p (buffer-modified-p)))
490
491 (defun momentary-string-display (string pos &optional exit-char message)
492 "Momentarily display STRING in the buffer at POS.
493 Display remains until next character is typed.
494 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
495 otherwise it is then available as input (as a command if nothing else).
496 Display MESSAGE (optional fourth arg) in the echo area.
497 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
498 (or exit-char (setq exit-char ?\ ))
499 (let ((buffer-read-only nil)
500 (modified (buffer-modified-p))
501 (name buffer-file-name)
502 insert-end)
503 (unwind-protect
504 (progn
505 (save-excursion
506 (goto-char pos)
507 ;; defeat file locking... don't try this at home, kids!
508 (setq buffer-file-name nil)
509 (insert-before-markers string)
510 (setq insert-end (point)))
511 (message (or message "Type %s to continue editing.")
512 (single-key-description exit-char))
513 (let ((char (read-event)))
514 (or (eq char exit-char)
515 (setq unread-command-events (list char)))))
516 (if insert-end
517 (save-excursion
518 (delete-region pos insert-end)))
519 (setq buffer-file-name name)
520 (set-buffer-modified-p modified))))
521
522 \f
523 ;;;; Miscellanea.
524
525 (defun ignore (&rest ignore)
526 "Do nothing.
527 Accept any number of arguments, but ignore them."
528 nil)
529
530 (defun error (&rest args)
531 "Signal an error, making error message by passing all args to `format'."
532 (while t
533 (signal 'error (list (apply 'format args)))))
534
535 (defun user-original-login-name ()
536 "Return user's login name from original login.
537 This tries to remain unaffected by `su', by looking in environment variables."
538 (or (getenv "LOGNAME") (getenv "USER") (user-login-name)))
539
540 (defun start-process-shell-command (name buffer &rest args)
541 "Start a program in a subprocess. Return the process object for it.
542 Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
543 NAME is name for process. It is modified if necessary to make it unique.
544 BUFFER is the buffer or (buffer-name) to associate with the process.
545 Process output goes at end of that buffer, unless you specify
546 an output stream or filter function to handle the output.
547 BUFFER may be also nil, meaning that this process is not associated
548 with any buffer
549 Third arg is command name, the name of a shell command.
550 Remaining arguments are the arguments for the command.
551 Wildcards and redirection are handle as usual in the shell."
552 (if (eq system-type 'vax-vms)
553 (apply 'start-process name buffer args)
554 (start-process name buffer shell-file-name "-c"
555 (concat "exec " (mapconcat 'identity args " ")))))
556
557 (defmacro save-match-data (&rest body)
558 "Execute the BODY forms, restoring the global value of the match data."
559 (let ((original (make-symbol "match-data")))
560 (list
561 'let (list (list original '(match-data)))
562 (list 'unwind-protect
563 (cons 'progn body)
564 (list 'store-match-data original)))))
565
566 ;; now in fns.c
567 ;(defun nth (n list)
568 ; "Returns the Nth element of LIST.
569 ;N counts from zero. If LIST is not that long, nil is returned."
570 ; (car (nthcdr n list)))
571 ;
572 ;(defun copy-alist (alist)
573 ; "Return a copy of ALIST.
574 ;This is a new alist which represents the same mapping
575 ;from objects to objects, but does not share the alist structure with ALIST.
576 ;The objects mapped (cars and cdrs of elements of the alist)
577 ;are shared, however."
578 ; (setq alist (copy-sequence alist))
579 ; (let ((tail alist))
580 ; (while tail
581 ; (if (consp (car tail))
582 ; (setcar tail (cons (car (car tail)) (cdr (car tail)))))
583 ; (setq tail (cdr tail))))
584 ; alist)
585
586 ;;; subr.el ends here
587