![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to subr.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to subr.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 1: ;; Basic lisp subroutines for Emacs
2: ;; Copyright (C) 1985, 1986, 1990 Free Software Foundation, Inc.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is free software; you can redistribute it and/or modify
7: ;; it under the terms of the GNU General Public License as published by
8: ;; the Free Software Foundation; either version 1, or (at your option)
9: ;; any later version.
10:
11: ;; GNU Emacs is distributed in the hope that it will be useful,
12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14: ;; GNU General Public License for more details.
15:
16: ;; You should have received a copy of the GNU General Public License
17: ;; along with GNU Emacs; see the file COPYING. If not, write to
18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19:
20:
21: (defun one-window-p (&optional nomini)
22: "Returns non-nil if there is only one window.
23: Optional arg NOMINI non-nil means don't count the minibuffer
24: even if it is active."
25: (let ((base-window (selected-window)))
26: (if (and nomini (eq base-window (minibuffer-window)))
27: (setq base-window (next-window base-window)))
28: (eq base-window
29: (next-window base-window (if nomini 'arg)))))
30:
31: (defun read-quoted-char (&optional prompt)
32: "Like `read-char', except that if the first character read is an octal
33: digit, we read up to two more octal digits and return the character
34: represented by the octal number consisting of those digits.
35: Optional argument PROMPT specifies a string to use to prompt the user."
36: (let ((count 0) (code 0) char)
37: (while (< count 3)
38: (let ((inhibit-quit (zerop count))
39: (help-form nil))
40: (and prompt (message "%s-" prompt))
41: (setq char (read-char))
42: (if inhibit-quit (setq quit-flag nil)))
43: (cond ((null char))
44: ((and (<= ?0 char) (<= char ?7))
45: (setq code (+ (* code 8) (- char ?0))
46: count (1+ count))
47: (and prompt (message (setq prompt
48: (format "%s %c" prompt char)))))
49: ((> count 0)
50: (setq unread-command-char char count 259))
51: (t (setq code char count 259))))
52: (logand 255 code)))
53:
54: (defun error (&rest args)
55: "Signal an error, making error message by passing all args to `format'."
56: (while t
57: (signal 'error (list (apply 'format args)))))
58:
59: (defun undefined ()
60: (interactive)
61: (ding))
62:
63: ;Prevent the \{...} documentation construct
64: ;from mentioning keys that run this command.
65: (put 'undefined 'suppress-keymap t)
66:
67: (defun suppress-keymap (map &optional arg)
68: "Make MAP override all buffer-modifying commands to be undefined.
69: Works by knowing which commands are normally buffer-modifying.
70: Normally also makes digits set numeric arg,
71: but optional second arg NODIGITS non-nil prevents this."
72: (let ((i ? ))
73: (while (< i 127)
74: (aset map i 'undefined)
75: (setq i (1+ i))))
76: (or arg
77: (let (loop)
78: (aset map ?- 'negative-argument)
79: ;; Make plain numbers do numeric args.
80: (setq loop ?0)
81: (while (<= loop ?9)
82: (aset map loop 'digit-argument)
83: (setq loop (1+ loop))))))
84:
85: ;; now in fns.c
86: ;(defun nth (n list)
87: ; "Returns the Nth element of LIST.
88: ;N counts from zero. If LIST is not that long, nil is returned."
89: ; (car (nthcdr n list)))
90: ;
91: ;(defun copy-alist (alist)
92: ; "Return a copy of ALIST.
93: ;This is a new alist which represents the same mapping
94: ;from objects to objects, but does not share the alist structure with ALIST.
95: ;The objects mapped (cars and cdrs of elements of the alist)
96: ;are shared, however."
97: ; (setq alist (copy-sequence alist))
98: ; (let ((tail alist))
99: ; (while tail
100: ; (if (consp (car tail))
101: ; (setcar tail (cons (car (car tail)) (cdr (car tail)))))
102: ; (setq tail (cdr tail))))
103: ; alist)
104:
105: ;Moved to keymap.c
106: ;(defun copy-keymap (keymap)
107: ; "Return a copy of KEYMAP"
108: ; (while (not (keymapp keymap))
109: ; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
110: ; (if (vectorp keymap)
111: ; (copy-sequence keymap)
112: ; (copy-alist keymap)))
113:
114: (defun substitute-key-definition (olddef newdef keymap)
115: "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
116: In other words, OLDDEF is replaced with NEWDEF where ever it appears."
117: (if (arrayp keymap)
118: (let ((len (length keymap))
119: (i 0))
120: (while (< i len)
121: (if (eq (aref keymap i) olddef)
122: (aset keymap i newdef))
123: (setq i (1+ i))))
124: (while keymap
125: (if (eq (cdr-safe (car-safe keymap)) olddef)
126: (setcdr (car keymap) newdef))
127: (setq keymap (cdr keymap)))))
128:
129: ;; Avoids useless byte-compilation.
130: ;; In the future, would be better to fix byte compiler
131: ;; not to really compile in cases like this,
132: ;; and use defun here.
133: (fset 'ignore '(lambda (&rest ignore) nil))
134:
135:
136: ; old names
137: (fset 'make-syntax-table 'copy-syntax-table)
138: (fset 'dot 'point)
139: (fset 'dot-marker 'point-marker)
140: (fset 'dot-min 'point-min)
141: (fset 'dot-max 'point-max)
142: (fset 'window-dot 'window-point)
143: (fset 'set-window-dot 'set-window-point)
144: (fset 'read-input 'read-string)
145: (fset 'send-string 'process-send-string)
146: (fset 'send-region 'process-send-region)
147: (fset 'show-buffer 'set-window-buffer)
148:
149: ; alternate names
150: (fset 'string= 'string-equal)
151: (fset 'string< 'string-lessp)
152: (fset 'mod '%)
153: (fset 'move-marker 'set-marker)
154: (fset 'eql 'eq)
155: (fset 'not 'null)
156: (fset 'numberp 'integerp)
157: (fset 'rplaca 'setcar)
158: (fset 'rplacd 'setcdr)
159: (fset 'beep 'ding) ;preserve lingual purtity
160: (fset 'indent-to-column 'indent-to)
161: (fset 'backward-delete-char 'delete-backward-char)
162:
163: (defvar global-map nil
164: "Default global keymap mapping Emacs keyboard input into commands.
165: The value is a keymap which is usually (but not necessarily) Emacs's
166: global map.")
167:
168: (defvar ctl-x-map nil
169: "Default keymap for C-x commands.
170: The normal global definition of the character C-x indirects to this keymap.")
171:
172: (defvar esc-map nil
173: "Default keymap for ESC (meta) commands.
174: The normal global definition of the character ESC indirects to this keymap.")
175:
176: (defvar mouse-map nil
177: "Keymap for mouse commands from the X window system.")
178:
179: (defun run-hooks (&rest hooklist)
180: "Takes hook names and runs each one in turn. Major mode functions use this.
181: Each argument should be a symbol, a hook variable.
182: These symbols are processed in the order specified.
183: If a hook symbol has a non-nil value, that value may be a function
184: or a list of functions to be called to run the hook.
185: If the value is a function, it is called with no arguments.
186: If it is a list, the elements are called, in order, with no arguments."
187: (while hooklist
188: (let ((sym (car hooklist)))
189: (and (boundp sym)
190: (symbol-value sym)
191: (let ((value (symbol-value sym)))
192: (if (and (listp value) (not (eq (car value) 'lambda)))
193: (mapcar 'funcall value)
194: (funcall value)))))
195: (setq hooklist (cdr hooklist))))
196:
197: (defun momentary-string-display (string pos &optional exit-char message)
198: "Momentarily display STRING in the buffer at POS.
199: Display remains until next character is typed.
200: If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
201: otherwise it is then available as input (as a command if nothing else).
202: Display MESSAGE (optional fourth arg) in the echo area.
203: If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
204: (or exit-char (setq exit-char ?\ ))
205: (let ((buffer-read-only nil)
206: (modified (buffer-modified-p))
207: (name buffer-file-name)
208: insert-end)
209: (unwind-protect
210: (progn
211: (save-excursion
212: (goto-char pos)
213: ;; defeat file locking... don't try this at home, kids!
214: (setq buffer-file-name nil)
215: (insert-before-markers string)
216: (setq insert-end (point)))
217: (message (or message "Type %s to continue editing.")
218: (single-key-description exit-char))
219: (let ((char (read-char)))
220: (or (eq char exit-char)
221: (setq unread-command-char char))))
222: (if insert-end
223: (save-excursion
224: (delete-region pos insert-end)))
225: (setq buffer-file-name name)
226: (set-buffer-modified-p modified))))
227:
228: (defun undo-start ()
229: "Move undo-pointer to front of undo records.
230: The next call to undo-more will undo the most recently made change."
231: (if (eq buffer-undo-list t)
232: (error "No undo information in this buffer"))
233: (setq pending-undo-list buffer-undo-list))
234:
235: (defun undo-more (count)
236: "Undo back N undo-boundaries beyond what was already undone recently.
237: Call undo-start to get ready to undo recent changes,
238: then call undo-more one or more times to undo them."
239: (or pending-undo-list
240: (error "No further undo information"))
241: (setq pending-undo-list (primitive-undo count pending-undo-list)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.