;;; subr.el --- basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001
+;; Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
(setq m (1+ m) p (cdr p)))
(if (<= n 0) p
(if (< n m) (nthcdr (- m n) x) x)))
- (while (cdr x)
+ (while (consp (cdr x))
(setq x (cdr x)))
x))
+(defun butlast (x &optional n)
+ "Returns a copy of LIST with the last N elements removed."
+ (if (and n (<= n 0)) x
+ (nbutlast (copy-sequence x) n)))
+
+(defun nbutlast (x &optional n)
+ "Modifies LIST to remove the last N elements."
+ (let ((m (length x)))
+ (or n (setq n 1))
+ (and (< n m)
+ (progn
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+ x))))
+
+(defun remove (elt seq)
+ "Return a copy of SEQ with all occurences of ELT removed.
+SEQ must be a list, vector, or string. The comparison is done with `equal'."
+ (if (nlistp seq)
+ ;; If SEQ isn't a list, there's no need to copy SEQ because
+ ;; `delete' will return a new object.
+ (delete elt seq)
+ (delete elt (copy-sequence seq))))
+
+(defun remq (elt list)
+ "Return a copy of LIST with all occurences of ELT removed.
+The comparison is done with `eq'."
+ (if (memq elt list)
+ (delq elt (copy-sequence list))
+ list))
+
(defun assoc-default (key alist &optional test default)
"Find object KEY in a pseudo-alist ALIST.
ALIST is a list of conses or objects. Each element (or the element's car,
"Like `member', but ignores differences in case and text representation.
ELT must be a string. Upper-case and lower-case letters are treated as equal.
Unibyte strings are converted to multibyte for comparison."
- (let (element)
- (while (and list (not element))
- (if (eq t (compare-strings elt 0 nil (car list) 0 nil t))
- (setq element (car list)))
- (setq list (cdr list)))
- element))
+ (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
+ (setq list (cdr list)))
+ list)
\f
;;;; Keymap support.
"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.
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
-in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP."
+in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
+ ;; Don't document PREFIX in the doc string because we don't want to
+ ;; advertise it. It's meant for recursive calls only. Here's its
+ ;; meaning
+
+ ;; If optional argument PREFIX is specified, it should be a key
+ ;; prefix, a string. Redefined bindings will then be bound to the
+ ;; original key, with PREFIX added at the front.
(or prefix (setq prefix ""))
(let* ((scan (or oldmap keymap))
(vec1 (vector nil))
(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."
+The value is a printing character (not upper case) or a symbol."
(if (consp event)
(setq event (car event)))
(if (symbolp event)
(defalias 'define-function 'defalias)
(defalias 'sref 'aref)
-(make-obsolete 'sref 'aref)
-(make-obsolete 'char-bytes "Now this function always returns 1")
+(make-obsolete 'sref 'aref "20.4")
+(make-obsolete 'char-bytes "Now this function always returns 1" "20.4")
;; Some programs still use this as a function.
(defun baud-rate ()
(defalias 'search-backward-regexp (symbol-function 're-search-backward))
(defalias 'int-to-string 'number-to-string)
(defalias 'store-match-data 'set-match-data)
+;; These are the XEmacs names:
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
"Make the hook HOOK local to the current buffer.
The return value is HOOK.
+You never need to call this function now that `add-hook' does it for you
+if its LOCAL argument is non-nil.
+
When a hook is local, its local and global values
work in concert: running the hook actually runs all the hook
functions listed in *either* the local value *or* the global value
function, it is changed to a list of functions."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
- (if local (make-local-hook hook)
+ (if local (unless (local-variable-if-set-p hook) (make-local-hook hook))
;; Detect the case where make-local-variable was used on a hook
;; and do what we used to do.
(unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
(let ((hook-value (if local (symbol-value hook) (default-value hook))))
;; If the hook value is a single function, turn it into a list.
(when (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
- (set hook-value (list hook-value)))
+ (setq hook-value (list hook-value)))
;; Do the actual addition if necessary
(unless (member function hook-value)
(setq hook-value
`make-local-hook', not `make-local-variable'."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
- (if local (make-local-hook hook)
+ (if local (unless (local-variable-if-set-p hook) (make-local-hook hook))
;; Detect the case where make-local-variable was used on a hook
;; and do what we used to do.
(unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
(setq local t)))
(let ((hook-value (if local (symbol-value hook) (default-value hook))))
- ;; If the hook value is a single function, turn it into a list.
- (when (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
- (set hook-value (list hook-value)))
- ;; Do the actual removal if necessary
- (setq hook-value (delete function (copy-sequence hook-value)))
+ ;; Remove the function, for both the list and the non-list cases.
+ (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
+ (if (equal hook-value function) (setq hook-value nil))
+ (setq hook-value (delete function (copy-sequence hook-value))))
;; If the function is on the global hook, we need to shadow it locally
;;(when (and local (member function (default-value hook))
;; (not (member (cons 'not function) hook-value)))
;; Set the actual variable
(if local (set hook hook-value) (set-default hook hook-value))))
-(defun add-to-list (list-var element)
+(defun add-to-list (list-var element &optional append)
"Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
The test for presence of ELEMENT is done with `equal'.
-If ELEMENT is added, it is added at the beginning of the list.
+If ELEMENT is added, it is added at the beginning of the list,
+unless the optional argument APPEND is non-nil, in which case
+ELEMENT is added at the end.
If you want to use `add-to-list' on a variable that is not defined
until a certain package is loaded, you should put the call to `add-to-list'
other hooks, such as major mode hooks, can do the job."
(if (member element (symbol-value list-var))
(symbol-value list-var)
- (set list-var (cons element (symbol-value list-var)))))
+ (set list-var
+ (if append
+ (append (symbol-value list-var) (list element))
+ (cons element (symbol-value list-var))))))
\f
;;;; Specifying things to do after certain files are loaded.
This makes or adds to an entry on `after-load-alist'.
If FILE is already loaded, evaluate FORM right now.
It does nothing if FORM is already on the list for FILE.
-FILE should be the name of a library, with no directory name."
+FILE must match exactly. Normally FILE is the name of a library,
+with no directory or extension specified, since that is how `load'
+is normally called."
+ ;; Make sure `load-history' contains the files dumped with Emacs
+ ;; for the case that FILE is one of the files dumped with Emacs.
+ (load-symbol-file-load-history)
;; Make sure there is an element for FILE.
(or (assoc file after-load-alist)
(setq after-load-alist (cons (list file) after-load-alist)))
(let ((first (read-passwd prompt nil default))
(second (read-passwd "Confirm password: " nil default)))
(if (equal first second)
- (setq success first)
+ (progn
+ (and (arrayp second) (fillarray second ?\0))
+ (setq success first))
+ (and (arrayp first) (fillarray first ?\0))
+ (and (arrayp second) (fillarray second ?\0))
(message "Password not repeated accurately; please start over")
(sit-for 1))))
success)
(make-string (length pass) ?.))
(setq c (read-char-exclusive nil t))
(and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
+ (clear-this-command-keys)
(if (= c ?\C-u)
- (setq pass "")
+ (progn
+ (and (arrayp pass) (fillarray pass ?\0))
+ (setq pass ""))
(if (and (/= c ?\b) (/= c ?\177))
- (setq pass (concat pass (char-to-string c)))
+ (let* ((new-char (char-to-string c))
+ (new-pass (concat pass new-char)))
+ (and (arrayp pass) (fillarray pass ?\0))
+ (fillarray new-char ?\0)
+ (setq c ?\0)
+ (setq pass new-pass))
(if (> (length pass) 0)
- (setq pass (substring pass 0 -1))))))
- (clear-this-command-keys)
+ (let ((new-pass (substring pass 0 -1)))
+ (and (arrayp pass) (fillarray pass ?\0))
+ (setq pass new-pass))))))
(message nil)
(or pass default ""))))
\f
(combine-after-change-execute)))
-(defvar combine-run-hooks t
- "List of hooks delayed. Or t if we're not delaying hooks.")
-
-(defmacro combine-run-hooks (&rest body)
- "Execute BODY, but delay any `run-hooks' until the end."
- (let ((saved-combine-run-hooks (make-symbol "saved-combine-run-hooks"))
- (saved-run-hooks (make-symbol "saved-run-hooks")))
- `(let ((,saved-combine-run-hooks combine-run-hooks)
- (,saved-run-hooks (symbol-function 'run-hooks)))
- (unwind-protect
- (progn
- ;; If we're not delaying hooks yet, setup the delaying mode
- (unless (listp combine-run-hooks)
- (setq combine-run-hooks nil)
- (fset 'run-hooks
- ,(lambda (&rest hooks)
- (setq combine-run-hooks
- (append combine-run-hooks hooks)))))
- ,@body)
- ;; If we were not already delaying, then it's now time to set things
- ;; back to normal and to execute the delayed hooks.
- (unless (listp ,saved-combine-run-hooks)
- (setq ,saved-combine-run-hooks combine-run-hooks)
- (fset 'run-hooks ,saved-run-hooks)
- (setq combine-run-hooks t)
- (apply 'run-hooks ,saved-combine-run-hooks))))))
-
-
(defmacro with-syntax-table (table &rest body)
"Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
The syntax table of the current buffer is saved, BODY is evaluated, and the
(eq (car-safe object) 'lambda)
(and (symbolp object) (fboundp object))))
-;; now in fns.c
-;(defun nth (n list)
-; "Returns the Nth element of LIST.
-;N counts from zero. If LIST is not that long, nil is returned."
-; (car (nthcdr n list)))
-;
-;(defun copy-alist (alist)
-; "Return a copy of ALIST.
-;This is a new alist which represents the same mapping
-;from objects to objects, but does not share the alist structure with ALIST.
-;The objects mapped (cars and cdrs of elements of the alist)
-;are shared, however."
-; (setq alist (copy-sequence alist))
-; (let ((tail alist))
-; (while tail
-; (if (consp (car tail))
-; (setcar tail (cons (car (car tail)) (cdr (car tail)))))
-; (setq tail (cdr tail))))
-; alist)
+(defun interactive-form (function)
+ "Return the interactive form of FUNCTION.
+If function is a command (see `commandp'), value is a list of the form
+\(interactive SPEC). If function is not a command, return nil."
+ (setq function (indirect-function function))
+ (when (commandp function)
+ (cond ((byte-code-function-p function)
+ (when (> (length function) 5)
+ (let ((spec (aref function 5)))
+ (if spec
+ (list 'interactive spec)
+ (list 'interactive)))))
+ ((subrp function)
+ (subr-interactive-form function))
+ ((eq (car-safe function) 'lambda)
+ (setq function (cddr function))
+ (when (stringp (car function))
+ (setq function (cdr function)))
+ (let ((form (car function)))
+ (when (eq (car-safe form) 'interactive)
+ (copy-sequence form)))))))
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is KEY.
(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
"Register a new minor mode.
+This is an XEmacs-compatibility function. Use `define-minor-mode' instead.
+
TOGGLE is a symbol which is the name of a buffer-local variable that
is toggled on or off to say whether the minor mode is active or not.
Optional AFTER specifies that TOGGLE should be added after AFTER
in `minor-mode-alist'.
-Optional TOGGLE-FUN is there for compatiblity with other Emacsen.
-It is currently not used.
-
-In most cases, `define-minor-mode' should be used instead."
+Optional TOGGLE-FUN is an interactive function to toggle the mode.
+It defaults to (and should by convention be) TOGGLE.
+
+If TOGGLE has a non-nil `:included' property, an entry for the mode is
+included in the mode-line minor mode menu.
+If TOGGLE has a `:menu-tag', that is used for the menu item's label."
+ (unless toggle-fun (setq toggle-fun toggle))
+ ;; Add the toggle to the minor-modes menu if requested.
+ (when (get toggle :included)
+ (define-key mode-line-mode-menu
+ (vector toggle)
+ (list 'menu-item
+ (or (get toggle :menu-tag)
+ (if (stringp name) name (symbol-name toggle)))
+ toggle-fun
+ :button (cons :toggle toggle))))
+ ;; Add the name to the minor-mode-alist.
(when name
- (let ((existing (assq toggle minor-mode-alist))
- (name (if (symbolp name) (symbol-value name) name)))
- (cond ((null existing)
- (let ((tail minor-mode-alist) found)
- (while (and tail (not found))
- (if (eq after (caar tail))
- (setq found tail)
- (setq tail (cdr tail))))
- (if found
- (let ((rest (cdr found)))
- (setcdr found nil)
- (nconc found (list (list toggle name)) rest))
- (setq minor-mode-alist (cons (list toggle name)
- minor-mode-alist)))))
- (t
- (setcdr existing (list name))))))
-
+ (let ((existing (assq toggle minor-mode-alist)))
+ (when (and (stringp name) (not (get-text-property 0 'local-map name)))
+ (setq name
+ (apply 'propertize name
+ 'local-map (make-mode-line-mouse2-map toggle-fun)
+ (unless (get-text-property 0 'help-echo name)
+ (list 'help-echo
+ (format "mouse-2: turn off %S" toggle))))))
+ (if existing
+ (setcdr existing (list name))
+ (let ((tail minor-mode-alist) found)
+ (while (and tail (not found))
+ (if (eq after (caar tail))
+ (setq found tail)
+ (setq tail (cdr tail))))
+ (if found
+ (let ((rest (cdr found)))
+ (setcdr found nil)
+ (nconc found (list (list toggle name)) rest))
+ (setq minor-mode-alist (cons (list toggle name)
+ minor-mode-alist)))))))
+ ;; Add the map to the minor-mode-map-alist.
(when keymap
(let ((existing (assq toggle minor-mode-map-alist)))
- (cond ((null existing)
- (let ((tail minor-mode-map-alist) found)
- (while (and tail (not found))
- (if (eq after (caar tail))
- (setq found tail)
- (setq tail (cdr tail))))
- (if found
- (let ((rest (cdr found)))
- (setcdr found nil)
- (nconc found (list (cons toggle keymap)) rest))
- (setq minor-mode-map-alist (cons (cons toggle keymap)
- minor-mode-map-alist)))))
- (t
- (setcdr existing keymap))))))
-
+ (if existing
+ (setcdr existing keymap)
+ (let ((tail minor-mode-map-alist) found)
+ (while (and tail (not found))
+ (if (eq after (caar tail))
+ (setq found tail)
+ (setq tail (cdr tail))))
+ (if found
+ (let ((rest (cdr found)))
+ (setcdr found nil)
+ (nconc found (list (cons toggle keymap)) rest))
+ (setq minor-mode-map-alist (cons (cons toggle keymap)
+ minor-mode-map-alist))))))))
+
+;; XEmacs compatibility/convenience.
+(if (fboundp 'play-sound)
+ (defun play-sound-file (file &optional volume device)
+ "Play sound stored in FILE.
+VOLUME and DEVICE correspond to the keywords of the sound
+specification for `play-sound'."
+ (interactive "fPlay sound file: ")
+ (let ((sound (list :file file)))
+ (if volume
+ (plist-put sound :volume volume))
+ (if device
+ (plist-put sound :device device))
+ (push 'sound sound)
+ (play-sound sound))))
;;; subr.el ends here