MACRO is the name of the macro being defined.
DECL is a list `(declare ...)' containing the declarations.
The return value of this function is not used."
- (dolist (d (cdr decl))
- (cond ((and (consp d) (eq (car d) 'indent))
- (put macro 'lisp-indent-function (cadr d)))
- ((and (consp d) (eq (car d) 'debug))
- (put macro 'edebug-form-spec (cadr d)))
- (t
- (message "Unknown declaration %s" d)))))
+ ;; We can't use `dolist' or `cadr' yet for bootstrapping reasons.
+ (let (d)
+ ;; Ignore the first element of `decl' (it's always `declare').
+ (while (setq decl (cdr decl))
+ (setq d (car decl))
+ (cond ((and (consp d) (eq (car d) 'indent))
+ (put macro 'lisp-indent-function (car (cdr d))))
+ ((and (consp d) (eq (car d) 'debug))
+ (put macro 'edebug-form-spec (car (cdr d))))
+ (t
+ (message "Unknown declaration %s" d))))))
(setq macro-declaration-function 'macro-declaration-function)
"Add NEWELT to the list stored in the symbol LISTNAME.
This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
LISTNAME must be a symbol."
+ (declare (debug (form sexp)))
(list 'setq listname
(list 'cons newelt listname)))
LISTNAME must be a symbol whose value is a list.
If the value is nil, `pop' returns nil but does not actually
change the list."
+ (declare (debug (sexp)))
(list 'car
(list 'prog1 listname
(list 'setq listname (list 'cdr listname)))))
(defmacro when (cond &rest body)
"If COND yields non-nil, do BODY, else return nil."
+ (declare (indent 1) (debug t))
(list 'if cond (cons 'progn body)))
(defmacro unless (cond &rest body)
"If COND yields nil, do BODY, else return nil."
+ (declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
(defmacro dolist (spec &rest body)
- "(dolist (VAR LIST [RESULT]) BODY...): loop over a list.
+ "Loop over a list.
Evaluate BODY with VAR bound to each car from LIST, in turn.
-Then evaluate RESULT to get return value, default nil."
+Then evaluate RESULT to get return value, default nil.
+
+\(fn (VAR LIST [RESULT]) BODY...)"
+ (declare (indent 1) (debug ((symbolp form &optional form) body)))
(let ((temp (make-symbol "--dolist-temp--")))
- (list 'let (list (list temp (nth 1 spec)) (car spec))
- (list 'while temp
- (list 'setq (car spec) (list 'car temp))
- (cons 'progn
- (append body
- (list (list 'setq temp (list 'cdr temp))))))
- (if (cdr (cdr spec))
- (cons 'progn
- (cons (list 'setq (car spec) nil) (cdr (cdr spec))))))))
+ `(let ((,temp ,(nth 1 spec))
+ ,(car spec))
+ (while ,temp
+ (setq ,(car spec) (car ,temp))
+ (setq ,temp (cdr ,temp))
+ ,@body)
+ ,@(if (cdr (cdr spec))
+ `((setq ,(car spec) nil) ,@(cdr (cdr spec)))))))
(defmacro dotimes (spec &rest body)
- "(dotimes (VAR COUNT [RESULT]) BODY...): loop a certain number of times.
+ "Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers running from 0,
inclusive, to COUNT, exclusive. Then evaluate RESULT to get
-the return value (nil if RESULT is omitted)."
- (let ((temp (make-symbol "--dotimes-temp--")))
- (list 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
- (list 'while (list '< (car spec) temp)
- (cons 'progn
- (append body (list (list 'setq (car spec)
- (list '1+ (car spec)))))))
- (if (cdr (cdr spec))
- (car (cdr (cdr spec)))
- nil))))
+the return value (nil if RESULT is omitted).
+
+\(fn (VAR COUNT [RESULT]) BODY...)"
+ (declare (indent 1) (debug dolist))
+ (let ((temp (make-symbol "--dotimes-temp--"))
+ (start 0)
+ (end (nth 1 spec)))
+ `(let ((,temp ,end)
+ (,(car spec) ,start))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (setq ,(car spec) (1+ ,(car spec))))
+ ,@(cdr (cdr spec)))))
(defsubst caar (x)
"Return the car of the car of X."
(if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
x))))
+(defun number-sequence (from &optional to inc)
+ "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
+INC is the increment used between numbers in the sequence.
+So, the Nth element of the list is (+ FROM (* N INC)) where N counts from
+zero.
+If INC is nil, it defaults to 1 (one).
+If TO is nil, it defaults to FROM.
+If TO is less than FROM, the value is nil.
+Note that FROM, TO and INC can be integer or float."
+ (if (not to)
+ (list from)
+ (or inc (setq inc 1))
+ (let (seq)
+ (while (<= from to)
+ (setq seq (cons from seq)
+ from (+ from inc)))
+ (nreverse seq))))
+
(defun remove (elt seq)
"Return a copy of SEQ with all occurrences of ELT removed.
SEQ must be a list, vector, or string. The comparison is done with `equal'."
(delete elt (copy-sequence seq))))
(defun remq (elt list)
- "Return a copy of LIST with all occurrences of ELT removed.
-The comparison is done with `eq'."
+ "Return LIST with all occurrences of ELT removed.
+The comparison is done with `eq'. Contrary to `delq', this does not use
+side-effects, and the argument LIST is not modified."
(if (memq elt list)
(delq elt (copy-sequence list))
list))
(if (> c 127)
(logxor c listify-key-sequence-1)
c)))
- (append key nil))))
+ key)))
(defsubst eventp (obj)
"True if the argument is an event object."
The optional argument PROMPT specifies a string to use to prompt the user.
The variable `read-quoted-char-radix' controls which radix to use
for numeric input."
- (let ((message-log-max nil) done (first t) (code 0) char)
+ (let ((message-log-max nil) done (first t) (code 0) char translated)
(while (not done)
(let ((inhibit-quit first)
;; Don't let C-h get the help message--only help function keys.
;; We could try and use read-key-sequence instead, but then C-q ESC
;; or C-q C-x might not return immediately since ESC or C-x might be
;; bound to some prefix in function-key-map or key-translation-map.
- (and char
- (let ((translated (lookup-key function-key-map (vector char))))
- (if (arrayp translated)
- (setq char (aref translated 0)))))
- (cond ((null char))
- ((not (integerp char))
- (setq unread-command-events (listify-key-sequence (this-single-command-raw-keys))
+ (setq translated char)
+ (let ((translation (lookup-key function-key-map (vector char))))
+ (if (arrayp translation)
+ (setq translated (aref translation 0))))
+ (cond ((null translated))
+ ((not (integerp translated))
+ (setq unread-command-events (list char)
done t))
- ((/= (logand char ?\M-\^@) 0)
+ ((/= (logand translated ?\M-\^@) 0)
;; Turn a meta-character into a character with the 0200 bit set.
- (setq code (logior (logand char (lognot ?\M-\^@)) 128)
+ (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
done t))
- ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix))))
- (setq code (+ (* code read-quoted-char-radix) (- char ?0)))
- (and prompt (setq prompt (message "%s %c" prompt char))))
- ((and (<= ?a (downcase char))
- (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix))))
+ ((and (<= ?0 translated) (< translated (+ ?0 (min 10 read-quoted-char-radix))))
+ (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (<= ?a (downcase translated))
+ (< (downcase translated) (+ ?a -10 (min 36 read-quoted-char-radix))))
(setq code (+ (* code read-quoted-char-radix)
- (+ 10 (- (downcase char) ?a))))
- (and prompt (setq prompt (message "%s %c" prompt char))))
- ((and (not first) (eq char ?\C-m))
+ (+ 10 (- (downcase translated) ?a))))
+ (and prompt (setq prompt (message "%s %c" prompt translated))))
+ ((and (not first) (eq translated ?\C-m))
(setq done t))
((not first)
- (setq unread-command-events (listify-key-sequence (this-single-command-raw-keys))
+ (setq unread-command-events (list char)
done t))
- (t (setq code char
+ (t (setq code translated
done t)))
(setq first nil))
code))
(second (read-passwd "Confirm password: " nil default)))
(if (equal first second)
(progn
- (and (arrayp second) (fillarray second ?\0))
+ (and (arrayp second) (clear-string second))
(setq success first))
- (and (arrayp first) (fillarray first ?\0))
- (and (arrayp second) (fillarray second ?\0))
+ (and (arrayp first) (clear-string first))
+ (and (arrayp second) (clear-string second))
(message "Password not repeated accurately; please start over")
(sit-for 1))))
success)
(clear-this-command-keys)
(if (= c ?\C-u)
(progn
- (and (arrayp pass) (fillarray pass ?\0))
+ (and (arrayp pass) (clear-string pass))
(setq pass ""))
(if (and (/= c ?\b) (/= c ?\177))
(let* ((new-char (char-to-string c))
(new-pass (concat pass new-char)))
- (and (arrayp pass) (fillarray pass ?\0))
- (fillarray new-char ?\0)
+ (and (arrayp pass) (clear-string pass))
+ (clear-string new-char)
(setq c ?\0)
(setq pass new-pass))
(if (> (length pass) 0)
(let ((new-pass (substring pass 0 -1)))
- (and (arrayp pass) (fillarray pass ?\0))
+ (and (arrayp pass) (clear-string pass))
(setq pass new-pass))))))
(message nil)
(or pass default ""))))
call to `activate-change-group' and finish it with a single call
to `accept-change-group' or `cancel-change-group'."
- (list (cons (current-buffer) buffer-undo-list)))
+ (if buffer
+ (list (cons buffer (with-current-buffer buffer buffer-undo-list)))
+ (list (cons (current-buffer) buffer-undo-list))))
(defun activate-change-group (handle)
"Activate a change group made with `prepare-change-group' (which see)."
character numbers specifying the substring. They default to the
beginning and the end of BUFFER. Strip text properties from the
inserted text according to `yank-excluded-properties'."
+ ;; Since the buffer text should not normally have yank-handler properties,
+ ;; there is no need to handle them here.
(let ((opoint (point)))
(insert-buffer-substring buf start end)
(remove-yank-excluded-properties opoint (point))))
"Execute the forms in BODY with BUFFER as the current buffer.
The value returned is the value of the last form in BODY.
See also `with-temp-buffer'."
- (cons 'save-current-buffer
- (cons (list 'set-buffer buffer)
- body)))
+ (declare (indent 1) (debug t))
+ `(save-current-buffer
+ (set-buffer ,buffer)
+ ,@body))
+
+(defmacro with-selected-window (window &rest body)
+ "Execute the forms in BODY with WINDOW as the selected window.
+The value returned is the value of the last form in BODY.
+This does not alter the buffer list ordering.
+See also `with-temp-buffer'."
+ (declare (indent 1) (debug t))
+ ;; Most of this code is a copy of save-selected-window.
+ `(let ((save-selected-window-window (selected-window))
+ (save-selected-window-alist
+ (mapcar (lambda (frame) (list frame (frame-selected-window frame)))
+ (frame-list))))
+ (unwind-protect
+ (progn (select-window ,window 'norecord)
+ ,@body)
+ (dolist (elt save-selected-window-alist)
+ (and (frame-live-p (car elt))
+ (window-live-p (cadr elt))
+ (set-frame-selected-window (car elt) (cadr elt))))
+ (if (window-live-p save-selected-window-window)
+ ;; This is where the code differs from save-selected-window.
+ (select-window save-selected-window-window 'norecord)))))
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
The value returned is the value of the last form in BODY.
See also `with-temp-buffer'."
+ (declare (debug t))
(let ((temp-file (make-symbol "temp-file"))
(temp-buffer (make-symbol "temp-buffer")))
`(let ((,temp-file ,file)
MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
If MESSAGE is nil, the echo area and message log buffer are unchanged.
Use a MESSAGE of \"\" to temporarily clear the echo area."
+ (declare (debug t))
(let ((current-message (make-symbol "current-message"))
(temp-message (make-symbol "with-temp-message")))
`(let ((,temp-message ,message)
(defmacro with-temp-buffer (&rest body)
"Create a temporary buffer, and evaluate BODY there like `progn'.
See also `with-temp-file' and `with-output-to-string'."
+ (declare (indent 0) (debug t))
(let ((temp-buffer (make-symbol "temp-buffer")))
`(let ((,temp-buffer
(get-buffer-create (generate-new-buffer-name " *temp*"))))
(defmacro with-output-to-string (&rest body)
"Execute BODY, return the text it sent to `standard-output', as a string."
+ (declare (indent 0) (debug t))
`(let ((standard-output
(get-buffer-create (generate-new-buffer-name " *string-output*"))))
(let ((standard-output standard-output))
Do not alter `after-change-functions' or `before-change-functions'
in BODY."
+ (declare (indent 0) (debug t))
`(unwind-protect
(let ((combine-after-change-calls t))
. ,body)
(defmacro delay-mode-hooks (&rest body)
"Execute BODY, but delay any `run-mode-hooks'.
Only affects hooks run in the current buffer."
+ (declare (debug t))
`(progn
(make-local-variable 'delay-mode-hooks)
(let ((delay-mode-hooks t))
The syntax table of the current buffer is saved, BODY is evaluated, and the
saved table is restored, even in case of an abnormal exit.
Value is what BODY returns."
+ (declare (debug t))
(let ((old-table (make-symbol "table"))
(old-buffer (make-symbol "buffer")))
`(let ((,old-table (syntax-table))
(save-current-buffer
(set-buffer ,old-buffer)
(set-syntax-table ,old-table))))))
+
+(defmacro dynamic-completion-table (fun)
+ "Use function FUN as a dynamic completion table.
+FUN is called with one argument, the string for which completion is required,
+and it should return an alist containing all the intended possible
+completions. This alist may be a full list of possible completions so that FUN
+can ignore the value of its argument. If completion is performed in the
+minibuffer, FUN will be called in the buffer from which the minibuffer was
+entered.
+
+The result of the `dynamic-completion-table' form is a function
+that can be used as the ALIST argument to `try-completion' and
+`all-completion'. See Info node `(elisp)Programmed Completion'."
+ (let ((win (make-symbol "window"))
+ (string (make-symbol "string"))
+ (predicate (make-symbol "predicate"))
+ (mode (make-symbol "mode")))
+ `(lambda (,string ,predicate ,mode)
+ (with-current-buffer (let ((,win (minibuffer-selected-window)))
+ (if (window-live-p ,win) (window-buffer ,win)
+ (current-buffer)))
+ (cond
+ ((eq ,mode t) (all-completions ,string (,fun ,string) ,predicate))
+ ((not ,mode) (try-completion ,string (,fun ,string) ,predicate))
+ (t (test-completion ,string (,fun ,string) ,predicate)))))))
+
+(defmacro lazy-completion-table (var fun &rest args)
+ "Initialize variable VAR as a lazy completion table.
+If the completion table VAR is used for the first time (e.g., by passing VAR
+as an argument to `try-completion'), the function FUN is called with arguments
+ARGS. FUN must return the completion table that will be stored in VAR.
+If completion is requested in the minibuffer, FUN will be called in the buffer
+from which the minibuffer was entered. The return value of
+`lazy-completion-table' must be used to initialize the value of VAR."
+ (let ((str (make-symbol "string")))
+ `(dynamic-completion-table
+ (lambda (,str)
+ (unless (listp ,var)
+ (setq ,var (funcall ',fun ,@args)))
+ ,var))))
\f
;;; Matching and substitution
;; It is better not to use backquote here,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
+ (declare (indent 0) (debug t))
(list 'let
'((save-match-data-internal (match-data)))
(list 'unwind-protect
(buffer-substring-no-properties (match-beginning num)
(match-end num)))))
-(defun split-string (string &optional separators)
- "Splits STRING into substrings where there are matches for SEPARATORS.
-Each match for SEPARATORS is a splitting point.
-The substrings between the splitting points are made into a list
+(defun looking-back (regexp &optional limit)
+ "Return non-nil if text before point matches regular expression REGEXP.
+Like `looking-at' except backwards and slower.
+LIMIT if non-nil speeds up the search by specifying how far back the
+match can start."
+ (save-excursion
+ (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))
+
+(defconst split-string-default-separators "[ \f\t\n\r\v]+"
+ "The default value of separators for `split-string'.
+
+A regexp matching strings of whitespace. May be locale-dependent
+\(as yet unimplemented). Should not match non-breaking spaces.
+
+Warning: binding this to a different value and using it as default is
+likely to have undesired semantics.")
+
+;; The specification says that if both SEPARATORS and OMIT-NULLS are
+;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical
+;; expression leads to the equivalent implementation that if SEPARATORS
+;; is defaulted, OMIT-NULLS is treated as t.
+(defun split-string (string &optional separators omit-nulls)
+ "Splits STRING into substrings bounded by matches for SEPARATORS.
+
+The beginning and end of STRING, and each match for SEPARATORS, are
+splitting points. The substrings matching SEPARATORS are removed, and
+the substrings between the splitting points are collected as a list,
which is returned.
-If SEPARATORS is absent, it defaults to \"[ \\f\\t\\n\\r\\v]+\".
-If there is match for SEPARATORS at the beginning of STRING, we do not
-include a null substring for that. Likewise, if there is a match
-at the end of STRING, we don't include a null substring for that.
+If SEPARATORS is non-nil, it should be a regular expression matching text
+which separates, but is not part of, the substrings. If nil it defaults to
+`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
+OMIT-NULLS is forced to t.
+
+If OMIT-NULLs is t, zero-length substrings are omitted from the list \(so
+that for the default value of SEPARATORS leading and trailing whitespace
+are effectively trimmed). If nil, all zero-length substrings are retained,
+which correctly parses CSV format, for example.
+
+Note that the effect of `(split-string STRING)' is the same as
+`(split-string STRING split-string-default-separators t)'). In the rare
+case that you wish to retain zero-length substrings when splitting on
+whitespace, use `(split-string STRING split-string-default-separators)'.
Modifies the match data; use `save-match-data' if necessary."
- (let ((rexp (or separators "[ \f\t\n\r\v]+"))
+ (let ((keep-nulls (not (if separators omit-nulls t)))
+ (rexp (or separators split-string-default-separators))
(start 0)
notfirst
(list nil))
(= start (match-beginning 0))
(< start (length string)))
(1+ start) start))
- (< (match-beginning 0) (length string)))
+ (< start (length string)))
(setq notfirst t)
- (or (eq (match-beginning 0) 0)
- (and (eq (match-beginning 0) (match-end 0))
- (eq (match-beginning 0) start))
+ (if (or keep-nulls (< start (match-beginning 0)))
(setq list
(cons (substring string start (match-beginning 0))
list)))
(setq start (match-end 0)))
- (or (eq start (length string))
+ (if (or keep-nulls (< start (length string)))
(setq list
(cons (substring string start)
list)))
newstr))
(defun replace-regexp-in-string (regexp rep string &optional
- fixedcase literal subexp start)
+ fixedcase literal subexp start)
"Replace all matches for REGEXP with REP in STRING.
Return a new string containing the replacements.
rep
(funcall rep (match-string 0 str)))
fixedcase literal str subexp)
- (cons (substring string start mb) ; unmatched prefix
+ (cons (substring string start mb) ; unmatched prefix
matches)))
(setq start me))
;; Reconstruct a string from the pieces.
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is KEY.
-Return the modified alist."
+Return the modified alist.
+Elements of ALIST that are not conses are ignored."
(let ((tail alist))
(while tail
- (if (eq (car (car tail)) key)
+ (if (and (consp (car tail)) (eq (car (car tail)) key))
(setq alist (delq (car tail) alist)))
(setq tail (cdr tail)))
alist))
(set-default-file-modes umask))))
\f
+;; If a minor mode is not defined with define-minor-mode,
+;; add it here explicitly.
+;; isearch-mode is deliberately excluded, since you should
+;; not call it yourself.
+(defvar minor-mode-list '(auto-save-mode auto-fill-mode abbrev-mode
+ overwrite-mode view-mode)
+ "List of all minor mode functions.")
+
(defun add-minor-mode (toggle name &optional keymap after toggle-fun)
"Register a new minor mode.
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 (memq toggle minor-mode-list)
+ (push toggle minor-mode-list))
+
(unless toggle-fun (setq toggle-fun toggle))
;; Add the name to the minor-mode-alist.
(when name
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
+;;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc
;;; subr.el ends here
HCoop / bpt / emacs.git / blobdiff