/[emacs]/emacs/lisp/subr.el
ViewVC logotype

Diff of /emacs/lisp/subr.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.307.2.1 by miles, Wed Jun 12 01:53:21 2002 UTC revision 1.307.2.2 by miles, Fri Apr 4 06:20:11 2003 UTC
# Line 1  Line 1 
1  ;;; subr.el --- basic lisp subroutines for Emacs  ;;; subr.el --- basic lisp subroutines for Emacs
2    
3  ;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002  ;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002, 2003
4  ;;   Free Software Foundation, Inc.  ;;   Free Software Foundation, Inc.
5    
6  ;; Maintainer: FSF  ;; Maintainer: FSF
# Line 72  DOCSTRING is an optional documentation s Line 72  DOCSTRING is an optional documentation s
72   But documentation strings are usually not useful in nameless functions.   But documentation strings are usually not useful in nameless functions.
73  INTERACTIVE should be a call to the function `interactive', which see.  INTERACTIVE should be a call to the function `interactive', which see.
74  It may also be omitted.  It may also be omitted.
75  BODY should be a list of lisp expressions."  BODY should be a list of Lisp expressions."
76    ;; Note that this definition should not use backquotes; subr.el should not    ;; Note that this definition should not use backquotes; subr.el should not
77    ;; depend on backquote.el.    ;; depend on backquote.el.
78    (list 'function (cons 'lambda cdr)))    (list 'function (cons 'lambda cdr)))
# Line 89  LISTNAME must be a symbol." Line 89  LISTNAME must be a symbol."
89  LISTNAME must be a symbol whose value is a list.  LISTNAME must be a symbol whose value is a list.
90  If the value is nil, `pop' returns nil but does not actually  If the value is nil, `pop' returns nil but does not actually
91  change the list."  change the list."
92    (list 'prog1 (list 'car listname)    (list 'car
93          (list 'setq listname (list 'cdr listname))))          (list 'prog1 listname
94                  (list 'setq listname (list 'cdr listname)))))
95    
96  (defmacro when (cond &rest body)  (defmacro when (cond &rest body)
97    "If COND yields non-nil, do BODY, else return nil."    "If COND yields non-nil, do BODY, else return nil."
# Line 175  If N is bigger than the length of X, ret Line 176  If N is bigger than the length of X, ret
176             (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))             (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
177             x))))             x))))
178    
179    (defun number-sequence (from &optional to)
180      "Return a sequence of numbers from FROM to TO (both inclusive) as a list.
181    The Nth element of the list is (+ FROM N) where N counts from zero.
182    If TO is nil, it defaults to FROM.
183    If TO is less than FROM, the value is nil."
184      (if to
185          (if (< to from)
186              (setq to (1- from)))
187        (setq to from))
188      (let* ((list (make-list (- (1+ to) from) from))
189             (tail list))
190        (while (setq tail (cdr tail))
191          (setcar tail (setq from (1+ from))))
192        list))
193    
194  (defun remove (elt seq)  (defun remove (elt seq)
195    "Return a copy of SEQ with all occurrences of ELT removed.    "Return a copy of SEQ with all occurrences of ELT removed.
196  SEQ must be a list, vector, or string.  The comparison is done with `equal'."  SEQ must be a list, vector, or string.  The comparison is done with `equal'."
# Line 185  SEQ must be a list, vector, or string. Line 201  SEQ must be a list, vector, or string.
201      (delete elt (copy-sequence seq))))      (delete elt (copy-sequence seq))))
202    
203  (defun remq (elt list)  (defun remq (elt list)
204    "Return a copy of LIST with all occurences of ELT removed.    "Return a copy of LIST with all occurrences of ELT removed.
205  The comparison is done with `eq'."  The comparison is done with `eq'."
206    (if (memq elt list)    (if (memq elt list)
207        (delq elt (copy-sequence list))        (delq elt (copy-sequence list))
# Line 204  argument VECP, this copies vectors as we Line 220  argument VECP, this copies vectors as we
220                  (setq newcar (copy-tree (car tree) vecp)))                  (setq newcar (copy-tree (car tree) vecp)))
221              (push newcar result))              (push newcar result))
222            (setq tree (cdr tree)))            (setq tree (cdr tree)))
223          (nreconc result tree))          (nconc (nreverse result) tree))
224      (if (and vecp (vectorp tree))      (if (and vecp (vectorp tree))
225          (let ((i (length (setq tree (copy-sequence tree)))))          (let ((i (length (setq tree (copy-sequence tree)))))
226            (while (>= (setq i (1- i)) 0)            (while (>= (setq i (1- i)) 0)
# Line 243  Unibyte strings are converted to multiby Line 259  Unibyte strings are converted to multiby
259    
260  (defun assoc-ignore-representation (key alist)  (defun assoc-ignore-representation (key alist)
261    "Like `assoc', but ignores differences in text representation.    "Like `assoc', but ignores differences in text representation.
262  KEY must be a string.    KEY must be a string.
263  Unibyte strings are converted to multibyte for comparison."  Unibyte strings are converted to multibyte for comparison."
264    (let (element)    (let (element)
265      (while (and alist (not element))      (while (and alist (not element))
# Line 284  Non-strings in LIST are ignored." Line 300  Non-strings in LIST are ignored."
300    "Make MAP override all normally self-inserting keys to be undefined.    "Make MAP override all normally self-inserting keys to be undefined.
301  Normally, as an exception, digits and minus-sign are set to make prefix args,  Normally, as an exception, digits and minus-sign are set to make prefix args,
302  but optional second arg NODIGITS non-nil treats them like other chars."  but optional second arg NODIGITS non-nil treats them like other chars."
303    (substitute-key-definition 'self-insert-command 'undefined map global-map)    (define-key map [remap self-insert-command] 'undefined)
304    (or nodigits    (or nodigits
305        (let (loop)        (let (loop)
306          (define-key map "-" 'negative-argument)          (define-key map "-" 'negative-argument)
# Line 296  but optional second arg NODIGITS non-nil Line 312  but optional second arg NODIGITS non-nil
312    
313  ;Moved to keymap.c  ;Moved to keymap.c
314  ;(defun copy-keymap (keymap)  ;(defun copy-keymap (keymap)
315  ;  "Return a copy of KEYMAP"    ;  "Return a copy of KEYMAP"
316  ;  (while (not (keymapp keymap))  ;  (while (not (keymapp keymap))
317  ;    (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))  ;    (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
318  ;  (if (vectorp keymap)  ;  (if (vectorp keymap)
# Line 314  in KEYMAP as NEWDEF those keys which are Line 330  in KEYMAP as NEWDEF those keys which are
330    ;; Don't document PREFIX in the doc string because we don't want to    ;; Don't document PREFIX in the doc string because we don't want to
331    ;; advertise it.  It's meant for recursive calls only.  Here's its    ;; advertise it.  It's meant for recursive calls only.  Here's its
332    ;; meaning    ;; meaning
333      
334    ;; If optional argument PREFIX is specified, it should be a key    ;; If optional argument PREFIX is specified, it should be a key
335    ;; prefix, a string.  Redefined bindings will then be bound to the    ;; prefix, a string.  Redefined bindings will then be bound to the
336    ;; original key, with PREFIX added at the front.    ;; original key, with PREFIX added at the front.
# Line 508  and then modifies one entry in it." Line 524  and then modifies one entry in it."
524    (aset keyboard-translate-table from to))    (aset keyboard-translate-table from to))
525    
526    
527  ;;;; The global keymap tree.    ;;;; The global keymap tree.
528    
529  ;;; global-map, esc-map, and ctl-x-map have their values set up in  ;;; global-map, esc-map, and ctl-x-map have their values set up in
530  ;;; keymap.c; we just give them docstrings here.  ;;; keymap.c; we just give them docstrings here.
# Line 613  If EVENT is a drag, this returns the dra Line 629  If EVENT is a drag, this returns the dra
629  The return value is of the form  The return value is of the form
630     (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)     (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
631  The `posn-' functions access elements of such lists."  The `posn-' functions access elements of such lists."
632    (nth 1 event))    (if (consp event) (nth 1 event)
633        (list (selected-window) (point) '(0 . 0) 0)))
634    
635  (defsubst event-end (event)  (defsubst event-end (event)
636    "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 or drag event.
# Line 621  If EVENT is a click event, this function Line 638  If EVENT is a click event, this function
638  The return value is of the form  The return value is of the form
639     (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)     (WINDOW BUFFER-POSITION (X . Y) TIMESTAMP)
640  The `posn-' functions access elements of such lists."  The `posn-' functions access elements of such lists."
641    (nth (if (consp (nth 2 event)) 2 1) event))    (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event)
642        (list (selected-window) (point) '(0 . 0) 0)))
643    
644  (defsubst event-click-count (event)  (defsubst event-click-count (event)
645    "Return the multi-click count of EVENT, a click or drag event.    "Return the multi-click count of EVENT, a click or drag event.
646  The return value is a positive integer."  The return value is a positive integer."
647    (if (integerp (nth 2 event)) (nth 2 event) 1))    (if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
648    
649  (defsubst posn-window (position)  (defsubst posn-window (position)
650    "Return the window in POSITION.    "Return the window in POSITION.
# Line 658  POSITION should be a list of the form Line 676  POSITION should be a list of the form
676  as returned by the `event-start' and `event-end' functions.  as returned by the `event-start' and `event-end' functions.
677  For a scroll-bar event, the result column is 0, and the row  For a scroll-bar event, the result column is 0, and the row
678  corresponds to the vertical position of the click in the scroll bar."  corresponds to the vertical position of the click in the scroll bar."
679    (let ((pair   (nth 2 position))    (let* ((pair   (nth 2 position))
680          (window (posn-window position)))           (window (posn-window position)))
681      (if (eq (if (consp (nth 1 position))      (if (eq (if (consp (nth 1 position))
682                  (car (nth 1 position))                  (car (nth 1 position))
683                (nth 1 position))                (nth 1 position))
# Line 672  corresponds to the vertical position of Line 690  corresponds to the vertical position of
690            (cons (scroll-bar-scale pair (window-width window)) 0)            (cons (scroll-bar-scale pair (window-width window)) 0)
691          (let* ((frame (if (framep window) window (window-frame window)))          (let* ((frame (if (framep window) window (window-frame window)))
692                 (x (/ (car pair) (frame-char-width frame)))                 (x (/ (car pair) (frame-char-width frame)))
693                 (y (/ (cdr pair) (frame-char-height frame))))                 (y (/ (cdr pair) (+ (frame-char-height frame)
694                                       (or (frame-parameter frame 'line-spacing)
695                                           default-line-spacing
696                                           0)))))
697            (cons x y))))))            (cons x y))))))
698    
699  (defsubst posn-timestamp (position)  (defsubst posn-timestamp (position)
# Line 872  This function is appropiate for `key-men Line 893  This function is appropiate for `key-men
893    
894  (defalias 'sref 'aref)  (defalias 'sref 'aref)
895  (make-obsolete 'sref 'aref "20.4")  (make-obsolete 'sref 'aref "20.4")
896  (make-obsolete 'char-bytes "Now this function always returns 1" "20.4")  (make-obsolete 'char-bytes "now always returns 1." "20.4")
897    (make-obsolete 'chars-in-region "use (abs (- BEG END))." "20.3")
898    (make-obsolete 'dot 'point              "before 19.15")
899    (make-obsolete 'dot-max 'point-max      "before 19.15")
900    (make-obsolete 'dot-min 'point-min      "before 19.15")
901    (make-obsolete 'dot-marker 'point-marker "before 19.15")
902    (make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
903    (make-obsolete 'baud-rate "use the baud-rate variable instead." "before 19.15")
904    (make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
905    (make-obsolete 'define-function 'defalias "20.1")
906    
907  (defun insert-string (&rest args)  (defun insert-string (&rest args)
908    "Mocklisp-compatibility insert function.    "Mocklisp-compatibility insert function.
# Line 880  Like the function `insert' except that a Line 910  Like the function `insert' except that a
910  is converted into a string by expressing it in decimal."  is converted into a string by expressing it in decimal."
911    (dolist (el args)    (dolist (el args)
912      (insert (if (integerp el) (number-to-string el) el))))      (insert (if (integerp el) (number-to-string el) el))))
913    (make-obsolete 'insert-string 'insert "21.4")
914  (make-obsolete 'insert-string 'insert "21.3")  (defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
915    (make-obsolete 'makehash 'make-hash-table "21.4")
916    
917  ;; Some programs still use this as a function.  ;; Some programs still use this as a function.
918  (defun baud-rate ()  (defun baud-rate ()
919    "Obsolete function returning the value of the `baud-rate' variable.    "Return the value of the `baud-rate' variable."
 Please convert your programs to use the variable `baud-rate' directly."  
920    baud-rate)    baud-rate)
921    
922  (defalias 'focus-frame 'ignore)  (defalias 'focus-frame 'ignore)
923  (defalias 'unfocus-frame 'ignore)  (defalias 'unfocus-frame 'ignore)
924    
925    
926    ;;;; Obsolescence declarations for variables.
927    
928    (make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
929    (make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1")
930    (make-obsolete-variable 'unread-command-char
931      "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."
932      "before 19.15")
933    (make-obsolete-variable 'executing-macro 'executing-kbd-macro "before 19.34")
934    (make-obsolete-variable 'post-command-idle-hook
935      "use timers instead, with `run-with-idle-timer'." "before 19.34")
936    (make-obsolete-variable 'post-command-idle-delay
937      "use timers instead, with `run-with-idle-timer'." "before 19.34")
938    
939    
940  ;;;; Alternate names for functions - these are not being phased out.  ;;;; Alternate names for functions - these are not being phased out.
941    
# Line 906  Please convert your programs to use the Line 951  Please convert your programs to use the
951  (defalias 'search-backward-regexp (symbol-function 're-search-backward))  (defalias 'search-backward-regexp (symbol-function 're-search-backward))
952  (defalias 'int-to-string 'number-to-string)  (defalias 'int-to-string 'number-to-string)
953  (defalias 'store-match-data 'set-match-data)  (defalias 'store-match-data 'set-match-data)
954    (defalias 'make-variable-frame-localizable 'make-variable-frame-local)
955  ;; These are the XEmacs names:  ;; These are the XEmacs names:
956  (defalias 'point-at-eol 'line-end-position)  (defalias 'point-at-eol 'line-end-position)
957  (defalias 'point-at-bol 'line-beginning-position)  (defalias 'point-at-bol 'line-beginning-position)
# Line 945  Do not use `make-local-variable' to make Line 991  Do not use `make-local-variable' to make
991      (make-local-variable hook)      (make-local-variable hook)
992      (set hook (list t)))      (set hook (list t)))
993    hook)    hook)
994  (make-obsolete 'make-local-hook "Not necessary any more." "21.1")  (make-obsolete 'make-local-hook "not necessary any more." "21.1")
995    
996  (defun add-hook (hook function &optional append local)  (defun add-hook (hook function &optional append local)
997    "Add to the value of HOOK the function FUNCTION.    "Add to the value of HOOK the function FUNCTION.
# Line 1041  other hooks, such as major mode hooks, c Line 1087  other hooks, such as major mode hooks, c
1087    
1088  ;;; Load history  ;;; Load history
1089    
1090  (defvar symbol-file-load-history-loaded nil  ;;; (defvar symbol-file-load-history-loaded nil
1091    "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.  ;;;   "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
1092  That file records the part of `load-history' for preloaded files,  ;;; That file records the part of `load-history' for preloaded files,
1093  which is cleared out before dumping to make Emacs smaller.")  ;;; which is cleared out before dumping to make Emacs smaller.")
1094    
1095  (defun load-symbol-file-load-history ()  ;;; (defun load-symbol-file-load-history ()
1096    "Load the file `fns-VERSION.el' in `exec-directory' if not already done.  ;;;   "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
1097  That file records the part of `load-history' for preloaded files,  ;;; That file records the part of `load-history' for preloaded files,
1098  which is cleared out before dumping to make Emacs smaller."  ;;; which is cleared out before dumping to make Emacs smaller."
1099    (unless symbol-file-load-history-loaded  ;;;   (unless symbol-file-load-history-loaded
1100      (load (expand-file-name  ;;;     (load (expand-file-name
1101             ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.  ;;;        ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
1102             (if (eq system-type 'ms-dos)  ;;;        (if (eq system-type 'ms-dos)
1103                 "fns.el"  ;;;            "fns.el"
1104               (format "fns-%s.el" emacs-version))  ;;;          (format "fns-%s.el" emacs-version))
1105             exec-directory)  ;;;        exec-directory)
1106            ;; The file name fns-%s.el already has a .el extension.  ;;;       ;; The file name fns-%s.el already has a .el extension.
1107            nil nil t)  ;;;       nil nil t)
1108      (setq symbol-file-load-history-loaded t)))  ;;;     (setq symbol-file-load-history-loaded t)))
1109    
1110  (defun symbol-file (function)  (defun symbol-file (function)
1111    "Return the input source from which FUNCTION was loaded.    "Return the input source from which FUNCTION was loaded.
# Line 1067  The value is normally a string that was Line 1113  The value is normally a string that was
1113  either an absolute file name, or a library name  either an absolute file name, or a library name
1114  \(with no directory name and no `.el' or `.elc' at the end).  \(with no directory name and no `.el' or `.elc' at the end).
1115  It can also be nil, if the definition is not associated with any file."  It can also be nil, if the definition is not associated with any file."
1116    (load-symbol-file-load-history)    (if (and (symbolp function) (fboundp function)
1117    (let ((files load-history)             (eq 'autoload (car-safe (symbol-function function))))
1118          file functions)        (nth 1 (symbol-function function))
1119      (while files      (let ((files load-history)
1120        (if (memq function (cdr (car files)))            file)
1121            (setq file (car (car files)) files nil))        (while files
1122        (setq files (cdr files)))          (if (member function (cdr (car files)))
1123      file))              (setq file (car (car files)) files nil))
1124            (setq files (cdr files)))
1125          file)))
1126    
1127    
1128  ;;;; Specifying things to do after certain files are loaded.  ;;;; Specifying things to do after certain files are loaded.
# Line 1100  evaluated whenever that feature is `prov Line 1148  evaluated whenever that feature is `prov
1148                (featurep file)                (featurep file)
1149              ;; Make sure `load-history' contains the files dumped with              ;; Make sure `load-history' contains the files dumped with
1150              ;; Emacs for the case that FILE is one of them.              ;; Emacs for the case that FILE is one of them.
1151              (load-symbol-file-load-history)              ;; (load-symbol-file-load-history)
1152              (assoc file load-history))              (assoc file load-history))
1153            (eval form))))            (eval form))))
1154    form)    form)
# Line 1187  does not use these function." Line 1235  does not use these function."
1235  (defun process-kill-without-query (process &optional flag)  (defun process-kill-without-query (process &optional flag)
1236    "Say no query needed if PROCESS is running when Emacs is exited.    "Say no query needed if PROCESS is running when Emacs is exited.
1237  Optional second argument if non-nil says to require a query.  Optional second argument if non-nil says to require a query.
1238  Value is t if a query was formerly required.    Value is t if a query was formerly required.
1239  New code should not use this function; use `process-query-on-exit-flag'  New code should not use this function; use `process-query-on-exit-flag'
1240  or `set-process-query-on-exit-flag' instead."  or `set-process-query-on-exit-flag' instead."
1241    (let ((old (process-query-on-exit-flag process)))    (let ((old (process-query-on-exit-flag process)))
1242      (set-process-query-on-exit-flag process nil)      (set-process-query-on-exit-flag process nil)
1243      old))      old))
1244    
1245    ;; process plist management
1246    
1247    (defun process-get (process propname)
1248      "Return the value of PROCESS' PROPNAME property.
1249    This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
1250      (plist-get (process-plist process) propname))
1251    
1252    (defun process-put (process propname value)
1253      "Change PROCESS' PROPNAME property to VALUE.
1254    It can be retrieved with `(process-get PROCESS PROPNAME)'."
1255      (set-process-plist process
1256                         (plist-put (process-plist process) propname value)))
1257    
1258    
1259  ;;;; Input and display facilities.  ;;;; Input and display facilities.
1260    
# Line 1202  or `set-process-query-on-exit-flag' inst Line 1263  or `set-process-query-on-exit-flag' inst
1263  Legitimate radix values are 8, 10 and 16.")  Legitimate radix values are 8, 10 and 16.")
1264    
1265  (custom-declare-variable-early  (custom-declare-variable-early
1266   'read-quoted-char-radix 8   'read-quoted-char-radix 8
1267   "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.   "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
1268  Legitimate radix values are 8, 10 and 16."  Legitimate radix values are 8, 10 and 16."
1269    :type '(choice (const 8) (const 10) (const 16))    :type '(choice (const 8) (const 10) (const 16))
# Line 1219  any other terminator is used itself as i Line 1280  any other terminator is used itself as i
1280  The optional argument PROMPT specifies a string to use to prompt the user.  The optional argument PROMPT specifies a string to use to prompt the user.
1281  The variable `read-quoted-char-radix' controls which radix to use  The variable `read-quoted-char-radix' controls which radix to use
1282  for numeric input."  for numeric input."
1283    (let ((message-log-max nil) done (first t) (code 0) char)    (let ((message-log-max nil) done (first t) (code 0) char translated)
1284      (while (not done)      (while (not done)
1285        (let ((inhibit-quit first)        (let ((inhibit-quit first)
1286              ;; Don't let C-h get the help message--only help function keys.              ;; Don't let C-h get the help message--only help function keys.
# Line 1232  any other non-digit terminates the chara Line 1293  any other non-digit terminates the chara
1293          (setq char (read-event (and prompt (format "%s-" prompt)) t))          (setq char (read-event (and prompt (format "%s-" prompt)) t))
1294          (if inhibit-quit (setq quit-flag nil)))          (if inhibit-quit (setq quit-flag nil)))
1295        ;; Translate TAB key into control-I ASCII character, and so on.        ;; Translate TAB key into control-I ASCII character, and so on.
1296        (and char        ;; Note: `read-char' does it using the `ascii-character' property.
1297             (let ((translated (lookup-key function-key-map (vector char))))        ;; We could try and use read-key-sequence instead, but then C-q ESC
1298               (if (arrayp translated)        ;; or C-q C-x might not return immediately since ESC or C-x might be
1299                   (setq char (aref translated 0)))))        ;; bound to some prefix in function-key-map or key-translation-map.
1300        (cond ((null char))        (setq translated char)
1301              ((not (integerp char))        (let ((translation (lookup-key function-key-map (vector char))))
1302            (if (arrayp translation)
1303                (setq translated (aref translation 0))))
1304          (cond ((null translated))
1305                ((not (integerp translated))
1306               (setq unread-command-events (list char)               (setq unread-command-events (list char)
1307                     done t))                     done t))
1308              ((/= (logand char ?\M-\^@) 0)              ((/= (logand translated ?\M-\^@) 0)
1309               ;; Turn a meta-character into a character with the 0200 bit set.               ;; Turn a meta-character into a character with the 0200 bit set.
1310               (setq code (logior (logand char (lognot ?\M-\^@)) 128)               (setq code (logior (logand translated (lognot ?\M-\^@)) 128)
1311                     done t))                     done t))
1312              ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix))))              ((and (<= ?0 translated) (< translated (+ ?0 (min 10 read-quoted-char-radix))))
1313               (setq code (+ (* code read-quoted-char-radix) (- char ?0)))               (setq code (+ (* code read-quoted-char-radix) (- translated ?0)))
1314               (and prompt (setq prompt (message "%s %c" prompt char))))               (and prompt (setq prompt (message "%s %c" prompt translated))))
1315              ((and (<= ?a (downcase char))              ((and (<= ?a (downcase translated))
1316                    (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix))))                    (< (downcase translated) (+ ?a -10 (min 26 read-quoted-char-radix))))
1317               (setq code (+ (* code read-quoted-char-radix)               (setq code (+ (* code read-quoted-char-radix)
1318                             (+ 10 (- (downcase char) ?a))))                             (+ 10 (- (downcase translated) ?a))))
1319               (and prompt (setq prompt (message "%s %c" prompt char))))               (and prompt (setq prompt (message "%s %c" prompt translated))))
1320              ((and (not first) (eq char ?\C-m))              ((and (not first) (eq translated ?\C-m))
1321               (setq done t))               (setq done t))
1322              ((not first)              ((not first)
1323               (setq unread-command-events (list char)               (setq unread-command-events (list char)
1324                     done t))                     done t))
1325              (t (setq code char              (t (setq code translated
1326                       done t)))                       done t)))
1327        (setq first nil))        (setq first nil))
1328      code))      code))
# Line 1315  Optional DEFAULT is a default password t Line 1380  Optional DEFAULT is a default password t
1380    "Perform BODY as an atomic change group.    "Perform BODY as an atomic change group.
1381  This means that if BODY exits abnormally,  This means that if BODY exits abnormally,
1382  all of its changes to the current buffer are undone.  all of its changes to the current buffer are undone.
1383  This works regadless of whether undo is enabled in the buffer.  This works regardless of whether undo is enabled in the buffer.
1384    
1385  This mechanism is transparent to ordinary use of undo;  This mechanism is transparent to ordinary use of undo;
1386  if undo is enabled in the buffer and BODY succeeds, the  if undo is enabled in the buffer and BODY succeeds, the
# Line 1389  This finishes the change group by revert Line 1454  This finishes the change group by revert
1454    (dolist (elt handle)    (dolist (elt handle)
1455      (with-current-buffer (car elt)      (with-current-buffer (car elt)
1456        (setq elt (cdr elt))        (setq elt (cdr elt))
1457        (let ((old-car        (let ((old-car
1458               (if (consp elt) (car elt)))               (if (consp elt) (car elt)))
1459              (old-cdr              (old-cdr
1460               (if (consp elt) (cdr elt))))               (if (consp elt) (cdr elt))))
# Line 1570  Replaces `category' properties with thei Line 1635  Replaces `category' properties with thei
1635          (while (< (point) end)          (while (< (point) end)
1636            (let ((cat (get-text-property (point) 'category))            (let ((cat (get-text-property (point) 'category))
1637                  run-end)                  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)))  
1638              (setq run-end              (setq run-end
1639                    (next-single-property-change (point) 'category nil end))                    (next-single-property-change (point) 'category nil end))
1640              (goto-char (or run-end end))))))              (when cat
1641                  (let (run-end2 original)
1642                    (remove-list-of-text-properties (point) run-end '(category))
1643                    (while (< (point) run-end)
1644                      (setq run-end2 (next-property-change (point) nil run-end))
1645                      (setq original (text-properties-at (point)))
1646                      (set-text-properties (point) run-end2 (symbol-plist cat))
1647                      (add-text-properties (point) run-end2 original)
1648                      (goto-char run-end2))))
1649                (goto-char run-end)))))
1650      (if (eq yank-excluded-properties t)      (if (eq yank-excluded-properties t)
1651          (set-text-properties start end nil)          (set-text-properties start end nil)
1652        (remove-list-of-text-properties start end        (remove-list-of-text-properties start end yank-excluded-properties))))
                                       yank-excluded-properties))))  
