X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ffd56f97cf56501f7a6981c184192e9043e4eafd..d1b985ec39dc2a7e04b376b41bc717ee95244522:/lisp/subr.el diff --git a/lisp/subr.el b/lisp/subr.el index c29261c7d5..88fbb517fa 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1,11 +1,12 @@ -;; Basic lisp subroutines for Emacs -;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. +;;; subr.el --- basic lisp subroutines for Emacs + +;;; Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 1, or (at your option) +;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -17,27 +18,35 @@ ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; Code: -(defun one-window-p (&optional arg) +(defun one-window-p (&optional nomini) "Returns non-nil if there is only one window. Optional arg NOMINI non-nil means don't count the minibuffer even if it is active." - (eq (selected-window) - (next-window (selected-window) (if arg 'arg)))) + (let ((base-window (selected-window))) + (if (and nomini (eq base-window (minibuffer-window))) + (setq base-window (next-window base-window))) + (eq base-window + (next-window base-window (if nomini 'arg))))) -(defun walk-windows (proc &optional minibuf all-screens) +(defun walk-windows (proc &optional minibuf all-frames) "Cycle through all visible windows, calling PROC for each one. PROC is called with a window as argument. Optional second arg MINIBUF t means count the minibuffer window even if not active. If MINIBUF is neither t nor nil it means not to count the minibuffer even if it is active. -Optional third arg ALL-SCREENS t means include all windows in all screens; -otherwise cycle within the selected screen." + +Optional third arg ALL-FRAMES, if t, means include all frames. +ALL-FRAMES nil or omitted means cycle within the selected frame, +but include the minibuffer window (if MINIBUF says so) that that +frame uses, even if it is on another frame. +If ALL-FRAMES is neither nil nor t, stick strictly to the selected frame." (let* ((walk-windows-start (selected-window)) (walk-windows-current walk-windows-start)) (while (progn (setq walk-windows-current - (next-window walk-windows-current minibuf all-screens)) + (next-window walk-windows-current minibuf all-frames)) (funcall proc walk-windows-current) (not (eq walk-windows-current walk-windows-start)))))) @@ -60,7 +69,7 @@ Optional argument PROMPT specifies a string to use to prompt the user." (and prompt (message (setq prompt (format "%s %c" prompt char))))) ((> count 0) - (setq unread-command-char char count 259)) + (setq unread-command-events (list char) count 259)) (t (setq code char count 259)))) (logand 255 code))) @@ -73,6 +82,11 @@ Optional argument PROMPT specifies a string to use to prompt the user." (interactive) (ding)) +;; Some programs still use this as a function. +(defun baud-rate () + "Obsolete function returning the value of the `baud-rate' variable." + baud-rate) + ;Prevent the \{...} documentation construct ;from mentioning keys that run this command. (put 'undefined 'suppress-keymap t) @@ -124,32 +138,184 @@ but optional second arg NODIGITS non-nil treats them like other chars." ; (copy-sequence keymap) ; (copy-alist keymap))) -(defun substitute-key-definition (olddef newdef keymap) +(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. In other words, OLDDEF is replaced with NEWDEF where ever it appears. -Prefix keymaps reached from KEYMAP are not checked recursively; -perhaps they ought to be." - (if (arrayp keymap) - (let ((len (length keymap)) - (i 0)) - (while (< i len) - (if (eq (aref keymap i) olddef) - (aset keymap i newdef)) - (setq i (1+ i)))) - (while keymap - (if (eq (cdr-safe (car-safe keymap)) olddef) - (setcdr (car keymap) newdef)) - (setq keymap (cdr keymap))))) - -;; Avoids useless byte-compilation. -;; In the future, would be better to fix byte compiler -;; not to really compile in cases like this, -;; and use defun here. -(fset 'ignore '(lambda (&rest ignore) - "Do nothing. -Accept any number of arguments, but ignore them." - nil)) +If optional fourth argument OLDMAP is specified, we redefine +in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP." + (or prefix (setq prefix "")) + (let* ((scan (or oldmap keymap)) + (vec1 (vector nil)) + (prefix1 (vconcat prefix vec1))) + ;; Scan OLDMAP, finding each char or event-symbol that + ;; has any definition, and act on it with hack-key. + (while (consp scan) + (if (consp (car scan)) + (let ((char (car (car scan))) + (defn (cdr (car scan)))) + ;; The inside of this let duplicates exactly + ;; the inside of the following let that handles array elements. + (aset vec1 0 char) + (aset prefix1 (length prefix) char) + (let (inner-def) + ;; Skip past menu-prompt. + (while (stringp (car-safe defn)) + (setq defn (cdr defn))) + (setq inner-def defn) + (while (and (symbolp inner-def) + (fboundp inner-def)) + (setq inner-def (symbol-function inner-def))) + (if (eq defn olddef) + (define-key keymap prefix1 newdef) + (if (keymapp defn) + (substitute-key-definition olddef newdef keymap + inner-def + prefix1))))) + (if (arrayp (car scan)) + (let* ((array (car scan)) + (len (length array)) + (i 0)) + (while (< i len) + (let ((char i) (defn (aref array i))) + ;; The inside of this let duplicates exactly + ;; the inside of the previous let. + (aset vec1 0 char) + (aset prefix1 (length prefix) char) + (let (inner-def) + ;; Skip past menu-prompt. + (while (stringp (car-safe defn)) + (setq defn (cdr defn))) + (setq inner-def defn) + (while (and (symbolp inner-def) + (fboundp inner-def)) + (setq inner-def (symbol-function inner-def))) + (if (eq defn olddef) + (define-key keymap prefix1 newdef) + (if (keymapp defn) + (substitute-key-definition olddef newdef keymap + inner-def + prefix1))))) + (setq i (1+ i)))))) + (setq scan (cdr scan))))) + +(defun listify-key-sequence (key) + "Convert a key sequence to a list of events." + (if (vectorp key) + (append key nil) + (mapcar (function (lambda (c) + (if (> c 127) + (logxor c 8388736) + c))) + (append key nil)))) + +(defsubst eventp (obj) + "True if the argument is an event object." + (or (integerp obj) + (and (symbolp obj) + (get obj 'event-symbol-elements)) + (and (consp obj) + (symbolp (car obj)) + (get (car obj) 'event-symbol-elements)))) + +(defun event-modifiers (event) + "Returns a list of symbols representing the modifier keys in event EVENT. +The elements of the list may include `meta', `control', +`shift', `hyper', `super', `alt'. +See also the function `event-modifier-bits'." + (let ((type event)) + (if (listp type) + (setq type (car type))) + (if (symbolp type) + (cdr (get type 'event-symbol-elements)) + (let ((list nil)) + (or (zerop (logand type (lsh 1 23))) + (setq list (cons 'meta list))) + (or (and (zerop (logand type (lsh 1 22))) + (>= (logand type 127) 32)) + (setq list (cons 'control list))) + (or (and (zerop (logand type (lsh 1 21))) + (= (logand type 255) (downcase (logand type 255)))) + (setq list (cons 'shift list))) + (or (zerop (logand type (lsh 1 20))) + (setq list (cons 'hyper list))) + (or (zerop (logand type (lsh 1 19))) + (setq list (cons 'super list))) + (or (zerop (logand type (lsh 1 18))) + (setq list (cons 'alt list))) + list)))) + +(defun event-basic-type (event) + "Returns the basic type of the given event (all modifiers removed). +The value is an ASCII printing character (not upper case) or a symbol." + (if (symbolp event) + (car (get event 'event-symbol-elements)) + (let ((base (logand event (1- (lsh 1 18))))) + (downcase (if (< base 32) (logior base 64) base))))) + +(defsubst mouse-movement-p (object) + "Return non-nil if OBJECT is a mouse movement event." + (and (consp object) + (eq (car object) 'mouse-movement))) + +(defsubst event-start (event) + "Return the starting position of EVENT. +If EVENT is a mouse press or a mouse click, this returns the location +of the event. +If EVENT is a drag, this returns the drag's starting position. +The return value is of the form + (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP) +The `posn-' functions access elements of such lists." + (nth 1 event)) +(defsubst event-end (event) + "Return the ending location of EVENT. EVENT should be a click or drag event. +If EVENT is a click event, this function is the same as `event-start'. +The return value is of the form + (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP) +The `posn-' functions access elements of such lists." + (nth (1- (length event)) event)) + +(defsubst posn-window (position) + "Return the window in POSITION. +POSITION should be a list of the form + (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP) +as returned by the `event-start' and `event-end' functions." + (nth 0 position)) + +(defsubst posn-point (position) + "Return the buffer location in POSITION. +POSITION should be a list of the form + (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP) +as returned by the `event-start' and `event-end' functions." + (nth 1 position)) + +(defsubst posn-col-row (position) + "Return the row and column in POSITION. +POSITION should be a list of the form + (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP) +as returned by the `event-start' and `event-end' functions." + (nth 2 position)) + +(defsubst posn-timestamp (position) + "Return the timestamp of POSITION. +POSITION should be a list of the form + (WINDOW BUFFER-POSITION (COL . ROW) TIMESTAMP) +nas returned by the `event-start' and `event-end' functions." + (nth 3 position)) + +(defmacro save-match-data (&rest body) + "Execute the BODY forms, restoring the global value of the match data." + (let ((original (make-symbol "match-data"))) + (list + 'let (list (list original '(match-data))) + (list 'unwind-protect + (cons 'progn body) + (list 'store-match-data original))))) + +(defun ignore (&rest ignore) + "Do nothing. +Accept any number of arguments, but ignore them." + nil) ; old names (fset 'make-syntax-table 'copy-syntax-table) @@ -164,6 +330,15 @@ Accept any number of arguments, but ignore them." (fset 'send-region 'process-send-region) (fset 'show-buffer 'set-window-buffer) (fset 'buffer-flush-undo 'buffer-disable-undo) +(fset 'eval-current-buffer 'eval-buffer) +(fset 'compiled-function-p 'byte-code-function-p) + +;;; This name isn't mentioned in the manual, and we've been hoping to +;;; phase it out, but there's still a lot of code out there, even for +;;; Emacs 18.59, which uses mod. I'm going to let the byte compiler's +;;; make-obsolete function to poke people a little more, and leave the +;;; `mod' name around for a while longer. +(fset 'mod '%) ; alternate names (fset 'string= 'string-equal) @@ -171,7 +346,6 @@ Accept any number of arguments, but ignore them." (fset 'move-marker 'set-marker) (fset 'eql 'eq) (fset 'not 'null) -(fset 'numberp 'integerp) (fset 'rplaca 'setcar) (fset 'rplacd 'setcdr) (fset 'beep 'ding) ;preserve lingual purtity @@ -179,6 +353,11 @@ Accept any number of arguments, but ignore them." (fset 'backward-delete-char 'delete-backward-char) (fset 'search-forward-regexp (symbol-function 're-search-forward)) (fset 'search-backward-regexp (symbol-function 're-search-backward)) +(fset 'int-to-string 'number-to-string) + +;;; Should this be an obsolete name? If you decide it should, you get +;;; to go through all the sources and change them. +(fset 'string-to-int 'string-to-number) ;;; global-map, esc-map, and ctl-x-map have their values set up ;;; in keymap.c. @@ -200,10 +379,10 @@ The normal global definition of the character C-x indirects to this keymap.") (fset 'ctl-x-4-prefix ctl-x-4-map) (define-key ctl-x-map "4" 'ctl-x-4-prefix) -(defvar ctl-x-3-map (make-sparse-keymap) - "Keymap for screen commands.") -(fset 'ctl-x-3-prefix ctl-x-3-map) -(define-key ctl-x-map "3" 'ctl-x-3-prefix) +(defvar ctl-x-5-map (make-sparse-keymap) + "Keymap for frame commands.") +(fset 'ctl-x-5-prefix ctl-x-5-map) +(define-key ctl-x-map "5" 'ctl-x-5-prefix) (defun run-hooks (&rest hooklist) @@ -229,11 +408,12 @@ If it is a list, the elements are called, in order, with no arguments." "Variable by which C primitives find the function `run-hooks'. Don't change it.") -(defun add-hook (hook function) - "Add to the value of HOOK the function FUNCTION unless already present. -HOOK should be a symbol, and FUNCTION may be any valid function. -HOOK's value should be a list of functions, not a single function. -If HOOK is void, it is first set to nil." +(defun add-hook (hook function &optional append) + "Add to the value of HOOK the function FUNCTION unless already present (it +becomes the first hook on the list unless optional APPEND is non-nil, in +which case it becomes the last). HOOK should be a symbol, and FUNCTION may be +any valid function. HOOK's value should be a list of functions, not a single +function. If HOOK is void, it is first set to nil." (or (boundp hook) (set hook nil)) (or (if (consp function) ;; Clever way to tell whether a given lambda-expression @@ -241,7 +421,10 @@ If HOOK is void, it is first set to nil." (let ((tail (assoc (cdr function) (symbol-value hook)))) (equal function tail)) (memq function (symbol-value hook))) - (set hook (cons function (symbol-value hook))))) + (set hook + (if append + (nconc (symbol-value hook) (list function)) + (cons function (symbol-value hook)))))) (defun momentary-string-display (string pos &optional exit-char message) "Momentarily display STRING in the buffer at POS. @@ -265,9 +448,9 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." (setq insert-end (point))) (message (or message "Type %s to continue editing.") (single-key-description exit-char)) - (let ((char (read-char))) + (let ((char (read-event))) (or (eq char exit-char) - (setq unread-command-char char)))) + (setq unread-command-events (list char))))) (if insert-end (save-excursion (delete-region pos insert-end))) @@ -306,16 +489,16 @@ This makes or adds to an entry on `after-load-alist'. FILE should be the name of a library, with no directory name." (eval-after-load file (read))) -(defmacro defun-inline (name args &rest body) - "Create an \"inline defun\" (actually a macro). -Use just like `defun'." - (nconc (list 'defmacro name '(&rest args)) - (if (stringp (car body)) - (prog1 (list (car body)) - (setq body (or (cdr body) body)))) - (list (list 'cons (list 'quote - (cons 'lambda (cons args body))) - 'args)))) +;;(defmacro defun-inline (name args &rest body) +;; "Create an \"inline defun\" (actually a macro). +;;Use just like `defun'." +;; (nconc (list 'defmacro name '(&rest args)) +;; (if (stringp (car body)) +;; (prog1 (list (car body)) +;; (setq body (or (cdr body) body)))) +;; (list (list 'cons (list 'quote +;; (cons 'lambda (cons args body))) +;; 'args)))) (defun user-original-login-name () "Return user's login name from original login. @@ -332,15 +515,34 @@ With optional non-nil ALL then force then force redisplay of all mode-lines." "Translate character FROM to TO at a low level. This function creates a `keyboard-translate-table' if necessary and then modifies one entry in it." - (or (boundp 'keyboard-translate-table) - (let ((table (make-string 256)) - (i 0)) - (while (< i 256) - (aset table i i) - (setq i (1+ i))) - (setq keyboard-translate-table table))) + (or (arrayp keyboard-translate-table) + (setq keyboard-translate-table "")) + (if (or (> from (length keyboard-translate-table)) + (> to (length keyboard-translate-table))) + (progn + (let* ((i (length keyboard-translate-table)) + (table (make-string (- 256 i) 0))) + (while (< i 256) + (aset table i i) + (setq i (1+ i))) + (setq keyboard-translate-table table)))) (aset keyboard-translate-table from to)) (defmacro lambda (&rest cdr) - (` (function (lambda (,@ cdr))))) + "Return a lambda expression. +A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is +self-quoting; the result of evaluating the lambda expression is the +expression itself. The lambda expression may then be treated as a +function, i. e. stored as the function value of a symbol, passed to +funcall or mapcar, etcetera. +ARGS should take the same form as an argument list for a `defun'. +DOCSTRING should be a string, as described for `defun'. It may be omitted. +INTERACTIVE should be a call to the function `interactive', which see. +It may also be omitted. +BODY should be a list of lisp expressions." + ;; Note that this definition should not use backquotes; subr.el should not + ;; depend on backquote.el. + (list 'function (cons 'lambda cdr))) + +;;; subr.el ends here