;;; subr.el --- basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002
+;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002, 03, 2004
;; Free Software Foundation, Inc.
;; Maintainer: FSF
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)
(defalias 'not 'null)
+(defmacro noreturn (form)
+ "Evaluates FORM, with the expectation that the evaluation will signal an error
+instead of returning to its caller. If FORM does return, an error is
+signalled."
+ `(prog1 ,form
+ (error "Form marked with `noreturn' did return")))
+
+(defmacro 1value (form)
+ "Evaluates FORM, with the expectation that all the same value will be returned
+from all evaluations of FORM. This is the global do-nothing
+version of `1value'. There is also `testcover-1value' that
+complains if FORM ever does return differing values."
+ form)
+
(defmacro lambda (&rest cdr)
"Return a lambda expression.
A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
But documentation strings are usually not useful in nameless functions.
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
-BODY should be a list of lisp expressions."
+BODY should be a list of Lisp expressions.
+
+\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
;; Note that this definition should not use backquotes; subr.el should not
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
"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."
- (list 'prog1 (list 'car listname)
- (list 'setq listname (list 'cdr listname))))
+ (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)))))
+
+(defmacro declare (&rest specs)
+ "Do not evaluate any arguments and return nil.
+Treated as a declaration when used at the right place in a
+`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
+ nil)
(defsubst caar (x)
"Return the car of the car of X."
"Return the cdr of the cdr of X."
(cdr (cdr x)))
-(defun last (x &optional n)
- "Return the last link of the list X. Its car is the last element.
-If X is nil, return nil.
-If N is non-nil, return the Nth-to-last link of X.
-If N is bigger than the length of X, return X."
+(defun last (list &optional n)
+ "Return the last link of LIST. Its car is the last element.
+If LIST is nil, return nil.
+If N is non-nil, return the Nth-to-last link of LIST.
+If N is bigger than the length of LIST, return LIST."
(if n
- (let ((m 0) (p x))
+ (let ((m 0) (p list))
(while (consp p)
(setq m (1+ m) p (cdr p)))
(if (<= n 0) p
- (if (< n m) (nthcdr (- m n) x) x)))
- (while (consp (cdr x))
- (setq x (cdr x)))
- x))
+ (if (< n m) (nthcdr (- m n) list) list)))
+ (while (consp (cdr list))
+ (setq list (cdr list)))
+ list))
-(defun butlast (x &optional n)
+(defun butlast (list &optional n)
"Returns a copy of LIST with the last N elements removed."
- (if (and n (<= n 0)) x
- (nbutlast (copy-sequence x) n)))
+ (if (and n (<= n 0)) list
+ (nbutlast (copy-sequence list) n)))
-(defun nbutlast (x &optional n)
+(defun nbutlast (list &optional n)
"Modifies LIST to remove the last N elements."
- (let ((m (length x)))
+ (let ((m (length list)))
(or n (setq n 1))
(and (< n m)
(progn
- (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
- x))))
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
+ list))))
+
+(defun delete-dups (list)
+ "Destructively remove `equal' duplicates from LIST.
+Store the result in LIST and return it. LIST must be a proper list.
+Of several `equal' occurrences of an element in LIST, the first
+one is kept."
+ (let ((tail list))
+ (while tail
+ (setcdr tail (delete (car tail) (cdr tail)))
+ (setq tail (cdr tail))))
+ list)
+
+(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 and defaults to 1.
+So, the Nth element of the list is \(+ FROM \(* N INC)) where N counts from
+zero. TO is only included if there is an N for which TO = FROM + N * INC.
+If TO is nil or numerically equal to FROM, return \(FROM).
+If INC is positive and TO is less than FROM, or INC is negative
+and TO is larger than FROM, return nil.
+If INC is zero and TO is neither nil nor numerically equal to
+FROM, signal an error.
+
+This function is primarily designed for integer arguments.
+Nevertheless, FROM, TO and INC can be integer or float. However,
+floating point arithmetic is inexact. For instance, depending on
+the machine, it may quite well happen that
+\(number-sequence 0.4 0.6 0.2) returns the one element list \(0.4),
+whereas \(number-sequence 0.4 0.8 0.2) returns a list with three
+elements. Thus, if some of the arguments are floats and one wants
+to make sure that TO is included, one may have to explicitly write
+TO as \(+ FROM \(* N INC)) or use a variable whose value was
+computed with this exact expression. Alternatively, you can,
+of course, also replace TO with a slightly larger value
+\(or a slightly more negative value if INC is negative)."
+ (if (or (not to) (= from to))
+ (list from)
+ (or inc (setq inc 1))
+ (when (zerop inc) (error "The increment can not be zero"))
+ (let (seq (n 0) (next from))
+ (if (> inc 0)
+ (while (<= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc))))
+ (while (>= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc)))))
+ (nreverse seq))))
(defun remove (elt seq)
"Return a copy of SEQ with all occurrences of ELT removed.
(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'."
+ "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))
+(defun copy-tree (tree &optional vecp)
+ "Make a copy of TREE.
+If TREE is a cons cell, this recursively copies both its car and its cdr.
+Contrast to `copy-sequence', which copies only along the cdrs. With second
+argument VECP, this copies vectors as well as conses."
+ (if (consp tree)
+ (let (result)
+ (while (consp tree)
+ (let ((newcar (car tree)))
+ (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
+ (setq newcar (copy-tree (car tree) vecp)))
+ (push newcar result))
+ (setq tree (cdr tree)))
+ (nconc (nreverse result) tree))
+ (if (and vecp (vectorp tree))
+ (let ((i (length (setq tree (copy-sequence tree)))))
+ (while (>= (setq i (1- i)) 0)
+ (aset tree i (copy-tree (aref tree i) vecp)))
+ tree)
+ tree)))
+
(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,
(setq tail (cdr tail)))
value))
+(make-obsolete 'assoc-ignore-case 'assoc-string)
(defun assoc-ignore-case (key alist)
"Like `assoc', but ignores differences in case and text representation.
KEY 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 alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc-string key alist t))
+(make-obsolete 'assoc-ignore-representation 'assoc-string)
(defun assoc-ignore-representation (key alist)
"Like `assoc', but ignores differences in text representation.
-KEY must be a string.
+KEY must be a string.
Unibyte strings are converted to multibyte for comparison."
- (let (element)
- (while (and alist (not element))
- (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil))
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
+ (assoc-string key alist nil))
(defun member-ignore-case (elt list)
"Like `member', but ignores differences in case and text representation.
"Make MAP override all normally self-inserting keys to be undefined.
Normally, as an exception, digits and minus-sign are set to make prefix args,
but optional second arg NODIGITS non-nil treats them like other chars."
- (substitute-key-definition 'self-insert-command 'undefined map global-map)
+ (define-key map [remap self-insert-command] 'undefined)
(or nodigits
(let (loop)
(define-key map "-" 'negative-argument)
;Moved to keymap.c
;(defun copy-keymap (keymap)
-; "Return a copy of KEYMAP"
+; "Return a copy of KEYMAP"
; (while (not (keymapp keymap))
; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
; (if (vectorp keymap)
;; 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.
(aset keyboard-translate-table from to))
\f
-;;;; The global keymap tree.
+;;;; The global keymap tree.
;;; global-map, esc-map, and ctl-x-map have their values set up in
;;; keymap.c; we just give them docstrings here.
(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."
- (or (integerp obj)
+ (or (and (integerp obj)
+ ;; Filter out integers too large to be events.
+ ;; M is the biggest modifier.
+ (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
+ (char-valid-p (event-basic-type obj)))
(and (symbolp obj)
(get obj 'event-symbol-elements))
(and (consp obj)
(setq type (car type)))
(if (symbolp type)
(cdr (get type 'event-symbol-elements))
- (let ((list nil))
- (or (zerop (logand type ?\M-\^@))
+ (let ((list nil)
+ (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
+ ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
+ (if (not (zerop (logand type ?\M-\^@)))
(setq list (cons 'meta list)))
- (or (and (zerop (logand type ?\C-\^@))
- (>= (logand type 127) 32))
+ (if (or (not (zerop (logand type ?\C-\^@)))
+ (< char 32))
(setq list (cons 'control list)))
- (or (and (zerop (logand type ?\S-\^@))
- (= (logand type 255) (downcase (logand type 255))))
+ (if (or (not (zerop (logand type ?\S-\^@)))
+ (/= char (downcase char)))
(setq list (cons 'shift list)))
(or (zerop (logand type ?\H-\^@))
(setq list (cons 'hyper list)))
(defsubst event-start (event)
"Return the starting position of EVENT.
-If EVENT is a mouse press or a mouse click, this returns the location
+If EVENT is a mouse or key 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 (X . Y) TIMESTAMP)
+ (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
+ IMAGE (DX . DY) (WIDTH . HEIGHT))
The `posn-' functions access elements of such lists."
- (nth 1 event))
+ (if (consp event) (nth 1 event)
+ (list (selected-window) (point) '(0 . 0) 0)))
(defsubst event-end (event)
- "Return the ending location of EVENT. EVENT should be a click or drag event.
+ "Return the ending location of EVENT.
+EVENT should be a click, drag, or key press 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 (X . Y) TIMESTAMP)
+ (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
+ IMAGE (DX . DY) (WIDTH . HEIGHT))
The `posn-' functions access elements of such lists."
- (nth (if (consp (nth 2 event)) 2 1) event))
+ (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
+ (list (selected-window) (point) '(0 . 0) 0)))
(defsubst event-click-count (event)
"Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
- (if (integerp (nth 2 event)) (nth 2 event) 1))
+ (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
(defsubst posn-window (position)
"Return the window in POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
(nth 0 position))
+(defsubst posn-area (position)
+ "Return the window area recorded in POSITION, or nil for the text area.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (let ((area (if (consp (nth 1 position))
+ (car (nth 1 position))
+ (nth 1 position))))
+ (and (symbolp area) area)))
+
(defsubst posn-point (position)
"Return the buffer location in POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
- (if (consp (nth 1 position))
- (car (nth 1 position))
- (nth 1 position)))
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (or (nth 5 position)
+ (if (consp (nth 1 position))
+ (car (nth 1 position))
+ (nth 1 position))))
+
+(defun posn-set-point (position)
+ "Move point to POSITION.
+Select the corresponding window as well."
+ (if (not (windowp (posn-window position)))
+ (error "Position not in text area of window"))
+ (select-window (posn-window position))
+ (if (numberp (posn-point position))
+ (goto-char (posn-point position))))
(defsubst posn-x-y (position)
"Return the x and y coordinates in POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
(nth 2 position))
(defun posn-col-row (position)
- "Return the column and row in POSITION, measured in characters.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions.
+ "Return the nominal column and row in POSITION, measured in characters.
+The column and row values are approximations calculated from the x
+and y coordinates in POSITION and the frame's default character width
+and height.
For a scroll-bar event, the result column is 0, and the row
-corresponds to the vertical position of the click in the scroll bar."
- (let ((pair (nth 2 position))
- (window (posn-window position)))
- (if (eq (if (consp (nth 1 position))
- (car (nth 1 position))
- (nth 1 position))
- 'vertical-scroll-bar)
- (cons 0 (scroll-bar-scale pair (1- (window-height window))))
- (if (eq (if (consp (nth 1 position))
- (car (nth 1 position))
- (nth 1 position))
- 'horizontal-scroll-bar)
- (cons (scroll-bar-scale pair (window-width window)) 0)
- (let* ((frame (if (framep window) window (window-frame window)))
- (x (/ (car pair) (frame-char-width frame)))
- (y (/ (cdr pair) (frame-char-height frame))))
- (cons x y))))))
+corresponds to the vertical position of the click in the scroll bar.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (let* ((pair (posn-x-y position))
+ (window (posn-window position))
+ (area (posn-area position)))
+ (cond
+ ((null window)
+ '(0 . 0))
+ ((eq area 'vertical-scroll-bar)
+ (cons 0 (scroll-bar-scale pair (1- (window-height window)))))
+ ((eq area 'horizontal-scroll-bar)
+ (cons (scroll-bar-scale pair (window-width window)) 0))
+ (t
+ (let* ((frame (if (framep window) window (window-frame window)))
+ (x (/ (car pair) (frame-char-width frame)))
+ (y (/ (cdr pair) (+ (frame-char-height frame)
+ (or (frame-parameter frame 'line-spacing)
+ default-line-spacing
+ 0)))))
+ (cons x y))))))
+
+(defun posn-actual-col-row (position)
+ "Return the actual column and row in POSITION, measured in characters.
+These are the actual row number in the window and character number in that row.
+Return nil if POSITION does not contain the actual position; in that case
+`posn-col-row' can be used to get approximate values.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 6 position))
(defsubst posn-timestamp (position)
"Return the timestamp of POSITION.
-POSITION should be a list of the form
- (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
-as returned by the `event-start' and `event-end' functions."
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
(nth 3 position))
+(defsubst posn-string (position)
+ "Return the string object of POSITION, or nil if a buffer position.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 4 position))
+
+(defsubst posn-image (position)
+ "Return the image object of POSITION, or nil if a not an image.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 7 position))
+
+(defsubst posn-object (position)
+ "Return the object (image or string) of POSITION.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (or (posn-image position) (posn-string position)))
+
+(defsubst posn-object-x-y (position)
+ "Return the x and y coordinates relative to the object of POSITION.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 8 position))
+
+(defsubst posn-object-width-height (position)
+ "Return the pixel width and height of the object of POSITION.
+POSITION should be a list of the form returned by the `event-start'
+and `event-end' functions."
+ (nth 9 position))
+
\f
;;;; Obsolescent names for functions.
(defalias 'sref 'aref)
(make-obsolete 'sref 'aref "20.4")
-(make-obsolete 'char-bytes "Now this function always returns 1" "20.4")
+(make-obsolete 'char-bytes "now always returns 1." "20.4")
+(make-obsolete 'chars-in-region "use (abs (- BEG END))." "20.3")
+(make-obsolete 'dot 'point "before 19.15")
+(make-obsolete 'dot-max 'point-max "before 19.15")
+(make-obsolete 'dot-min 'point-min "before 19.15")
+(make-obsolete 'dot-marker 'point-marker "before 19.15")
+(make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
+(make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
+(make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
+(make-obsolete 'define-function 'defalias "20.1")
+(make-obsolete 'focus-frame "it does nothing." "19.32")
+(make-obsolete 'unfocus-frame "it does nothing." "19.32")
(defun insert-string (&rest args)
"Mocklisp-compatibility insert function.
is converted into a string by expressing it in decimal."
(dolist (el args)
(insert (if (integerp el) (number-to-string el) el))))
-
-(make-obsolete 'insert-string 'insert "21.3")
+(make-obsolete 'insert-string 'insert "21.4")
+(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
+(make-obsolete 'makehash 'make-hash-table "21.4")
;; Some programs still use this as a function.
(defun baud-rate ()
- "Obsolete function returning the value of the `baud-rate' variable.
-Please convert your programs to use the variable `baud-rate' directly."
+ "Return the value of the `baud-rate' variable."
baud-rate)
-(defalias 'focus-frame 'ignore)
-(defalias 'unfocus-frame 'ignore)
+(defalias 'focus-frame 'ignore "")
+(defalias 'unfocus-frame 'ignore "")
+
+\f
+;;;; Obsolescence declarations for variables.
+
+(make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
+(make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1")
+(make-obsolete-variable 'unread-command-char
+ "use `unread-command-events' instead. That variable is a list of events to reread, so it now uses nil to mean `no event', instead of -1."
+ "before 19.15")
+(make-obsolete-variable 'executing-macro 'executing-kbd-macro "before 19.34")
+(make-obsolete-variable 'post-command-idle-hook
+ "use timers instead, with `run-with-idle-timer'." "before 19.34")
+(make-obsolete-variable 'post-command-idle-delay
+ "use timers instead, with `run-with-idle-timer'." "before 19.34")
+
\f
;;;; Alternate names for functions - these are not being phased out.
(defalias 'search-backward-regexp (symbol-function 're-search-backward))
(defalias 'int-to-string 'number-to-string)
(defalias 'store-match-data 'set-match-data)
+(defalias 'make-variable-frame-localizable 'make-variable-frame-local)
;; These are the XEmacs names:
(defalias 'point-at-eol 'line-end-position)
(defalias 'point-at-bol 'line-beginning-position)
(make-local-variable hook)
(set hook (list t)))
hook)
-(make-obsolete 'make-local-hook "Not necessary any more." "21.1")
+(make-obsolete 'make-local-hook "not necessary any more." "21.1")
(defun add-hook (hook function &optional append local)
"Add to the value of HOOK the function FUNCTION.
list of hooks to run in HOOK, then nothing is done. See `add-hook'.
The optional third argument, LOCAL, if non-nil, says to modify
-the hook's buffer-local value rather than its default value.
-This makes the hook buffer-local if needed."
+the hook's buffer-local value rather than its default value."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
- (if local (unless (local-variable-if-set-p hook)
- (set (make-local-variable hook) (list t)))
+ ;; Do nothing if LOCAL is t but this hook has no local binding.
+ (unless (and local (not (local-variable-p 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))))
- ;; 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)))
- ;; (push (cons 'not function) hook-value))
- ;; Set the actual variable
- (if (not local)
- (set-default hook hook-value)
- (if (equal hook-value '(t))
- (kill-local-variable hook)
- (set hook hook-value)))))
+ (when (and (local-variable-p hook)
+ (not (and (consp (symbol-value hook))
+ (memq t (symbol-value hook)))))
+ (setq local t))
+ (let ((hook-value (if local (symbol-value hook) (default-value hook))))
+ ;; 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)))
+ ;; (push (cons 'not function) hook-value))
+ ;; Set the actual variable
+ (if (not local)
+ (set-default hook hook-value)
+ (if (equal hook-value '(t))
+ (kill-local-variable hook)
+ (set hook hook-value))))))
(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.
\f
;;; Load history
-(defvar symbol-file-load-history-loaded nil
- "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
-That file records the part of `load-history' for preloaded files,
-which is cleared out before dumping to make Emacs smaller.")
-
-(defun load-symbol-file-load-history ()
- "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
-That file records the part of `load-history' for preloaded files,
-which is cleared out before dumping to make Emacs smaller."
- (unless symbol-file-load-history-loaded
- (load (expand-file-name
- ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
- (if (eq system-type 'ms-dos)
- "fns.el"
- (format "fns-%s.el" emacs-version))
- exec-directory)
- ;; The file name fns-%s.el already has a .el extension.
- nil nil t)
- (setq symbol-file-load-history-loaded t)))
+;;; (defvar symbol-file-load-history-loaded nil
+;;; "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
+;;; That file records the part of `load-history' for preloaded files,
+;;; which is cleared out before dumping to make Emacs smaller.")
+
+;;; (defun load-symbol-file-load-history ()
+;;; "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
+;;; That file records the part of `load-history' for preloaded files,
+;;; which is cleared out before dumping to make Emacs smaller."
+;;; (unless symbol-file-load-history-loaded
+;;; (load (expand-file-name
+;;; ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
+;;; (if (eq system-type 'ms-dos)
+;;; "fns.el"
+;;; (format "fns-%s.el" emacs-version))
+;;; exec-directory)
+;;; ;; The file name fns-%s.el already has a .el extension.
+;;; nil nil t)
+;;; (setq symbol-file-load-history-loaded t)))
(defun symbol-file (function)
"Return the input source from which FUNCTION was loaded.
either an absolute file name, or a library name
\(with no directory name and no `.el' or `.elc' at the end).
It can also be nil, if the definition is not associated with any file."
- (load-symbol-file-load-history)
- (let ((files load-history)
- file functions)
- (while files
- (if (memq function (cdr (car files)))
- (setq file (car (car files)) files nil))
- (setq files (cdr files)))
- file))
+ (if (and (symbolp function) (fboundp function)
+ (eq 'autoload (car-safe (symbol-function function))))
+ (nth 1 (symbol-function function))
+ (let ((files load-history)
+ file)
+ (while files
+ (if (member function (cdr (car files)))
+ (setq file (car (car files)) files nil))
+ (setq files (cdr files)))
+ file)))
\f
;;;; Specifying things to do after certain files are loaded.
(featurep file)
;; Make sure `load-history' contains the files dumped with
;; Emacs for the case that FILE is one of them.
- (load-symbol-file-load-history)
+ ;; (load-symbol-file-load-history)
(assoc file load-history))
(eval form))))
form)
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)))
+\f
+;;; make-network-process wrappers
+
+(if (featurep 'make-network-process)
+ (progn
+
+(defun open-network-stream (name buffer host service)
+ "Open a TCP connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or buffer name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer.
+HOST is name of the host to connect to, or its IP address.
+SERVICE is name of the service desired, or an integer specifying
+ a port number to connect to."
+ (make-network-process :name name :buffer buffer
+ :host host :service service))
+
+(defun open-network-stream-nowait (name buffer host service &optional sentinel filter)
+ "Initiate connection to a TCP connection for a service to a host.
+It returns nil if non-blocking connects are not supported; otherwise,
+it returns a subprocess-object to represent the connection.
+
+This function is similar to `open-network-stream', except that it
+returns before the connection is established. When the connection
+is completed, the sentinel function will be called with second arg
+matching `open' (if successful) or `failed' (on error).
+
+Args are NAME BUFFER HOST SERVICE SENTINEL FILTER.
+NAME, BUFFER, HOST, and SERVICE are as for `open-network-stream'.
+Optional args SENTINEL and FILTER specify the sentinel and filter
+functions to be used for this network stream."
+ (if (featurep 'make-network-process '(:nowait t))
+ (make-network-process :name name :buffer buffer :nowait t
+ :host host :service service
+ :filter filter :sentinel sentinel)))
+
+(defun open-network-stream-server (name buffer service &optional sentinel filter)
+ "Create a network server process for a TCP service.
+It returns nil if server processes are not supported; otherwise,
+it returns a subprocess-object to represent the server.
+
+When a client connects to the specified service, a new subprocess
+is created to handle the new connection, and the sentinel function
+is called for the new process.
+
+Args are NAME BUFFER SERVICE SENTINEL FILTER.
+NAME is name for the server process. Client processes are named by
+ appending the ip-address and port number of the client to NAME.
+BUFFER is the buffer (or buffer name) to associate with the server
+ process. Client processes will not get a buffer if a process filter
+ is specified or BUFFER is nil; otherwise, a new buffer is created for
+ the client process. The name is similar to the process name.
+Third arg SERVICE is name of the service desired, or an integer
+ specifying a port number to connect to. It may also be t to select
+ an unused port number for the server.
+Optional args SENTINEL and FILTER specify the sentinel and filter
+ functions to be used for the client processes; the server process
+ does not use these function."
+ (if (featurep 'make-network-process '(:server t))
+ (make-network-process :name name :buffer buffer
+ :service service :server t :noquery t
+ :sentinel sentinel :filter filter)))
+
+)) ;; (featurep 'make-network-process)
+
+
+;; compatibility
+
+(make-obsolete 'process-kill-without-query
+ "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
+ "21.5")
+(defun process-kill-without-query (process &optional flag)
+ "Say no query needed if PROCESS is running when Emacs is exited.
+Optional second argument if non-nil says to require a query.
+Value is t if a query was formerly required."
+ (let ((old (process-query-on-exit-flag process)))
+ (set-process-query-on-exit-flag process nil)
+ old))
+
+;; process plist management
+
+(defun process-get (process propname)
+ "Return the value of PROCESS' PROPNAME property.
+This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
+ (plist-get (process-plist process) propname))
+
+(defun process-put (process propname value)
+ "Change PROCESS' PROPNAME property to VALUE.
+It can be retrieved with `(process-get PROCESS PROPNAME)'."
+ (set-process-plist process
+ (plist-put (process-plist process) propname value)))
\f
;;;; Input and display facilities.
Legitimate radix values are 8, 10 and 16.")
(custom-declare-variable-early
- 'read-quoted-char-radix 8
+ 'read-quoted-char-radix 8
"*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
Legitimate radix values are 8, 10 and 16."
:type '(choice (const 8) (const 10) (const 16))
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.
(setq char (read-event (and prompt (format "%s-" prompt)) t))
(if inhibit-quit (setq quit-flag nil)))
;; Translate TAB key into control-I ASCII character, and so on.
- (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))
+ ;; Note: `read-char' does it using the `ascii-character' property.
+ ;; 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.
+ (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 (list char)
done t))
- (t (setq code char
+ (t (setq code translated
done t)))
(setq first nil))
code))
(defun read-passwd (prompt &optional confirm default)
"Read a password, prompting with PROMPT. Echo `.' for each character typed.
End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
-Optional argument CONFIRM, if non-nil, then read it twice to make sure.
+If optional CONFIRM is non-nil, read password twice to make sure.
Optional DEFAULT is a default password to use instead of empty input."
(if confirm
(let (success)
(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 ""))))
+
+;; This should be used by `call-interactively' for `n' specs.
+(defun read-number (prompt &optional default)
+ (let ((n nil))
+ (when default
+ (setq prompt
+ (if (string-match "\\(\\):[^:]*" prompt)
+ (replace-match (format " [%s]" default) t t prompt 1)
+ (concat prompt (format " [%s] " default)))))
+ (while
+ (progn
+ (let ((str (read-from-minibuffer prompt nil nil nil nil
+ (and default
+ (number-to-string default)))))
+ (setq n (cond
+ ((zerop (length str)) default)
+ ((stringp str) (read str)))))
+ (unless (numberp n)
+ (message "Please enter a number.")
+ (sit-for 1)
+ t)))
+ n))
\f
;;; Atomic change groups.
"Perform BODY as an atomic change group.
This means that if BODY exits abnormally,
all of its changes to the current buffer are undone.
-This works regadless of whether undo is enabled in the buffer.
+This works regardless of whether undo is enabled in the buffer.
This mechanism is transparent to ordinary use of undo;
if undo is enabled in the buffer and BODY succeeds, the
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)."
(dolist (elt handle)
(with-current-buffer (car elt)
(setq elt (cdr elt))
- (let ((old-car
+ (let ((old-car
(if (consp elt) (car elt)))
(old-cdr
(if (consp elt) (cdr elt))))
(defalias 'redraw-modeline 'force-mode-line-update)
(defun force-mode-line-update (&optional all)
- "Force the mode line of the current buffer to be redisplayed.
-With optional non-nil ALL, force redisplay of all mode lines."
+ "Force redisplay of the current buffer's mode line and header line.
+With optional non-nil ALL, force redisplay of all mode lines and
+header lines. This function also forces recomputation of the
+menu bar menus and the frame title."
(if all (save-excursion (set-buffer (other-buffer))))
(set-buffer-modified-p (buffer-modified-p)))
(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
-Display remains until next character is typed.
-If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
-otherwise it is then available as input (as a command if nothing else).
+Display remains until next event is input.
+Optional third arg EXIT-CHAR can be a character, event or event
+description list. EXIT-CHAR defaults to SPC. If the input is
+EXIT-CHAR it is swallowed; otherwise it is then available as
+input (as a command if nothing else).
Display MESSAGE (optional fourth arg) in the echo area.
If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(or exit-char (setq exit-char ?\ ))
(recenter 0))))
(message (or message "Type %s to continue editing.")
(single-key-description exit-char))
- (let ((char (read-event)))
- (or (eq char exit-char)
- (setq unread-command-events (list char)))))
+ (let (char)
+ (if (integerp exit-char)
+ (condition-case nil
+ (progn
+ (setq char (read-char))
+ (or (eq char exit-char)
+ (setq unread-command-events (list char))))
+ (error
+ ;; `exit-char' is a character, hence it differs
+ ;; from char, which is an event.
+ (setq unread-command-events (list char))))
+ ;; `exit-char' can be an event, or an event description
+ ;; list.
+ (setq char (read-event))
+ (or (eq char exit-char)
+ (eq char (event-convert-list exit-char))
+ (setq unread-command-events (list char))))))
(if insert-end
(save-excursion
(delete-region pos insert-end)))
(overlay-put o1 (pop props) (pop props)))
o1))
-(defun remove-overlays (beg end name val)
+(defun remove-overlays (&optional beg end name val)
"Clear BEG and END of overlays whose property NAME has value VAL.
-Overlays might be moved and or split."
+Overlays might be moved and/or split.
+BEG and END default respectively to the beginning and end of buffer."
+ (unless beg (setq beg (point-min)))
+ (unless end (setq end (point-max)))
(if (< end beg)
(setq beg (prog1 end (setq end beg))))
(save-excursion
(while (< (point) end)
(let ((cat (get-text-property (point) 'category))
run-end)
- (when cat
- (setq run-end
- (next-single-property-change (point) 'category nil end))
- (remove-list-of-text-properties (point) run-end '(category))
- (add-text-properties (point) run-end (symbol-plist cat))
- (goto-char (or run-end end)))
(setq run-end
(next-single-property-change (point) 'category nil end))
- (goto-char (or run-end end))))))
+ (when cat
+ (let (run-end2 original)
+ (remove-list-of-text-properties (point) run-end '(category))
+ (while (< (point) run-end)
+ (setq run-end2 (next-property-change (point) nil run-end))
+ (setq original (text-properties-at (point)))
+ (set-text-properties (point) run-end2 (symbol-plist cat))
+ (add-text-properties (point) run-end2 original)
+ (goto-char run-end2))))
+ (goto-char run-end)))))
(if (eq yank-excluded-properties t)
(set-text-properties start end nil)
- (remove-list-of-text-properties start end
- yank-excluded-properties))))
-
-(defun insert-for-yank (&rest strings)
- "Insert STRINGS at point, stripping some text properties.
-Strip text properties from the inserted text
-according to `yank-excluded-properties'.
-Otherwise just like (insert STRINGS...)."
- (let ((opoint (point)))
- (apply 'insert strings)
- (remove-yank-excluded-properties opoint (point))))
-
-(defun insert-buffer-substring-no-properties (buf &optional start end)
- "Insert before point a substring of buffer BUFFER, without text properties.
+ (remove-list-of-text-properties start end yank-excluded-properties))))
+
+(defvar yank-undo-function)
+
+(defun insert-for-yank (string)
+ "Calls `insert-for-yank-1' repetitively for each `yank-handler' segment.
+
+See `insert-for-yank-1' for more details."
+ (let (to)
+ (while (setq to (next-single-property-change 0 'yank-handler string))
+ (insert-for-yank-1 (substring string 0 to))
+ (setq string (substring string to))))
+ (insert-for-yank-1 string))
+
+(defun insert-for-yank-1 (string)
+ "Insert STRING at point, stripping some text properties.
+
+Strip text properties from the inserted text according to
+`yank-excluded-properties'. Otherwise just like (insert STRING).
+
+If STRING has a non-nil `yank-handler' property on the first character,
+the normal insert behaviour is modified in various ways. The value of
+the yank-handler property must be a list with one to five elements
+with the following format: (FUNCTION PARAM NOEXCLUDE UNDO).
+When FUNCTION is present and non-nil, it is called instead of `insert'
+ to insert the string. FUNCTION takes one argument--the object to insert.
+If PARAM is present and non-nil, it replaces STRING as the object
+ passed to FUNCTION (or `insert'); for example, if FUNCTION is
+ `yank-rectangle', PARAM may be a list of strings to insert as a
+ rectangle.
+If NOEXCLUDE is present and non-nil, the normal removal of the
+ yank-excluded-properties is not performed; instead FUNCTION is
+ responsible for removing those properties. This may be necessary
+ if FUNCTION adjusts point before or after inserting the object.
+If UNDO is present and non-nil, it is a function that will be called
+ by `yank-pop' to undo the insertion of the current object. It is
+ called with two arguments, the start and end of the current region.
+ FUNCTION may set `yank-undo-function' to override the UNDO value."
+ (let* ((handler (and (stringp string)
+ (get-text-property 0 'yank-handler string)))
+ (param (or (nth 1 handler) string))
+ (opoint (point)))
+ (setq yank-undo-function t)
+ (if (nth 0 handler) ;; FUNCTION
+ (funcall (car handler) param)
+ (insert param))
+ (unless (nth 2 handler) ;; NOEXCLUDE
+ (remove-yank-excluded-properties opoint (point)))
+ (if (eq yank-undo-function t) ;; not set by FUNCTION
+ (setq yank-undo-function (nth 3 handler))) ;; UNDO
+ (if (nth 4 handler) ;; COMMAND
+ (setq this-command (nth 4 handler)))))
+
+(defun insert-buffer-substring-no-properties (buffer &optional start end)
+ "Insert before point a substring of BUFFER, without text properties.
BUFFER may be a buffer or a buffer name.
Arguments START and END are character numbers specifying the substring.
They default to the beginning and the end of BUFFER."
(let ((opoint (point)))
- (insert-buffer-substring buf start end)
+ (insert-buffer-substring buffer start end)
(let ((inhibit-read-only t))
(set-text-properties opoint (point) nil))))
-(defun insert-buffer-substring-as-yank (buf &optional start end)
- "Insert before point a part of buffer BUFFER, stripping some text properties.
-BUFFER may be a buffer or a buffer name. Arguments START and END are
-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'."
+(defun insert-buffer-substring-as-yank (buffer &optional start end)
+ "Insert before point a part of BUFFER, stripping some text properties.
+BUFFER may be a buffer or a buffer name.
+Arguments START and END are 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)
+ (insert-buffer-substring buffer start end)
(remove-yank-excluded-properties opoint (point))))
\f
(defun start-process-shell-command (name buffer &rest args)
"Start a program in a subprocess. Return the process object for it.
-Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer or (buffer-name) to associate with the process.
+BUFFER is the buffer (or buffer name) to associate with the process.
Process output goes at end of that buffer, unless you specify
an output stream or filter function to handle the output.
BUFFER may be also nil, meaning that this process is not associated
with any buffer
-Third arg is command name, the name of a shell command.
+COMMAND is the name of a shell command.
Remaining arguments are the arguments for the command.
-Wildcards and redirection are handled as usual in the shell."
+Wildcards and redirection are handled as usual in the shell.
+
+\(fn NAME BUFFER COMMAND &rest COMMAND-ARGS)"
(cond
((eq system-type 'vax-vms)
(apply 'start-process name buffer args))
"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))
+ ;; It is necessary to save all of these, because calling
+ ;; select-window changes frame-selected-window for whatever
+ ;; frame that window is in.
+ (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)
+ (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))
(defmacro with-local-quit (&rest body)
"Execute BODY with `inhibit-quit' temporarily bound to nil."
+ (declare (debug t) (indent 0))
`(condition-case nil
(let ((inhibit-quit nil))
,@body)
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)
(defvar delayed-mode-hooks nil
"List of delayed mode hooks waiting to be run.")
(make-variable-buffer-local 'delayed-mode-hooks)
+(put 'delay-mode-hooks 'permanent-local t)
(defun run-mode-hooks (&rest hooks)
"Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
(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))
parent))
(defmacro with-syntax-table (table &rest body)
- "Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
+ "Evaluate BODY with syntax table of current buffer set to TABLE.
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))
(,old-buffer (current-buffer)))
(unwind-protect
(progn
- (set-syntax-table (copy-syntax-table ,table))
+ (set-syntax-table ,table)
,@body)
(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
STRING should be given if the last search was by `string-match' on STRING."
(if (match-beginning num)
(if string
- (let ((result
- (substring string (match-beginning num) (match-end num))))
- (set-text-properties 0 (length result) nil result)
- result)
+ (substring-no-properties string (match-beginning num)
+ (match-end num))
(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.
To replace only the first match (if any), make REGEXP match up to \\'
and replace a sub-expression, e.g.
- (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1)
+ (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1)
=> \" bar foo\"
"
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.
(set-char-table-parent table (or oldtable (standard-syntax-table)))
table))
+(defun syntax-after (pos)
+ "Return the syntax of the char after POS."
+ (unless (or (< pos (point-min)) (>= pos (point-max)))
+ (let ((st (if parse-sexp-lookup-properties
+ (get-char-property pos 'syntax-table))))
+ (if (consp st) st
+ (aref (or st (syntax-table)) (char-after pos))))))
+
(defun add-to-invisibility-spec (arg)
"Add elements to `buffer-invisibility-spec'.
See documentation for `buffer-invisibility-spec' for the kind of elements
that can be added."
- (cond
- ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t))
- (setq buffer-invisibility-spec (list arg)))
- (t
- (setq buffer-invisibility-spec
- (cons arg buffer-invisibility-spec)))))
+ (if (eq buffer-invisibility-spec t)
+ (setq buffer-invisibility-spec (list t)))
+ (setq buffer-invisibility-spec
+ (cons arg buffer-invisibility-spec)))
(defun remove-from-invisibility-spec (arg)
"Remove elements from `buffer-invisibility-spec'."
(eq (car object) 'frame-configuration)))
(defun functionp (object)
- "Non-nil iff OBJECT is a type of object that can be called as a function."
+ "Non-nil if OBJECT is any kind of function or a special form.
+Also non-nil if OBJECT is a symbol and its function definition is
+\(recursively) a function or special form. This does not include
+macros."
(or (and (symbolp object) (fboundp object)
- (setq object (indirect-function object))
+ (condition-case nil
+ (setq object (indirect-function object))
+ (error nil))
(eq (car-safe object) 'autoload)
(not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
(subrp object) (byte-code-function-p object)
(eq (car-safe object) 'lambda)))
-(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.
-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))
(defun make-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file.
The returned file name (created by appending some random characters at the end
-of PREFIX, and expanding against `temporary-file-directory' if necessary,
+of PREFIX, and expanding against `temporary-file-directory' if necessary),
is guaranteed to point to a newly created empty file.
You can then use `write-region' to write new data into the file.
If DIR-FLAG is non-nil, create a new empty directory instead of a file.
If SUFFIX is non-nil, add that at the end of the file name."
- (let (file)
- (while (condition-case ()
- (progn
- (setq file
- (make-temp-name
- (expand-file-name prefix temporary-file-directory)))
- (if suffix
- (setq file (concat file suffix)))
- (if dir-flag
- (make-directory file)
- (write-region "" nil file nil 'silent nil 'excl))
- nil)
- (file-already-exists t))
- ;; the file was somehow created by someone else between
- ;; `make-temp-name' and `write-region', let's try again.
- nil)
- file))
+ (let ((umask (default-file-modes))
+ file)
+ (unwind-protect
+ (progn
+ ;; Create temp files with strict access rights. It's easy to
+ ;; loosen them later, whereas it's impossible to close the
+ ;; time-window of loose permissions otherwise.
+ (set-default-file-modes ?\700)
+ (while (condition-case ()
+ (progn
+ (setq file
+ (make-temp-name
+ (expand-file-name prefix temporary-file-directory)))
+ (if suffix
+ (setq file (concat file suffix)))
+ (if dir-flag
+ (make-directory file)
+ (write-region "" nil file nil 'silent nil 'excl))
+ nil)
+ (file-already-exists t))
+ ;; the file was somehow created by someone else between
+ ;; `make-temp-name' and `write-region', let's try again.
+ nil)
+ file)
+ ;; Reset the umask.
+ (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
+ hs-minor-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
(let ((existing (assq toggle minor-mode-alist)))
- (when (and (stringp name) (not (get-text-property 0 'local-map name)))
- (setq name
- (propertize name
- 'local-map mode-line-minor-mode-keymap
- 'help-echo "mouse-3: minor mode menu")))
(if existing
(setcdr existing (list name))
(let ((tail minor-mode-alist) found)
(concat
(or (get toggle :menu-tag)
(if (stringp name) name (symbol-name toggle)))
- (let ((mode-name (if (stringp name) name
- (if (symbolp name) (symbol-value name)))))
- (if mode-name
- (concat " (" mode-name ")"))))
+ (let ((mode-name (if (symbolp name) (symbol-value name))))
+ (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
+ (concat " (" (match-string 0 mode-name) ")"))))
toggle-fun
:button (cons :toggle toggle))))
- ;; Add the map to the minor-mode-map-alist.
+ ;; Add the map to the minor-mode-map-alist.
(when keymap
(let ((existing (assq toggle minor-mode-map-alist)))
(if existing
;; where the clone is reduced to the empty string (we want the overlay to
;; stay when the clone's content is the empty string and we want to use
;; `evaporate' to make sure those overlays get deleted when needed).
- ;;
+ ;;
(let* ((pt-end (+ (point) (- end start)))
(start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))
0 1))
;;(overlay-put ol1 'face 'underline)
(overlay-put ol1 'evaporate t)
(overlay-put ol1 'text-clones dups)
- ;;
+ ;;
(overlay-put ol2 'modification-hooks '(text-clone-maintain))
(when spreadp (overlay-put ol2 'text-clone-spreadp t))
(when syntax (overlay-put ol2 'text-clone-syntax syntax))
;;(overlay-put ol2 'face 'underline)
(overlay-put ol2 'evaporate t)
(overlay-put ol2 'text-clones dups)))
-\f
+
(defun play-sound (sound)
"SOUND is a list of the form `(sound KEYWORD VALUE...)'.
The following keywords are recognized:
(error "This Emacs binary lacks sound support"))
(play-sound-internal sound))
+(defun define-mail-user-agent (symbol composefunc sendfunc
+ &optional abortfunc hookvar)
+ "Define a symbol to identify a mail-sending package for `mail-user-agent'.
+
+SYMBOL can be any Lisp symbol. Its function definition and/or
+value as a variable do not matter for this usage; we use only certain
+properties on its property list, to encode the rest of the arguments.
+
+COMPOSEFUNC is program callable function that composes an outgoing
+mail message buffer. This function should set up the basics of the
+buffer without requiring user interaction. It should populate the
+standard mail headers, leaving the `to:' and `subject:' headers blank
+by default.
+
+COMPOSEFUNC should accept several optional arguments--the same
+arguments that `compose-mail' takes. See that function's documentation.
+
+SENDFUNC is the command a user would run to send the message.
+
+Optional ABORTFUNC is the command a user would run to abort the
+message. For mail packages that don't have a separate abort function,
+this can be `kill-buffer' (the equivalent of omitting this argument).
+
+Optional HOOKVAR is a hook variable that gets run before the message
+is actually sent. Callers that use the `mail-user-agent' may
+install a hook function temporarily on this hook variable.
+If HOOKVAR is nil, `mail-send-hook' is used.
+
+The properties used on SYMBOL are `composefunc', `sendfunc',
+`abortfunc', and `hookvar'."
+ (put symbol 'composefunc composefunc)
+ (put symbol 'sendfunc sendfunc)
+ (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