-;; 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,
;; 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))))))
(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)))
(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)
; (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)))))
+\f
+(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))
+\f
+(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)
\f
; old names
(fset 'make-syntax-table 'copy-syntax-table)
(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)
(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
(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)
\f
;;; global-map, esc-map, and ctl-x-map have their values set up
;;; in keymap.c.
(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)
\f
(defun run-hooks (&rest hooklist)
"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
(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))))))
\f
(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
(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)))
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))))
\f
(defun user-original-login-name ()
"Return user's login name from original login.
"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))
\f
(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