1653    
1654  (defun insert-for-yank (&rest strings)  (defvar yank-undo-function)
1655    "Insert STRINGS at point, stripping some text properties.  
1656  Strip text properties from the inserted text  (defun insert-for-yank (string)
1657  according to `yank-excluded-properties'.    "Insert STRING at point, stripping some text properties.
1658  Otherwise just like (insert STRINGS...)."  Strip text properties from the inserted text according to
1659    (let ((opoint (point)))  `yank-excluded-properties'.  Otherwise just like (insert STRING).
1660      (apply 'insert strings)  
1661      (remove-yank-excluded-properties opoint (point))))  If STRING has a non-nil `yank-handler' property on the first character,
1662    the normal insert behaviour is modified in various ways.  The value of
1663    the yank-handler property must be a list with one to five elements
1664    with the following format:  (FUNCTION PARAM NOEXCLUDE UNDO).
1665    When FUNCTION is present and non-nil, it is called instead of `insert'
1666     to insert the string.  FUNCTION takes one argument--the object to insert.
1667    If PARAM is present and non-nil, it replaces STRING as the object
1668     passed to FUNCTION (or `insert'); for example, if FUNCTION is
1669     `yank-rectangle', PARAM may be a list of strings to insert as a
1670     rectangle.
1671    If NOEXCLUDE is present and non-nil, the normal removal of the
1672     yank-excluded-properties is not performed; instead FUNCTION is
1673     responsible for removing those properties.  This may be necessary
1674     if FUNCTION adjusts point before or after inserting the object.
1675    If UNDO is present and non-nil, it is a function that will be called
1676     by `yank-pop' to undo the insertion of the current object.  It is
1677     called with two arguments, the start and end of the current region.
1678     FUNCTION may set `yank-undo-function' to override the UNDO value."
1679      (let* ((handler (and (stringp string)
1680                           (get-text-property 0 'yank-handler string)))
1681             (param (or (nth 1 handler) string))
1682             (opoint (point)))
1683        (setq yank-undo-function t)
1684        (if (nth 0 handler) ;; FUNCTION
1685            (funcall (car handler) param)
1686          (insert param))
1687        (unless (nth 2 handler) ;; NOEXCLUDE
1688          (remove-yank-excluded-properties opoint (point)))
1689        (if (eq yank-undo-function t)  ;; not set by FUNCTION
1690            (setq yank-undo-function (nth 3 handler))) ;; UNDO
1691        (if (nth 4 handler) ;; COMMAND
1692            (setq this-command (nth 4 handler)))))
1693    
1694  (defun insert-buffer-substring-no-properties (buf &optional start end)  (defun insert-buffer-substring-no-properties (buf &optional start end)
1695    "Insert before point a substring of buffer BUFFER, without text properties.    "Insert before point a substring of buffer BUFFER, without text properties.
# Line 1743  See also `with-temp-file' and `with-outp Line 1841  See also `with-temp-file' and `with-outp
1841    
1842  (defmacro with-local-quit (&rest body)  (defmacro with-local-quit (&rest body)
1843    "Execute BODY with `inhibit-quit' temporarily bound to nil."    "Execute BODY with `inhibit-quit' temporarily bound to nil."
1844      (declare (debug t) (indent 0))
1845    `(condition-case nil    `(condition-case nil
1846         (let ((inhibit-quit nil))         (let ((inhibit-quit nil))
1847           ,@body)           ,@body)
# Line 1804  Uses the `derived-mode-parent' property Line 1903  Uses the `derived-mode-parent' property
1903      parent))      parent))
1904    
1905  (defmacro with-syntax-table (table &rest body)  (defmacro with-syntax-table (table &rest body)
1906    "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.
1907  The syntax table of the current buffer is saved, BODY is evaluated, and the  The syntax table of the current buffer is saved, BODY is evaluated, and the
1908  saved table is restored, even in case of an abnormal exit.  saved table is restored, even in case of an abnormal exit.
1909  Value is what BODY returns."  Value is what BODY returns."
# Line 1814  Value is what BODY returns." Line 1913  Value is what BODY returns."
1913             (,old-buffer (current-buffer)))             (,old-buffer (current-buffer)))
1914         (unwind-protect         (unwind-protect
1915             (progn             (progn
1916               (set-syntax-table (copy-syntax-table ,table))               (set-syntax-table ,table)
1917               ,@body)               ,@body)
1918           (save-current-buffer           (save-current-buffer
1919             (set-buffer ,old-buffer)             (set-buffer ,old-buffer)
# Line 1930  point are such that match 0 is the funct Line 2029  point are such that match 0 is the funct
2029    
2030  To replace only the first match (if any), make REGEXP match up to \\'  To replace only the first match (if any), make REGEXP match up to \\'
2031  and replace a sub-expression, e.g.  and replace a sub-expression, e.g.
2032    (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1)    (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1)
2033      => \" bar foo\"      => \" bar foo\"
2034  "  "
2035    
# Line 2008  from `standard-syntax-table' otherwise." Line 2107  from `standard-syntax-table' otherwise."
2107      (set-char-table-parent table (or oldtable (standard-syntax-table)))      (set-char-table-parent table (or oldtable (standard-syntax-table)))
2108      table))      table))
2109    
2110    (defun syntax-after (pos)
2111      "Return the syntax of the char after POS."
2112      (unless (or (< pos (point-min)) (>= pos (point-max)))
2113        (let ((st (if parse-sexp-lookup-properties
2114                      (get-char-property pos 'syntax-table))))
2115          (if (consp st) st
2116            (aref (or st (syntax-table)) (char-after pos))))))
2117    
2118  (defun add-to-invisibility-spec (arg)  (defun add-to-invisibility-spec (arg)
2119    "Add elements to `buffer-invisibility-spec'.    "Add elements to `buffer-invisibility-spec'.
2120  See documentation for `buffer-invisibility-spec' for the kind of elements  See documentation for `buffer-invisibility-spec' for the kind of elements
2121  that can be added."  that can be added."
2122    (cond    (if (eq buffer-invisibility-spec t)
2123     ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t))        (setq buffer-invisibility-spec (list t)))
2124          (setq buffer-invisibility-spec (list arg)))    (setq buffer-invisibility-spec
2125     (t          (cons arg buffer-invisibility-spec)))
     (setq buffer-invisibility-spec  
           (cons arg buffer-invisibility-spec)))))  
2126    
2127  (defun remove-from-invisibility-spec (arg)  (defun remove-from-invisibility-spec (arg)
2128    "Remove elements from `buffer-invisibility-spec'."    "Remove elements from `buffer-invisibility-spec'."
# Line 2116  Return the modified alist." Line 2221  Return the modified alist."
2221  (defun make-temp-file (prefix &optional dir-flag suffix)  (defun make-temp-file (prefix &optional dir-flag suffix)
2222    "Create a temporary file.    "Create a temporary file.
2223  The returned file name (created by appending some random characters at the end  The returned file name (created by appending some random characters at the end
2224  of PREFIX, and expanding against `temporary-file-directory' if necessary,  of PREFIX, and expanding against `temporary-file-directory' if necessary),
2225  is guaranteed to point to a newly created empty file.  is guaranteed to point to a newly created empty file.
2226  You can then use `write-region' to write new data into the file.  You can then use `write-region' to write new data into the file.
2227    
2228  If DIR-FLAG is non-nil, create a new empty directory instead of a file.  If DIR-FLAG is non-nil, create a new empty directory instead of a file.
2229    
2230  If SUFFIX is non-nil, add that at the end of the file name."  If SUFFIX is non-nil, add that at the end of the file name."
2231    (let (file)    (let ((umask (default-file-modes))
2232      (while (condition-case ()          file)
2233                 (progn      (unwind-protect
2234                   (setq file          (progn
2235                         (make-temp-name            ;; Create temp files with strict access rights.  It's easy to
2236                          (expand-file-name prefix temporary-file-directory)))            ;; loosen them later, whereas it's impossible to close the
2237                   (if suffix            ;; time-window of loose permissions otherwise.
2238                       (setq file (concat file suffix)))            (set-default-file-modes ?\700)
2239                   (if dir-flag            (while (condition-case ()
2240                       (make-directory file)                       (progn
2241                     (write-region "" nil file nil 'silent nil 'excl))                         (setq file
2242                   nil)                               (make-temp-name
2243               (file-already-exists t))                                (expand-file-name prefix temporary-file-directory)))
2244        ;; the file was somehow created by someone else between                         (if suffix
2245        ;; `make-temp-name' and `write-region', let's try again.                             (setq file (concat file suffix)))
2246        nil)                         (if dir-flag
2247      file))                             (make-directory file)
2248                             (write-region "" nil file nil 'silent nil 'excl))
2249                           nil)
2250                       (file-already-exists t))
2251                ;; the file was somehow created by someone else between
2252                ;; `make-temp-name' and `write-region', let's try again.
2253                nil)
2254              file)
2255          ;; Reset the umask.
2256          (set-default-file-modes umask))))
2257    
2258    
2259  (defun add-minor-mode (toggle name &optional keymap after toggle-fun)  (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
# Line 2170  If TOGGLE has a `:menu-tag', that is use Line 2284  If TOGGLE has a `:menu-tag', that is use
2284    ;; Add the name to the minor-mode-alist.    ;; Add the name to the minor-mode-alist.
2285    (when name    (when name
2286      (let ((existing (assq toggle minor-mode-alist)))      (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")))  
2287        (if existing        (if existing
2288            (setcdr existing (list name))            (setcdr existing (list name))
2289          (let ((tail minor-mode-alist) found)          (let ((tail minor-mode-alist) found)
# Line 2196  If TOGGLE has a `:menu-tag', that is use Line 2305  If TOGGLE has a `:menu-tag', that is use
2305              (concat              (concat
2306               (or (get toggle :menu-tag)               (or (get toggle :menu-tag)
2307                   (if (stringp name) name (symbol-name toggle)))                   (if (stringp name) name (symbol-name toggle)))
2308               (let ((mode-name (if (stringp name) name               (let ((mode-name (if (symbolp name) (symbol-value name))))
2309                                  (if (symbolp name) (symbol-value name)))))                 (if (and (stringp mode-name) (string-match "[^ ]+" mode-name))
2310                 (if mode-name                     (concat " (" (match-string 0 mode-name) ")"))))
                    (concat " (" mode-name ")"))))  
2311              toggle-fun              toggle-fun
2312              :button (cons :toggle toggle))))              :button (cons :toggle toggle))))
2313    
2314    ;; Add the map to the minor-mode-map-alist.        ;; Add the map to the minor-mode-map-alist.
2315    (when keymap    (when keymap
2316      (let ((existing (assq toggle minor-mode-map-alist)))      (let ((existing (assq toggle minor-mode-map-alist)))
2317        (if existing        (if existing
# Line 2290  clone should be incorporated in the clon Line 2398  clone should be incorporated in the clon
2398    ;; where the clone is reduced to the empty string (we want the overlay to    ;; where the clone is reduced to the empty string (we want the overlay to
2399    ;; stay when the clone's content is the empty string and we want to use    ;; stay when the clone's content is the empty string and we want to use
2400    ;; `evaporate' to make sure those overlays get deleted when needed).    ;; `evaporate' to make sure those overlays get deleted when needed).
2401    ;;    ;;
2402    (let* ((pt-end (+ (point) (- end start)))    (let* ((pt-end (+ (point) (- end start)))
2403           (start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))           (start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))
2404                             0 1))                             0 1))
# Line 2307  clone should be incorporated in the clon Line 2415  clone should be incorporated in the clon
2415      ;;(overlay-put ol1 'face 'underline)      ;;(overlay-put ol1 'face 'underline)
2416      (overlay-put ol1 'evaporate t)      (overlay-put ol1 'evaporate t)
2417      (overlay-put ol1 'text-clones dups)      (overlay-put ol1 'text-clones dups)
2418      ;;      ;;
2419      (overlay-put ol2 'modification-hooks '(text-clone-maintain))      (overlay-put ol2 'modification-hooks '(text-clone-maintain))
2420      (when spreadp (overlay-put ol2 'text-clone-spreadp t))      (when spreadp (overlay-put ol2 'text-clone-spreadp t))
2421      (when syntax (overlay-put ol2 'text-clone-syntax syntax))      (when syntax (overlay-put ol2 'text-clone-syntax syntax))
2422      ;;(overlay-put ol2 'face 'underline)      ;;(overlay-put ol2 'face 'underline)
2423      (overlay-put ol2 'evaporate t)      (overlay-put ol2 'evaporate t)
2424      (overlay-put ol2 'text-clones dups)))      (overlay-put ol2 'text-clones dups)))
2425    
2426  (defun play-sound (sound)  (defun play-sound (sound)
2427    "SOUND is a list of the form `(sound KEYWORD VALUE...)'.    "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
2428  The following keywords are recognized:  The following keywords are recognized:
# Line 2336  a system-dependent default device name i Line 2444  a system-dependent default device name i
2444      (error "This Emacs binary lacks sound support"))      (error "This Emacs binary lacks sound support"))
2445    (play-sound-internal sound))    (play-sound-internal sound))
2446    
2447    (defun define-mail-user-agent (symbol composefunc sendfunc
2448                                          &optional abortfunc hookvar)
2449      "Define a symbol to identify a mail-sending package for `mail-user-agent'.
2450    
2451    SYMBOL can be any Lisp symbol.  Its function definition and/or
2452    value as a variable do not matter for this usage; we use only certain
2453    properties on its property list, to encode the rest of the arguments.
2454    
2455    COMPOSEFUNC is program callable function that composes an outgoing
2456    mail message buffer.  This function should set up the basics of the
2457    buffer without requiring user interaction.  It should populate the
2458    standard mail headers, leaving the `to:' and `subject:' headers blank
2459    by default.
2460    
2461    COMPOSEFUNC should accept several optional arguments--the same
2462    arguments that `compose-mail' takes.  See that function's documentation.
2463    
2464    SENDFUNC is the command a user would run to send the message.
2465    
2466    Optional ABORTFUNC is the command a user would run to abort the
2467    message.  For mail packages that don't have a separate abort function,
2468    this can be `kill-buffer' (the equivalent of omitting this argument).
2469    
2470    Optional HOOKVAR is a hook variable that gets run before the message
2471    is actually sent.  Callers that use the `mail-user-agent' may
2472    install a hook function temporarily on this hook variable.
2473    If HOOKVAR is nil, `mail-send-hook' is used.
2474    
2475    The properties used on SYMBOL are `composefunc', `sendfunc',
2476    `abortfunc', and `hookvar'."
2477      (put symbol 'composefunc composefunc)
2478      (put symbol 'sendfunc sendfunc)
2479      (put symbol 'abortfunc (or abortfunc 'kill-buffer))
2480      (put symbol 'hookvar (or hookvar 'mail-send-hook)))
2481    
2482  ;;; subr.el ends here  ;;; subr.el ends here

Legend:
Removed from v.1.307.2.1  
changed lines
  Added in v.1.307.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26