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 |
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))) |
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." |
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'." |
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)) |
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) |
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)) |
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) |
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) |
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. |
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. |
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. |
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. |
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)) |
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) |
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. |
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 |
|
|
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) |
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. |
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. |
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. |
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) |
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 |
|
|
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)) |
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. |
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)) |
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 |
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)))) |
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. |
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) |
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." |
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) |
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 |
|
|
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'." |
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) |
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) |
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 |
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)) |
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: |
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 |