aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJuanma Barranquero2003-05-30 23:31:15 +0000
committerJuanma Barranquero2003-05-30 23:31:15 +0000
commit5e046f6d571737bb8cd115bf67f9ee76519ba3cb (patch)
treec25147d32cbb72db4fb264c670f3cfb3b6f08af0
parent9d7aa1b1b6f7eb8d97c2cc620022a708d43398f2 (diff)
downloademacs-5e046f6d571737bb8cd115bf67f9ee76519ba3cb.tar.gz
emacs-5e046f6d571737bb8cd115bf67f9ee76519ba3cb.zip
Moved from lisp/.
Diffstat
-rw-r--r--lisp/emacs-lisp/byte-run.el172
-rw-r--r--lisp/emacs-lisp/derived.el436
-rw-r--r--lisp/emacs-lisp/float-sup.el63
-rw-r--r--lisp/emacs-lisp/map-ynp.el264
-rw-r--r--lisp/emacs-lisp/regi.el258
-rw-r--r--lisp/emacs-lisp/timer.el479
-rw-r--r--lisp/emacs-lisp/warnings.el311
-rw-r--r--lisp/progmodes/which-func.el256
-rw-r--r--lisp/textmodes/enriched.el474
9 files changed, 2713 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
new file mode 100644
index 00000000000..a28f89cd91a
--- /dev/null
+++ b/lisp/emacs-lisp/byte-run.el
@@ -0,0 +1,172 @@
1;;; byte-run.el --- byte-compiler support for inlining
2
3;; Copyright (C) 1992 Free Software Foundation, Inc.
4
5;; Author: Jamie Zawinski <jwz@lucid.com>
6;; Hallvard Furuseth <hbf@ulrik.uio.no>
7;; Maintainer: FSF
8;; Keywords: internal
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
27;;; Commentary:
28
29;; interface to selectively inlining functions.
30;; This only happens when source-code optimization is turned on.
31
32;;; Code:
33
34;; Redefined in byte-optimize.el.
35;; This is not documented--it's not clear that we should promote it.
36(fset 'inline 'progn)
37(put 'inline 'lisp-indent-hook 0)
38
39
40;;; Interface to inline functions.
41
42;; (defmacro proclaim-inline (&rest fns)
43;; "Cause the named functions to be open-coded when called from compiled code.
44;; They will only be compiled open-coded when byte-compile-optimize is true."
45;; (cons 'eval-and-compile
46;; (mapcar '(lambda (x)
47;; (or (memq (get x 'byte-optimizer)
48;; '(nil byte-compile-inline-expand))
49;; (error
50;; "%s already has a byte-optimizer, can't make it inline"
51;; x))
52;; (list 'put (list 'quote x)
53;; ''byte-optimizer ''byte-compile-inline-expand))
54;; fns)))
55
56;; (defmacro proclaim-notinline (&rest fns)
57;; "Cause the named functions to no longer be open-coded."
58;; (cons 'eval-and-compile
59;; (mapcar '(lambda (x)
60;; (if (eq (get x 'byte-optimizer) 'byte-compile-inline-expand)
61;; (put x 'byte-optimizer nil))
62;; (list 'if (list 'eq (list 'get (list 'quote x) ''byte-optimizer)
63;; ''byte-compile-inline-expand)
64;; (list 'put x ''byte-optimizer nil)))
65;; fns)))
66
67;; This has a special byte-hunk-handler in bytecomp.el.
68(defmacro defsubst (name arglist &rest body)
69 "Define an inline function. The syntax is just like that of `defun'."
70 (or (memq (get name 'byte-optimizer)
71 '(nil byte-compile-inline-expand))
72 (error "`%s' is a primitive" name))
73 (list 'prog1
74 (cons 'defun (cons name (cons arglist body)))
75 (list 'eval-and-compile
76 (list 'put (list 'quote name)
77 ''byte-optimizer ''byte-compile-inline-expand))))
78
79(defun make-obsolete (fn new &optional when)
80 "Make the byte-compiler warn that FUNCTION is obsolete.
81The warning will say that NEW should be used instead.
82If NEW is a string, that is the `use instead' message.
83If provided, WHEN should be a string indicating when the function
84was first made obsolete, for example a date or a release number."
85 (interactive "aMake function obsolete: \nxObsoletion replacement: ")
86 (let ((handler (get fn 'byte-compile)))
87 (if (eq 'byte-compile-obsolete handler)
88 (setq handler (nth 1 (get fn 'byte-obsolete-info)))
89 (put fn 'byte-compile 'byte-compile-obsolete))
90 (put fn 'byte-obsolete-info (list new handler when)))
91 fn)
92
93(defun make-obsolete-variable (var new &optional when)
94 "Make the byte-compiler warn that VARIABLE is obsolete,
95and NEW should be used instead. If NEW is a string, then that is the
96`use instead' message.
97If provided, WHEN should be a string indicating when the variable
98was first made obsolete, for example a date or a release number."
99 (interactive
100 (list
101 (let ((str (completing-read "Make variable obsolete: " obarray 'boundp t)))
102 (if (equal str "") (error ""))
103 (intern str))
104 (car (read-from-string (read-string "Obsoletion replacement: ")))))
105 (put var 'byte-obsolete-variable (cons new when))
106 var)
107
108(put 'dont-compile 'lisp-indent-hook 0)
109(defmacro dont-compile (&rest body)
110 "Like `progn', but the body always runs interpreted (not compiled).
111If you think you need this, you're probably making a mistake somewhere."
112 (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
113
114
115;;; interface to evaluating things at compile time and/or load time
116;;; these macro must come after any uses of them in this file, as their
117;;; definition in the file overrides the magic definitions on the
118;;; byte-compile-macro-environment.
119
120(put 'eval-when-compile 'lisp-indent-hook 0)
121(defmacro eval-when-compile (&rest body)
122 "Like `progn', but evaluates the body at compile time.
123The result of the body appears to the compiler as a quoted constant."
124 ;; Not necessary because we have it in b-c-initial-macro-environment
125 ;; (list 'quote (eval (cons 'progn body)))
126 (cons 'progn body))
127
128(put 'eval-and-compile 'lisp-indent-hook 0)
129(defmacro eval-and-compile (&rest body)
130 "Like `progn', but evaluates the body at compile time and at load time."
131 ;; Remember, it's magic.
132 (cons 'progn body))
133
134(defun with-no-warnings (&optional first &rest body)
135 "Like `progn', but prevents compiler warnings in the body."
136 ;; The implementation for the interpreter is basically trivial.
137 (if body (car (last body))
138 first))
139
140
141;;; I nuked this because it's not a good idea for users to think of using it.
142;;; These options are a matter of installation preference, and have nothing to
143;;; with particular source files; it's a mistake to suggest to users
144;;; they should associate these with particular source files.
145;;; There is hardly any reason to change these parameters, anyway.
146;;; --rms.
147
148;; (put 'byte-compiler-options 'lisp-indent-hook 0)
149;; (defmacro byte-compiler-options (&rest args)
150;; "Set some compilation-parameters for this file. This will affect only the
151;; file in which it appears; this does nothing when evaluated, and when loaded
152;; from a .el file.
153;;
154;; Each argument to this macro must be a list of a key and a value.
155;;
156;; Keys: Values: Corresponding variable:
157;;
158;; verbose t, nil byte-compile-verbose
159;; optimize t, nil, source, byte byte-compile-optimize
160;; warnings list of warnings byte-compile-warnings
161;; Legal elements: (callargs redefine free-vars unresolved)
162;; file-format emacs18, emacs19 byte-compile-compatibility
163;;
164;; For example, this might appear at the top of a source file:
165;;
166;; (byte-compiler-options
167;; (optimize t)
168;; (warnings (- free-vars)) ; Don't warn about free variables
169;; (file-format emacs19))"
170;; nil)
171
172;;; byte-run.el ends here
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
new file mode 100644
index 00000000000..8d152f391bc
--- /dev/null
+++ b/lisp/emacs-lisp/derived.el
@@ -0,0 +1,436 @@
1;;; derived.el --- allow inheritance of major modes
2;;; (formerly mode-clone.el)
3
4;; Copyright (C) 1993, 1994, 1999, 2003 Free Software Foundation, Inc.
5
6;; Author: David Megginson (dmeggins@aix1.uottawa.ca)
7;; Maintainer: FSF
8;; Keywords: extensions
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
27;;; Commentary:
28
29;; GNU Emacs is already, in a sense, object oriented -- each object
30;; (buffer) belongs to a class (major mode), and that class defines
31;; the relationship between messages (input events) and methods
32;; (commands) by means of a keymap.
33;;
34;; The only thing missing is a good scheme of inheritance. It is
35;; possible to simulate a single level of inheritance with generous
36;; use of hooks and a bit of work -- sgml-mode, for example, also runs
37;; the hooks for text-mode, and keymaps can inherit from other keymaps
38;; -- but generally, each major mode ends up reinventing the wheel.
39;; Ideally, someone should redesign all of Emacs's major modes to
40;; follow a more conventional object-oriented system: when defining a
41;; new major mode, the user should need only to name the existing mode
42;; it is most similar to, then list the (few) differences.
43;;
44;; In the mean time, this package offers most of the advantages of
45;; full inheritance with the existing major modes. The macro
46;; `define-derived-mode' allows the user to make a variant of an existing
47;; major mode, with its own keymap. The new mode will inherit the key
48;; bindings of its parent, and will, in fact, run its parent first
49;; every time it is called. For example, the commands
50;;
51;; (define-derived-mode hypertext-mode text-mode "Hypertext"
52;; "Major mode for hypertext.\n\n\\{hypertext-mode-map}"
53;; (setq case-fold-search nil))
54;;
55;; (define-key hypertext-mode-map [down-mouse-3] 'do-hyper-link)
56;;
57;; will create a function `hypertext-mode' with its own (sparse)
58;; keymap `hypertext-mode-map.' The command M-x hypertext-mode will
59;; perform the following actions:
60;;
61;; - run the command (text-mode) to get its default setup
62;; - replace the current keymap with 'hypertext-mode-map,' which will
63;; inherit from 'text-mode-map'.
64;; - replace the current syntax table with
65;; 'hypertext-mode-syntax-table', which will borrow its defaults
66;; from the current text-mode-syntax-table.
67;; - replace the current abbrev table with
68;; 'hypertext-mode-abbrev-table', which will borrow its defaults
69;; from the current text-mode-abbrev table
70;; - change the mode line to read "Hypertext"
71;; - assign the value 'hypertext-mode' to the 'major-mode' variable
72;; - run the body of commands provided in the macro -- in this case,
73;; set the local variable `case-fold-search' to nil.
74;;
75;; The advantages of this system are threefold. First, text mode is
76;; untouched -- if you had added the new keystroke to `text-mode-map,'
77;; possibly using hooks, you would have added it to all text buffers
78;; -- here, it appears only in hypertext buffers, where it makes
79;; sense. Second, it is possible to build even further, and make
80;; a derived mode from a derived mode. The commands
81;;
82;; (define-derived-mode html-mode hypertext-mode "HTML")
83;; [various key definitions]
84;;
85;; will add a new major mode for HTML with very little fuss.
86;;
87;; Note also the function `derived-mode-p' which can tell if the current
88;; mode derives from another. In a hypertext-mode, buffer, for example,
89;; (derived-mode-p 'text-mode) would return non-nil. This should always
90;; be used in place of (eq major-mode 'text-mode).
91
92;;; Code:
93
94(eval-when-compile (require 'cl))
95
96;;; PRIVATE: defsubst must be defined before they are first used
97
98(defsubst derived-mode-hook-name (mode)
99 "Construct the mode hook name based on mode name MODE."
100 (intern (concat (symbol-name mode) "-hook")))
101
102(defsubst derived-mode-map-name (mode)
103 "Construct a map name based on a MODE name."
104 (intern (concat (symbol-name mode) "-map")))
105
106(defsubst derived-mode-syntax-table-name (mode)
107 "Construct a syntax-table name based on a MODE name."
108 (intern (concat (symbol-name mode) "-syntax-table")))
109
110(defsubst derived-mode-abbrev-table-name (mode)
111 "Construct an abbrev-table name based on a MODE name."
112 (intern (concat (symbol-name mode) "-abbrev-table")))
113
114;; PUBLIC: define a new major mode which inherits from an existing one.
115
116;;;###autoload
117(defmacro define-derived-mode (child parent name &optional docstring &rest body)
118 "Create a new mode as a variant of an existing mode.
119
120The arguments to this command are as follow:
121
122CHILD: the name of the command for the derived mode.
123PARENT: the name of the command for the parent mode (e.g. `text-mode')
124 or nil if there is no parent.
125NAME: a string which will appear in the status line (e.g. \"Hypertext\")
126DOCSTRING: an optional documentation string--if you do not supply one,
127 the function will attempt to invent something useful.
128BODY: forms to execute just before running the
129 hooks for the new mode. Do not use `interactive' here.
130
131BODY can start with a bunch of keyword arguments. The following keyword
132 arguments are currently understood:
133:group GROUP
134 Declare the customization group that corresponds to this mode.
135:syntax-table TABLE
136 Use TABLE instead of the default.
137 A nil value means to simply use the same syntax-table as the parent.
138:abbrev-table TABLE
139 Use TABLE instead of the default.
140 A nil value means to simply use the same abbrev-table as the parent.
141
142Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode:
143
144 (define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\")
145
146You could then make new key bindings for `LaTeX-thesis-mode-map'
147without changing regular LaTeX mode. In this example, BODY is empty,
148and DOCSTRING is generated by default.
149
150On a more complicated level, the following command uses `sgml-mode' as
151the parent, and then sets the variable `case-fold-search' to nil:
152
153 (define-derived-mode article-mode sgml-mode \"Article\"
154 \"Major mode for editing technical articles.\"
155 (setq case-fold-search nil))
156
157Note that if the documentation string had been left out, it would have
158been generated automatically, with a reference to the keymap."
159 (declare (debug (&define name symbolp sexp [&optional stringp]
160 [&rest keywordp sexp] def-body)))
161
162 (when (and docstring (not (stringp docstring)))
163 ;; Some trickiness, since what appears to be the docstring may really be
164 ;; the first element of the body.
165 (push docstring body)
166 (setq docstring nil))
167
168 (when (eq parent 'fundamental-mode) (setq parent nil))
169
170 (let ((map (derived-mode-map-name child))
171 (syntax (derived-mode-syntax-table-name child))
172 (abbrev (derived-mode-abbrev-table-name child))
173 (declare-abbrev t)
174 (declare-syntax t)
175 (hook (derived-mode-hook-name child))
176 (group nil))
177
178 ;; Process the keyword args.
179 (while (keywordp (car body))
180 (case (pop body)
181 (:group (setq group (pop body)))
182 (:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
183 (:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
184 (t (pop body))))
185
186 (setq docstring (derived-mode-make-docstring
187 parent child docstring syntax abbrev))
188
189 `(progn
190 (defvar ,map (make-sparse-keymap))
191 ,(if declare-syntax
192 `(defvar ,syntax (make-syntax-table)))
193 ,(if declare-abbrev
194 `(defvar ,abbrev
195 (progn (define-abbrev-table ',abbrev nil) ,abbrev)))
196 (put ',child 'derived-mode-parent ',parent)
197 ,(if group `(put ',child 'custom-mode-group ,group))
198
199 (defun ,child ()
200 ,docstring
201 (interactive)
202 ; Run the parent.
203 (delay-mode-hooks
204
205 (,(or parent 'kill-all-local-variables))
206 ; Identify the child mode.
207 (setq major-mode (quote ,child))
208 (setq mode-name ,name)
209 ; Identify special modes.
210 ,(when parent
211 `(progn
212 (if (get (quote ,parent) 'mode-class)
213 (put (quote ,child) 'mode-class
214 (get (quote ,parent) 'mode-class)))
215 ; Set up maps and tables.
216 (unless (keymap-parent ,map)
217 (set-keymap-parent ,map (current-local-map)))
218 ,(when declare-syntax
219 `(let ((parent (char-table-parent ,syntax)))
220 (unless (and parent
221 (not (eq parent (standard-syntax-table))))
222 (set-char-table-parent ,syntax (syntax-table)))))))
223
224 (use-local-map ,map)
225 ,(when syntax `(set-syntax-table ,syntax))
226 ,(when abbrev `(setq local-abbrev-table ,abbrev))
227 ; Splice in the body (if any).
228 ,@body
229 )
230 ;; Run the hooks, if any.
231 ;; Make the generated code work in older Emacs versions
232 ;; that do not yet have run-mode-hooks.
233 (if (fboundp 'run-mode-hooks)
234 (run-mode-hooks ',hook)
235 (run-hooks ',hook))))))
236
237;; PUBLIC: find the ultimate class of a derived mode.
238
239(defun derived-mode-class (mode)
240 "Find the class of a major MODE.
241A mode's class is the first ancestor which is NOT a derived mode.
242Use the `derived-mode-parent' property of the symbol to trace backwards.
243Since major-modes might all derive from `fundamental-mode', this function
244is not very useful."
245 (while (get mode 'derived-mode-parent)
246 (setq mode (get mode 'derived-mode-parent)))
247 mode)
248(make-obsolete 'derived-mode-class 'derived-mode-p "21.4")
249
250
251;;; PRIVATE
252
253(defun derived-mode-make-docstring (parent child &optional
254 docstring syntax abbrev)
255 "Construct a docstring for a new mode if none is provided."
256
257 (let ((map (derived-mode-map-name child))
258 (hook (derived-mode-hook-name child)))
259
260 (unless (stringp docstring)
261 ;; Use a default docstring.
262 (setq docstring
263 (if (null parent)
264 (format "Major-mode.
265Uses keymap `%s', abbrev table `%s' and syntax-table `%s'." map abbrev syntax)
266 (format "Major mode derived from `%s' by `define-derived-mode'.
267It inherits all of the parent's attributes, but has its own keymap,
268abbrev table and syntax table:
269
270 `%s', `%s' and `%s'
271
272which more-or-less shadow %s's corresponding tables."
273 parent map abbrev syntax parent))))
274
275 (unless (string-match (regexp-quote (symbol-name hook)) docstring)
276 ;; Make sure the docstring mentions the mode's hook.
277 (setq docstring
278 (concat docstring
279 (if (null parent)
280 "\n\nThis mode "
281 (concat
282 "\n\nIn addition to any hooks its parent mode "
283 (if (string-match (regexp-quote (format "`%s'" parent))
284 docstring) nil
285 (format "`%s' " parent))
286 "might have run,\nthis mode "))
287 (format "runs the hook `%s'" hook)
288 ", as the final step\nduring initialization.")))
289
290 (unless (string-match "\\\\[{[]" docstring)
291 ;; And don't forget to put the mode's keymap.
292 (setq docstring (concat docstring "\n\n\\{" (symbol-name map) "}")))
293
294 docstring))
295
296
297;;; OBSOLETE
298;; The functions below are only provided for backward compatibility with
299;; code byte-compiled with versions of derived.el prior to Emacs-21.
300
301(defsubst derived-mode-setup-function-name (mode)
302 "Construct a setup-function name based on a MODE name."
303 (intern (concat (symbol-name mode) "-setup")))
304
305
306;; Utility functions for defining a derived mode.
307
308;;;###autoload
309(defun derived-mode-init-mode-variables (mode)
310 "Initialise variables for a new MODE.
311Right now, if they don't already exist, set up a blank keymap, an
312empty syntax table, and an empty abbrev table -- these will be merged
313the first time the mode is used."
314
315 (if (boundp (derived-mode-map-name mode))
316 t
317 (eval `(defvar ,(derived-mode-map-name mode)
318 (make-sparse-keymap)
319 ,(format "Keymap for %s." mode)))
320 (put (derived-mode-map-name mode) 'derived-mode-unmerged t))
321
322 (if (boundp (derived-mode-syntax-table-name mode))
323 t
324 (eval `(defvar ,(derived-mode-syntax-table-name mode)
325 ;; Make a syntax table which doesn't specify anything
326 ;; for any char. Valid data will be merged in by
327 ;; derived-mode-merge-syntax-tables.
328 (make-char-table 'syntax-table nil)
329 ,(format "Syntax table for %s." mode)))
330 (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t))
331
332 (if (boundp (derived-mode-abbrev-table-name mode))
333 t
334 (eval `(defvar ,(derived-mode-abbrev-table-name mode)
335 (progn
336 (define-abbrev-table (derived-mode-abbrev-table-name mode) nil)
337 (make-abbrev-table))
338 ,(format "Abbrev table for %s." mode)))))
339
340;; Utility functions for running a derived mode.
341
342(defun derived-mode-set-keymap (mode)
343 "Set the keymap of the new MODE, maybe merging with the parent."
344 (let* ((map-name (derived-mode-map-name mode))
345 (new-map (eval map-name))
346 (old-map (current-local-map)))
347 (and old-map
348 (get map-name 'derived-mode-unmerged)
349 (derived-mode-merge-keymaps old-map new-map))
350 (put map-name 'derived-mode-unmerged nil)
351 (use-local-map new-map)))
352
353(defun derived-mode-set-syntax-table (mode)
354 "Set the syntax table of the new MODE, maybe merging with the parent."
355 (let* ((table-name (derived-mode-syntax-table-name mode))
356 (old-table (syntax-table))
357 (new-table (eval table-name)))
358 (if (get table-name 'derived-mode-unmerged)
359 (derived-mode-merge-syntax-tables old-table new-table))
360 (put table-name 'derived-mode-unmerged nil)
361 (set-syntax-table new-table)))
362
363(defun derived-mode-set-abbrev-table (mode)
364 "Set the abbrev table for MODE if it exists.
365Always merge its parent into it, since the merge is non-destructive."
366 (let* ((table-name (derived-mode-abbrev-table-name mode))
367 (old-table local-abbrev-table)
368 (new-table (eval table-name)))
369 (derived-mode-merge-abbrev-tables old-table new-table)
370 (setq local-abbrev-table new-table)))
371
372;;;(defun derived-mode-run-setup-function (mode)
373;;; "Run the setup function if it exists."
374
375;;; (let ((fname (derived-mode-setup-function-name mode)))
376;;; (if (fboundp fname)
377;;; (funcall fname))))
378
379(defun derived-mode-run-hooks (mode)
380 "Run the mode hook for MODE."
381 (let ((hooks-name (derived-mode-hook-name mode)))
382 (if (boundp hooks-name)
383 (run-hooks hooks-name))))
384
385;; Functions to merge maps and tables.
386
387(defun derived-mode-merge-keymaps (old new)
388 "Merge an OLD keymap into a NEW one.
389The old keymap is set to be the last cdr of the new one, so that there will
390be automatic inheritance."
391 ;; ?? Can this just use `set-keymap-parent'?
392 (let ((tail new))
393 ;; Scan the NEW map for prefix keys.
394 (while (consp tail)
395 (and (consp (car tail))
396 (let* ((key (vector (car (car tail))))
397 (subnew (lookup-key new key))
398 (subold (lookup-key old key)))
399 ;; If KEY is a prefix key in both OLD and NEW, merge them.
400 (and (keymapp subnew) (keymapp subold)
401 (derived-mode-merge-keymaps subold subnew))))
402 (and (vectorp (car tail))
403 ;; Search a vector of ASCII char bindings for prefix keys.
404 (let ((i (1- (length (car tail)))))
405 (while (>= i 0)
406 (let* ((key (vector i))
407 (subnew (lookup-key new key))
408 (subold (lookup-key old key)))
409 ;; If KEY is a prefix key in both OLD and NEW, merge them.
410 (and (keymapp subnew) (keymapp subold)
411 (derived-mode-merge-keymaps subold subnew)))
412 (setq i (1- i)))))
413 (setq tail (cdr tail))))
414 (setcdr (nthcdr (1- (length new)) new) old))
415
416(defun derived-mode-merge-syntax-tables (old new)
417 "Merge an OLD syntax table into a NEW one.
418Where the new table already has an entry, nothing is copied from the old one."
419 (set-char-table-parent new old))
420
421;; Merge an old abbrev table into a new one.
422;; This function requires internal knowledge of how abbrev tables work,
423;; presuming that they are obarrays with the abbrev as the symbol, the expansion
424;; as the value of the symbol, and the hook as the function definition.
425(defun derived-mode-merge-abbrev-tables (old new)
426 (if old
427 (mapatoms
428 (lambda (symbol)
429 (or (intern-soft (symbol-name symbol) new)
430 (define-abbrev new (symbol-name symbol)
431 (symbol-value symbol) (symbol-function symbol))))
432 old)))
433
434(provide 'derived)
435
436;;; derived.el ends here
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el
new file mode 100644
index 00000000000..4c45112e980
--- /dev/null
+++ b/lisp/emacs-lisp/float-sup.el
@@ -0,0 +1,63 @@
1;;; float-sup.el --- define some constants useful for floating point numbers.
2
3;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
4
5;; Maintainer: FSF
6;; Keywords: internal
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;;; Code:
28
29;; Provide a meaningful error message if we are running on
30;; bare (non-float) emacs.
31
32(if (fboundp 'atan)
33 nil
34 (error "Floating point was disabled at compile time"))
35
36;; provide an easy hook to tell if we are running with floats or not.
37;; define pi and e via math-lib calls. (much less prone to killer typos.)
38(defconst pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
39;; It's too inconvenient to make `e' a constant because it's used as
40;; a temporary variable all the time.
41(defvar e (exp 1) "The value of e (2.7182818...).")
42
43;; Careful when editing this file ... typos here will be hard to spot.
44;; (defconst pi 3.14159265358979323846264338327
45;; "The value of Pi (3.14159265358979323846264338327...)")
46
47(defconst degrees-to-radians (/ pi 180.0)
48 "Degrees to radian conversion constant.")
49(defconst radians-to-degrees (/ 180.0 pi)
50 "Radian to degree conversion constant.")
51
52;; these expand to a single multiply by a float when byte compiled
53
54(defmacro degrees-to-radians (x)
55 "Convert ARG from degrees to radians."
56 (list '* (/ pi 180.0) x))
57(defmacro radians-to-degrees (x)
58 "Convert ARG from radians to degrees."
59 (list '* (/ 180.0 pi) x))
60
61(provide 'lisp-float-type)
62
63;;; float-sup.el ends here
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
new file mode 100644
index 00000000000..2fa97f163d7
--- /dev/null
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -0,0 +1,264 @@
1;;; map-ynp.el --- general-purpose boolean question-asker
2
3;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 Free Software Foundation, Inc.
4
5;; Author: Roland McGrath <roland@gnu.org>
6;; Maintainer: FSF
7;; Keywords: lisp, extensions
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
25
26;;; Commentary:
27
28;; map-y-or-n-p is a general-purpose question-asking function.
29;; It asks a series of y/n questions (a la y-or-n-p), and decides to
30;; apply an action to each element of a list based on the answer.
31;; The nice thing is that you also get some other possible answers
32;; to use, reminiscent of query-replace: ! to answer y to all remaining
33;; questions; ESC or q to answer n to all remaining questions; . to answer
34;; y once and then n for the remainder; and you can get help with C-h.
35
36;;; Code:
37
38(defun map-y-or-n-p (prompter actor list &optional help action-alist
39 no-cursor-in-echo-area)
40 "Ask a series of boolean questions.
41Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST.
42
43LIST is a list of objects, or a function of no arguments to return the next
44object or nil.
45
46If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\). If not
47a string, PROMPTER is a function of one arg (an object from LIST), which
48returns a string to be used as the prompt for that object. If the return
49value is not a string, it may be nil to ignore the object or non-nil to act
50on the object without asking the user.
51
52ACTOR is a function of one arg (an object from LIST),
53which gets called with each object that the user answers `yes' for.
54
55If HELP is given, it is a list (OBJECT OBJECTS ACTION),
56where OBJECT is a string giving the singular noun for an elt of LIST;
57OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive
58verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\).
59
60At the prompts, the user may enter y, Y, or SPC to act on that object;
61n, N, or DEL to skip that object; ! to act on all following objects;
62ESC or q to exit (skip all following objects); . (period) to act on the
63current object and then exit; or \\[help-command] to get help.
64
65If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys
66that will be accepted. KEY is a character; FUNCTION is a function of one
67arg (an object from LIST); HELP is a string. When the user hits KEY,
68FUNCTION is called. If it returns non-nil, the object is considered
69\"acted upon\", and the next object from LIST is processed. If it returns
70nil, the prompt is repeated for the same object.
71
72Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set
73`cursor-in-echo-area' while prompting.
74
75This function uses `query-replace-map' to define the standard responses,
76but not all of the responses which `query-replace' understands
77are meaningful here.
78
79Returns the number of actions taken."
80 (let* ((actions 0)
81 user-keys mouse-event map prompt char elt tail def
82 ;; Non-nil means we should use mouse menus to ask.
83 use-menus
84 delayed-switch-frame
85 (next (if (or (and list (symbolp list))
86 (subrp list)
87 (byte-code-function-p list)
88 (and (consp list)
89 (eq (car list) 'lambda)))
90 (function (lambda ()
91 (setq elt (funcall list))))
92 (function (lambda ()
93 (if list
94 (progn
95 (setq elt (car list)
96 list (cdr list))
97 t)
98 nil))))))
99 (if (and (listp last-nonmenu-event)
100 use-dialog-box)
101 ;; Make a list describing a dialog box.
102 (let ((object (if help (capitalize (nth 0 help))))
103 (objects (if help (capitalize (nth 1 help))))
104 (action (if help (capitalize (nth 2 help)))))
105 (setq map `(("Yes" . act) ("No" . skip) ("Quit" . exit)
106 (,(if help (concat action " " object " And Quit")
107 "Do it and Quit") . act-and-exit)
108 (,(if help (concat action " All " objects)
109 "Do All") . automatic)
110 ,@(mapcar (lambda (elt)
111 (cons (capitalize (nth 2 elt))
112 (vector (nth 1 elt))))
113 action-alist))
114 use-menus t
115 mouse-event last-nonmenu-event))
116 (setq user-keys (if action-alist
117 (concat (mapconcat (function
118 (lambda (elt)
119 (key-description
120 (char-to-string (car elt)))))
121 action-alist ", ")
122 " ")
123 "")
124 ;; Make a map that defines each user key as a vector containing
125 ;; its definition.
126 map (cons 'keymap
127 (append (mapcar (lambda (elt)
128 (cons (car elt) (vector (nth 1 elt))))
129 action-alist)
130 query-replace-map))))
131 (unwind-protect
132 (progn
133 (if (stringp prompter)
134 (setq prompter `(lambda (object)
135 (format ,prompter object))))
136 (while (funcall next)
137 (setq prompt (funcall prompter elt))
138 (cond ((stringp prompt)
139 ;; Prompt the user about this object.
140 (setq quit-flag nil)
141 (if use-menus
142 (setq def (or (x-popup-dialog (or mouse-event use-menus)
143 (cons prompt map))
144 'quit))
145 ;; Prompt in the echo area.
146 (let ((cursor-in-echo-area (not no-cursor-in-echo-area))
147 (message-log-max nil))
148 (message "%s(y, n, !, ., q, %sor %s) "
149 prompt user-keys
150 (key-description (vector help-char)))
151 (if minibuffer-auto-raise
152 (raise-frame (window-frame (minibuffer-window))))
153 (while (progn
154 (setq char (read-event))
155 ;; If we get -1, from end of keyboard
156 ;; macro, try again.
157 (equal char -1)))
158 ;; Show the answer to the question.
159 (message "%s(y, n, !, ., q, %sor %s) %s"
160 prompt user-keys
161 (key-description (vector help-char))
162 (single-key-description char)))
163 (setq def (lookup-key map (vector char))))
164 (cond ((eq def 'exit)
165 (setq next (function (lambda () nil))))
166 ((eq def 'act)
167 ;; Act on the object.
168 (funcall actor elt)
169 (setq actions (1+ actions)))
170 ((eq def 'skip)
171 ;; Skip the object.
172 )
173 ((eq def 'act-and-exit)
174 ;; Act on the object and then exit.
175 (funcall actor elt)
176 (setq actions (1+ actions)
177 next (function (lambda () nil))))
178 ((eq def 'quit)
179 (setq quit-flag t)
180 (setq next `(lambda ()
181 (setq next ',next)
182 ',elt)))
183 ((eq def 'automatic)
184 ;; Act on this and all following objects.
185 (if (funcall prompter elt)
186 (progn
187 (funcall actor elt)
188 (setq actions (1+ actions))))
189 (while (funcall next)
190 (if (funcall prompter elt)
191 (progn
192 (funcall actor elt)
193 (setq actions (1+ actions))))))
194 ((eq def 'help)
195 (with-output-to-temp-buffer "*Help*"
196 (princ
197 (let ((object (if help (nth 0 help) "object"))
198 (objects (if help (nth 1 help) "objects"))
199 (action (if help (nth 2 help) "act on")))
200 (concat
201 (format "Type SPC or `y' to %s the current %s;
202DEL or `n' to skip the current %s;
203RET or `q' to exit (skip all remaining %s);
204C-g to quit (cancel the operation);
205! to %s all remaining %s;\n"
206 action object object objects action
207 objects)
208 (mapconcat (function
209 (lambda (elt)
210 (format "%s to %s"
211 (single-key-description
212 (nth 0 elt))
213 (nth 2 elt))))
214 action-alist
215 ";\n")
216 (if action-alist ";\n")
217 (format "or . (period) to %s \
218the current %s and exit."
219 action object))))
220 (save-excursion
221 (set-buffer standard-output)
222 (help-mode)))
223
224 (setq next `(lambda ()
225 (setq next ',next)
226 ',elt)))
227 ((vectorp def)
228 ;; A user-defined key.
229 (if (funcall (aref def 0) elt) ;Call its function.
230 ;; The function has eaten this object.
231 (setq actions (1+ actions))
232 ;; Regurgitated; try again.
233 (setq next `(lambda ()
234 (setq next ',next)
235 ',elt))))
236 ((and (consp char)
237 (eq (car char) 'switch-frame))
238 ;; switch-frame event. Put it off until we're done.
239 (setq delayed-switch-frame char)
240 (setq next `(lambda ()
241 (setq next ',next)
242 ',elt)))
243 (t
244 ;; Random char.
245 (message "Type %s for help."
246 (key-description (vector help-char)))
247 (beep)
248 (sit-for 1)
249 (setq next `(lambda ()
250 (setq next ',next)
251 ',elt)))))
252 (prompt
253 (funcall actor elt)
254 (setq actions (1+ actions))))))
255 (if delayed-switch-frame
256 (setq unread-command-events
257 (cons delayed-switch-frame unread-command-events))))
258 ;; Clear the last prompt from the minibuffer.
259 (let ((message-log-max nil))
260 (message ""))
261 ;; Return the number of actions that were taken.
262 actions))
263
264;;; map-ynp.el ends here
diff --git a/lisp/emacs-lisp/regi.el b/lisp/emacs-lisp/regi.el
new file mode 100644
index 00000000000..c0cae5b5771
--- /dev/null
+++ b/lisp/emacs-lisp/regi.el
@@ -0,0 +1,258 @@
1;;; regi.el --- REGular expression Interpreting engine
2
3;; Copyright (C) 1993 Free Software Foundation, Inc.
4
5;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
6;; Maintainer: bwarsaw@cen.com
7;; Created: 24-Feb-1993
8;; Version: 1.8
9;; Last Modified: 1993/06/01 21:33:00
10;; Keywords: extensions, matching
11
12;; This file is part of GNU Emacs.
13
14;; GNU Emacs is free software; you can redistribute it and/or modify
15;; it under the terms of the GNU General Public License as published by
16;; the Free Software Foundation; either version 2, or (at your option)
17;; any later version.
18
19;; GNU Emacs is distributed in the hope that it will be useful,
20;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;; GNU General Public License for more details.
23
24;; You should have received a copy of the GNU General Public License
25;; along with GNU Emacs; see the file COPYING. If not, write to the
26;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27;; Boston, MA 02111-1307, USA.
28
29;;; Commentary:
30
31;;; Code:
32
33
34(defun regi-pos (&optional position col-p)
35 "Return the character position at various buffer positions.
36Optional POSITION can be one of the following symbols:
37
38`bol' == beginning of line
39`boi' == beginning of indentation
40`eol' == end of line [default]
41`bonl' == beginning of next line
42`bopl' == beginning of previous line
43
44Optional COL-P non-nil returns `current-column' instead of character position."
45 (save-excursion
46 (cond
47 ((eq position 'bol) (beginning-of-line))
48 ((eq position 'boi) (back-to-indentation))
49 ((eq position 'bonl) (forward-line 1))
50 ((eq position 'bopl) (forward-line -1))
51 (t (end-of-line)))
52 (if col-p (current-column) (point))))
53
54(defun regi-mapcar (predlist func &optional negate-p case-fold-search-p)
55 "Build a regi frame where each element of PREDLIST appears exactly once.
56The frame contains elements where each member of PREDLIST is
57associated with FUNC, and optionally NEGATE-P and CASE-FOLD-SEARCH-P."
58 (let (frame tail)
59 (if (or negate-p case-fold-search-p)
60 (setq tail (list negate-p)))
61 (if case-fold-search-p
62 (setq tail (append tail (list case-fold-search-p))))
63 (while predlist
64 (let ((element (list (car predlist) func)))
65 (if tail
66 (setq element (append element tail)))
67 (setq frame (append frame (list element))
68 predlist (cdr predlist))
69 ))
70 frame))
71
72
73(defun regi-interpret (frame &optional start end)
74 "Interpret the regi frame FRAME.
75If optional START and END are supplied, they indicate the region of
76interest, and the buffer is narrowed to the beginning of the line
77containing START, and beginning of the line after the line containing
78END. Otherwise, point and mark are not set and processing continues
79until your FUNC returns the `abort' symbol (see below). Beware! Not
80supplying a START or END could put you in an infinite loop.
81
82A regi frame is a list of entries of the form:
83
84 (PRED FUNC [NEGATE-P [CASE-FOLD-SEARCH]])
85
86PRED is a predicate against which each line in the region is tested,
87and if a match occurs, FUNC is `eval'd. Point is then moved to the
88beginning of the next line, the frame is reset and checking continues.
89If a match doesn't occur, the next entry is checked against the
90current line until all entries in the frame are checked. At this
91point, if no match occurred, the frame is reset and point is moved to
92the next line. Checking continues until every line in the region is
93checked. Optional NEGATE-P inverts the result of PRED before FUNC is
94called and `case-fold-search' is bound to the optional value of
95CASE-FOLD-SEARCH for the PRED check.
96
97PRED can be a string, variable, function or one of the following
98symbols: t, nil, `begin', `end', and `every'. If PRED is a string, or
99a variable or list that evaluates to a string, it is interpreted as a
100regular expression and is matched against the current line (from the
101beginning) using `looking-at'. If PRED does not evaluate to a string,
102it is interpreted as a binary value (nil or non-nil).
103
104PRED can also be one of the following symbols:
105
106t -- always produces a true outcome
107`begin' -- always executes before anything else
108`end' -- always executes after everything else
109`every' -- execute after frame is matched on a line
110
111Note that NEGATE-P and CASE-FOLD-SEARCH are meaningless if PRED is one
112of these special symbols. Only the first occurrence of each symbol in
113a frame entry is used, the rest are ignored.
114
115Your FUNC can return values which control regi processing. If a list
116is returned from your function, it can contain any combination of the
117following elements:
118
119the symbol `continue'
120 Tells regi to continue processing frame-entries after a match,
121 instead of resetting to the first entry and advancing to the next
122 line, as is the default behavior. When returning this symbol,
123 you must take care not to enter an infinite loop.
124
125the symbol `abort'
126 Tells regi to terminate processing this frame. any end
127 frame-entry is still processed.
128
129the list `(frame . NEWFRAME)'
130 Tells regi to use NEWFRAME as its current frame. In other words,
131 your FUNC can modify the executing regi frame on the fly.
132
133the list `(step . STEP)'
134 Tells regi to move STEP number of lines forward during normal
135 processing. By default, regi moves forward 1 line. STEP can be
136 negative, but be careful of infinite loops.
137
138You should usually take care to explicitly return nil from your
139function if no action is to take place. Your FUNC will always be
140`eval'ed. The following variables will be temporarily bound to some
141useful information:
142
143`curline'
144 the current line in the buffer, as a string
145
146`curframe'
147 the full, current frame being executed
148
149`curentry'
150 the current frame entry being executed."
151
152 (save-excursion
153 (save-restriction
154 (let (begin-tag end-tag every-tag current-frame working-frame donep)
155
156 ;; set up the narrowed region
157 (and start
158 end
159 (let* ((tstart start)
160 (start (min start end))
161 (end (max start end)))
162 (narrow-to-region
163 (progn (goto-char end) (regi-pos 'bonl))
164 (progn (goto-char start) (regi-pos 'bol)))))
165
166 ;; lets find the special tags and remove them from the working
167 ;; frame. note that only the last special tag is used.
168 (mapcar
169 (function
170 (lambda (entry)
171 (let ((pred (car entry))
172 (func (car (cdr entry))))
173 (cond
174 ((eq pred 'begin) (setq begin-tag func))
175 ((eq pred 'end) (setq end-tag func))
176 ((eq pred 'every) (setq every-tag func))
177 (t
178 (setq working-frame (append working-frame (list entry))))
179 ) ; end-cond
180 )))
181 frame) ; end-mapcar
182
183 ;; execute the begin entry
184 (eval begin-tag)
185
186 ;; now process the frame
187 (setq current-frame working-frame)
188 (while (not (or donep (eobp)))
189 (let* ((entry (car current-frame))
190 (pred (nth 0 entry))
191 (func (nth 1 entry))
192 (negate-p (nth 2 entry))
193 (case-fold-search (nth 3 entry))
194 match-p)
195 (catch 'regi-throw-top
196 (cond
197 ;; we are finished processing the frame for this line
198 ((not current-frame)
199 (setq current-frame working-frame) ;reset frame
200 (forward-line 1)
201 (throw 'regi-throw-top t))
202 ;; see if predicate evaluates to a string
203 ((stringp (setq match-p (eval pred)))
204 (setq match-p (looking-at match-p)))
205 ) ; end-cond
206
207 ;; now that we've done the initial matching, check for
208 ;; negation of match
209 (and negate-p
210 (setq match-p (not match-p)))
211
212 ;; if the line matched, package up the argument list and
213 ;; funcall the FUNC
214 (if match-p
215 (let* ((curline (buffer-substring
216 (regi-pos 'bol)
217 (regi-pos 'eol)))
218 (curframe current-frame)
219 (curentry entry)
220 (result (eval func))
221 (step (or (cdr (assq 'step result)) 1))
222 )
223 ;; changing frame on the fly?
224 (if (assq 'frame result)
225 (setq working-frame (cdr (assq 'frame result))))
226
227 ;; continue processing current frame?
228 (if (memq 'continue result)
229 (setq current-frame (cdr current-frame))
230 (forward-line step)
231 (setq current-frame working-frame))
232
233 ;; abort current frame?
234 (if (memq 'abort result)
235 (progn
236 (setq donep t)
237 (throw 'regi-throw-top t)))
238 ) ; end-let
239
240 ;; else if no match occurred, then process the next
241 ;; frame-entry on the current line
242 (setq current-frame (cdr current-frame))
243
244 ) ; end-if match-p
245 ) ; end catch
246 ) ; end let
247
248 ;; after every cycle, evaluate every-tag
249 (eval every-tag)
250 ) ; end-while
251
252 ;; now process the end entry
253 (eval end-tag)))))
254
255
256(provide 'regi)
257
258;;; regi.el ends here
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
new file mode 100644
index 00000000000..b7db0d01dc1
--- /dev/null
+++ b/lisp/emacs-lisp/timer.el
@@ -0,0 +1,479 @@
1;;; timer.el --- run a function with args at some time in future
2
3;; Copyright (C) 1996 Free Software Foundation, Inc.
4
5;; Maintainer: FSF
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to the
21;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;; Boston, MA 02111-1307, USA.
23
24;;; Commentary:
25
26;; This package gives you the capability to run Emacs Lisp commands at
27;; specified times in the future, either as one-shots or periodically.
28
29;;; Code:
30
31;; Layout of a timer vector:
32;; [triggered-p high-seconds low-seconds usecs repeat-delay
33;; function args idle-delay]
34
35(defun timer-create ()
36 "Create a timer object."
37 (let ((timer (make-vector 8 nil)))
38 (aset timer 0 t)
39 timer))
40
41(defun timerp (object)
42 "Return t if OBJECT is a timer."
43 (and (vectorp object) (= (length object) 8)))
44
45(defun timer-set-time (timer time &optional delta)
46 "Set the trigger time of TIMER to TIME.
47TIME must be in the internal format returned by, e.g., `current-time'.
48If optional third argument DELTA is a positive number, make the timer
49fire repeatedly that many seconds apart."
50 (or (timerp timer)
51 (error "Invalid timer"))
52 (aset timer 1 (car time))
53 (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time)))
54 (aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time)))
55 (nth 2 time))
56 0))
57 (aset timer 4 (and (numberp delta) (> delta 0) delta))
58 timer)
59
60(defun timer-set-idle-time (timer secs &optional repeat)
61 "Set the trigger idle time of TIMER to SECS.
62If optional third argument REPEAT is non-nil, make the timer
63fire each time Emacs is idle for that many seconds."
64 (or (timerp timer)
65 (error "Invalid timer"))
66 (aset timer 1 0)
67 (aset timer 2 0)
68 (aset timer 3 0)
69 (timer-inc-time timer secs)
70 (aset timer 4 repeat)
71 timer)
72
73(defun timer-next-integral-multiple-of-time (time secs)
74 "Yield the next value after TIME that is an integral multiple of SECS.
75More precisely, the next value, after TIME, that is an integral multiple
76of SECS seconds since the epoch. SECS may be a fraction."
77 (let ((time-base (ash 1 16)))
78 (if (fboundp 'atan)
79 ;; Use floating point, taking care to not lose precision.
80 (let* ((float-time-base (float time-base))
81 (million 1000000.0)
82 (time-usec (+ (* million
83 (+ (* float-time-base (nth 0 time))
84 (nth 1 time)))
85 (nth 2 time)))
86 (secs-usec (* million secs))
87 (mod-usec (mod time-usec secs-usec))
88 (next-usec (+ (- time-usec mod-usec) secs-usec))
89 (time-base-million (* float-time-base million)))
90 (list (floor next-usec time-base-million)
91 (floor (mod next-usec time-base-million) million)
92 (floor (mod next-usec million))))
93 ;; Floating point is not supported.
94 ;; Use integer arithmetic, avoiding overflow if possible.
95 (let* ((mod-sec (mod (+ (* (mod time-base secs)
96 (mod (nth 0 time) secs))
97 (nth 1 time))
98 secs))
99 (next-1-sec (+ (- (nth 1 time) mod-sec) secs)))
100 (list (+ (nth 0 time) (floor next-1-sec time-base))
101 (mod next-1-sec time-base)
102 0)))))
103
104(defun timer-relative-time (time secs &optional usecs)
105 "Advance TIME by SECS seconds and optionally USECS microseconds.
106SECS may be a fraction."
107 (let ((high (car time))
108 (low (if (consp (cdr time)) (nth 1 time) (cdr time)))
109 (micro (if (numberp (car-safe (cdr-safe (cdr time))))
110 (nth 2 time)
111 0)))
112 ;; Add
113 (if usecs (setq micro (+ micro usecs)))
114 (if (floatp secs)
115 (setq micro (+ micro (floor (* 1000000 (- secs (floor secs)))))))
116 (setq low (+ low (floor secs)))
117
118 ;; Normalize
119 ;; `/' rounds towards zero while `mod' returns a positive number,
120 ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))).
121 (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0)))
122 (setq micro (mod micro 1000000))
123 (setq high (+ high (/ low 65536) (if (< low 0) -1 0)))
124 (setq low (logand low 65535))
125
126 (list high low (and (/= micro 0) micro))))
127
128(defun timer-inc-time (timer secs &optional usecs)
129 "Increment the time set in TIMER by SECS seconds and USECS microseconds.
130SECS may be a fraction. If USECS is omitted, that means it is zero."
131 (let ((time (timer-relative-time
132 (list (aref timer 1) (aref timer 2) (aref timer 3))
133 secs
134 usecs)))
135 (aset timer 1 (nth 0 time))
136 (aset timer 2 (nth 1 time))
137 (aset timer 3 (or (nth 2 time) 0))))
138
139(defun timer-set-time-with-usecs (timer time usecs &optional delta)
140 "Set the trigger time of TIMER to TIME plus USECS.
141TIME must be in the internal format returned by, e.g., `current-time'.
142The microsecond count from TIME is ignored, and USECS is used instead.
143If optional fourth argument DELTA is a positive number, make the timer
144fire repeatedly that many seconds apart."
145 (or (timerp timer)
146 (error "Invalid timer"))
147 (aset timer 1 (nth 0 time))
148 (aset timer 2 (nth 1 time))
149 (aset timer 3 usecs)
150 (aset timer 4 (and (numberp delta) (> delta 0) delta))
151 timer)
152(make-obsolete 'timer-set-time-with-usecs
153 "use `timer-set-time' and `timer-inc-time' instead."
154 "21.4")
155
156(defun timer-set-function (timer function &optional args)
157 "Make TIMER call FUNCTION with optional ARGS when triggering."
158 (or (timerp timer)
159 (error "Invalid timer"))
160 (aset timer 5 function)
161 (aset timer 6 args)
162 timer)
163
164(defun timer-activate (timer)
165 "Put TIMER on the list of active timers."
166 (if (and (timerp timer)
167 (integerp (aref timer 1))
168 (integerp (aref timer 2))
169 (integerp (aref timer 3))
170 (aref timer 5))
171 (let ((timers timer-list)
172 last)
173 ;; Skip all timers to trigger before the new one.
174 (while (and timers
175 (or (> (aref timer 1) (aref (car timers) 1))
176 (and (= (aref timer 1) (aref (car timers) 1))
177 (> (aref timer 2) (aref (car timers) 2)))
178 (and (= (aref timer 1) (aref (car timers) 1))
179 (= (aref timer 2) (aref (car timers) 2))
180 (> (aref timer 3) (aref (car timers) 3)))))
181 (setq last timers
182 timers (cdr timers)))
183 ;; Insert new timer after last which possibly means in front of queue.
184 (if last
185 (setcdr last (cons timer timers))
186 (setq timer-list (cons timer timers)))
187 (aset timer 0 nil)
188 (aset timer 7 nil)
189 nil)
190 (error "Invalid or uninitialized timer")))
191
192(defun timer-activate-when-idle (timer &optional dont-wait)
193 "Arrange to activate TIMER whenever Emacs is next idle.
194If optional argument DONT-WAIT is non-nil, then enable the
195timer to activate immediately, or at the right time, if Emacs
196is already idle."
197 (if (and (timerp timer)
198 (integerp (aref timer 1))
199 (integerp (aref timer 2))
200 (integerp (aref timer 3))
201 (aref timer 5))
202 (let ((timers timer-idle-list)
203 last)
204 ;; Skip all timers to trigger before the new one.
205 (while (and timers
206 (or (> (aref timer 1) (aref (car timers) 1))
207 (and (= (aref timer 1) (aref (car timers) 1))
208 (> (aref timer 2) (aref (car timers) 2)))
209 (and (= (aref timer 1) (aref (car timers) 1))
210 (= (aref timer 2) (aref (car timers) 2))
211 (> (aref timer 3) (aref (car timers) 3)))))
212 (setq last timers
213 timers (cdr timers)))
214 ;; Insert new timer after last which possibly means in front of queue.
215 (if last
216 (setcdr last (cons timer timers))
217 (setq timer-idle-list (cons timer timers)))
218 (aset timer 0 (not dont-wait))
219 (aset timer 7 t)
220 nil)
221 (error "Invalid or uninitialized timer")))
222
223;;;###autoload
224(defalias 'disable-timeout 'cancel-timer)
225;;;###autoload
226(defun cancel-timer (timer)
227 "Remove TIMER from the list of active timers."
228 (or (timerp timer)
229 (error "Invalid timer"))
230 (setq timer-list (delq timer timer-list))
231 (setq timer-idle-list (delq timer timer-idle-list))
232 nil)
233
234;;;###autoload
235(defun cancel-function-timers (function)
236 "Cancel all timers scheduled by `run-at-time' which would run FUNCTION."
237 (interactive "aCancel timers of function: ")
238 (let ((tail timer-list))
239 (while tail
240 (if (eq (aref (car tail) 5) function)
241 (setq timer-list (delq (car tail) timer-list)))
242 (setq tail (cdr tail))))
243 (let ((tail timer-idle-list))
244 (while tail
245 (if (eq (aref (car tail) 5) function)
246 (setq timer-idle-list (delq (car tail) timer-idle-list)))
247 (setq tail (cdr tail)))))
248
249;; Record the last few events, for debugging.
250(defvar timer-event-last-2 nil)
251(defvar timer-event-last-1 nil)
252(defvar timer-event-last nil)
253
254(defvar timer-max-repeats 10
255 "*Maximum number of times to repeat a timer, if real time jumps.")
256
257(defun timer-until (timer time)
258 "Calculate number of seconds from when TIMER will run, until TIME.
259TIMER is a timer, and stands for the time when its next repeat is scheduled.
260TIME is a time-list."
261 (let ((high (- (car time) (aref timer 1)))
262 (low (- (nth 1 time) (aref timer 2))))
263 (+ low (* high 65536))))
264
265(defun timer-event-handler (timer)
266 "Call the handler for the timer TIMER.
267This function is called, by name, directly by the C code."
268 (setq timer-event-last-2 timer-event-last-1)
269 (setq timer-event-last-1 timer-event-last)
270 (setq timer-event-last timer)
271 (let ((inhibit-quit t))
272 (if (timerp timer)
273 (progn
274 ;; Delete from queue.
275 (cancel-timer timer)
276 ;; Re-schedule if requested.
277 (if (aref timer 4)
278 (if (aref timer 7)
279 (timer-activate-when-idle timer)
280 (timer-inc-time timer (aref timer 4) 0)
281 ;; If real time has jumped forward,
282 ;; perhaps because Emacs was suspended for a long time,
283 ;; limit how many times things get repeated.
284 (if (and (numberp timer-max-repeats)
285 (< 0 (timer-until timer (current-time))))
286 (let ((repeats (/ (timer-until timer (current-time))
287 (aref timer 4))))
288 (if (> repeats timer-max-repeats)
289 (timer-inc-time timer (* (aref timer 4) repeats)))))
290 (timer-activate timer)))
291 ;; Run handler.
292 ;; We do this after rescheduling so that the handler function
293 ;; can cancel its own timer successfully with cancel-timer.
294 (condition-case nil
295 (apply (aref timer 5) (aref timer 6))
296 (error nil)))
297 (error "Bogus timer event"))))
298
299;; This function is incompatible with the one in levents.el.
300(defun timeout-event-p (event)
301 "Non-nil if EVENT is a timeout event."
302 (and (listp event) (eq (car event) 'timer-event)))
303
304;;;###autoload
305(defun run-at-time (time repeat function &rest args)
306 "Perform an action at time TIME.
307Repeat the action every REPEAT seconds, if REPEAT is non-nil.
308TIME should be a string like \"11:23pm\", nil meaning now, a number of seconds
309from now, a value from `current-time', or t (with non-nil REPEAT)
310meaning the next integral multiple of REPEAT.
311REPEAT may be an integer or floating point number.
312The action is to call FUNCTION with arguments ARGS.
313
314This function returns a timer object which you can use in `cancel-timer'."
315 (interactive "sRun at time: \nNRepeat interval: \naFunction: ")
316
317 (or (null repeat)
318 (and (numberp repeat) (< 0 repeat))
319 (error "Invalid repetition interval"))
320
321 ;; Special case: nil means "now" and is useful when repeating.
322 (if (null time)
323 (setq time (current-time)))
324
325 ;; Special case: t means the next integral multiple of REPEAT.
326 (if (and (eq time t) repeat)
327 (setq time (timer-next-integral-multiple-of-time (current-time) repeat)))
328
329 ;; Handle numbers as relative times in seconds.
330 (if (numberp time)
331 (setq time (timer-relative-time (current-time) time)))
332
333 ;; Handle relative times like "2 hours and 35 minutes"
334 (if (stringp time)
335 (let ((secs (timer-duration time)))
336 (if secs
337 (setq time (timer-relative-time (current-time) secs)))))
338
339 ;; Handle "11:23pm" and the like. Interpret it as meaning today
340 ;; which admittedly is rather stupid if we have passed that time
341 ;; already. (Though only Emacs hackers hack Emacs at that time.)
342 (if (stringp time)
343 (progn
344 (require 'diary-lib)
345 (let ((hhmm (diary-entry-time time))
346 (now (decode-time)))
347 (if (>= hhmm 0)
348 (setq time
349 (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now)
350 (nth 4 now) (nth 5 now) (nth 8 now)))))))
351
352 (or (consp time)
353 (error "Invalid time format"))
354
355 (let ((timer (timer-create)))
356 (timer-set-time timer time repeat)
357 (timer-set-function timer function args)
358 (timer-activate timer)
359 timer))
360
361;;;###autoload
362(defun run-with-timer (secs repeat function &rest args)
363 "Perform an action after a delay of SECS seconds.
364Repeat the action every REPEAT seconds, if REPEAT is non-nil.
365SECS and REPEAT may be integers or floating point numbers.
366The action is to call FUNCTION with arguments ARGS.
367
368This function returns a timer object which you can use in `cancel-timer'."
369 (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ")
370 (apply 'run-at-time secs repeat function args))
371
372;;;###autoload
373(defun add-timeout (secs function object &optional repeat)
374 "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT.
375If REPEAT is non-nil, repeat the timer every REPEAT seconds.
376This function is for compatibility; see also `run-with-timer'."
377 (run-with-timer secs repeat function object))
378
379;;;###autoload
380(defun run-with-idle-timer (secs repeat function &rest args)
381 "Perform an action the next time Emacs is idle for SECS seconds.
382The action is to call FUNCTION with arguments ARGS.
383SECS may be an integer or a floating point number.
384
385If REPEAT is non-nil, do the action each time Emacs has been idle for
386exactly SECS seconds (that is, only once for each time Emacs becomes idle).
387
388This function returns a timer object which you can use in `cancel-timer'."
389 (interactive
390 (list (read-from-minibuffer "Run after idle (seconds): " nil nil t)
391 (y-or-n-p "Repeat each time Emacs is idle? ")
392 (intern (completing-read "Function: " obarray 'fboundp t))))
393 (let ((timer (timer-create)))
394 (timer-set-function timer function args)
395 (timer-set-idle-time timer secs repeat)
396 (timer-activate-when-idle timer)
397 timer))
398
399(defun with-timeout-handler (tag)
400 (throw tag 'timeout))
401
402;;;###autoload (put 'with-timeout 'lisp-indent-function 1)
403
404;;;###autoload
405(defmacro with-timeout (list &rest body)
406 "Run BODY, but if it doesn't finish in SECONDS seconds, give up.
407If we give up, we run the TIMEOUT-FORMS and return the value of the last one.
408The call should look like:
409 (with-timeout (SECONDS TIMEOUT-FORMS...) BODY...)
410The timeout is checked whenever Emacs waits for some kind of external
411event \(such as keyboard input, input from subprocesses, or a certain time);
412if the program loops without waiting in any way, the timeout will not
413be detected."
414 (let ((seconds (car list))
415 (timeout-forms (cdr list)))
416 `(let ((with-timeout-tag (cons nil nil))
417 with-timeout-value with-timeout-timer)
418 (if (catch with-timeout-tag
419 (progn
420 (setq with-timeout-timer
421 (run-with-timer ,seconds nil
422 'with-timeout-handler
423 with-timeout-tag))
424 (setq with-timeout-value (progn . ,body))
425 nil))
426 (progn . ,timeout-forms)
427 (cancel-timer with-timeout-timer)
428 with-timeout-value))))
429
430(defun y-or-n-p-with-timeout (prompt seconds default-value)
431 "Like (y-or-n-p PROMPT), with a timeout.
432If the user does not answer after SECONDS seconds, return DEFAULT-VALUE."
433 (with-timeout (seconds default-value)
434 (y-or-n-p prompt)))
435
436(defvar timer-duration-words
437 (list (cons "microsec" 0.000001)
438 (cons "microsecond" 0.000001)
439 (cons "millisec" 0.001)
440 (cons "millisecond" 0.001)
441 (cons "sec" 1)
442 (cons "second" 1)
443 (cons "min" 60)
444 (cons "minute" 60)
445 (cons "hour" (* 60 60))
446 (cons "day" (* 24 60 60))
447 (cons "week" (* 7 24 60 60))
448 (cons "fortnight" (* 14 24 60 60))
449 (cons "month" (* 30 24 60 60)) ; Approximation
450 (cons "year" (* 365.25 24 60 60)) ; Approximation
451 )
452 "Alist mapping temporal words to durations in seconds")
453
454(defun timer-duration (string)
455 "Return number of seconds specified by STRING, or nil if parsing fails."
456 (let ((secs 0)
457 (start 0)
458 (case-fold-search t))
459 (while (string-match
460 "[ \t]*\\([0-9.]+\\)?[ \t]*\\([a-z]+[a-rt-z]\\)s?[ \t]*"
461 string start)
462 (let ((count (if (match-beginning 1)
463 (string-to-number (match-string 1 string))
464 1))
465 (itemsize (cdr (assoc (match-string 2 string)
466 timer-duration-words))))
467 (if itemsize
468 (setq start (match-end 0)
469 secs (+ secs (* count itemsize)))
470 (setq secs nil
471 start (length string)))))
472 (if (= start (length string))
473 secs
474 (if (string-match "\\`[0-9.]+\\'" string)
475 (string-to-number string)))))
476
477(provide 'timer)
478
479;;; timer.el ends here
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
new file mode 100644
index 00000000000..4d0354236a8
--- /dev/null
+++ b/lisp/emacs-lisp/warnings.el
@@ -0,0 +1,311 @@
1;;; warnings.el --- log and display warnings
2
3;; Copyright (C) 2002 Free Software Foundation, Inc.
4
5;; Maintainer: FSF
6;; Keywords: internal
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;; This file implements the entry points `warn', `lwarn'
28;; and `display-warnings'.
29
30;;; Code:
31
32(defgroup warnings nil
33 "Log and display warnings."
34 :version "21.4"
35 :group 'lisp)
36
37(defvar warning-levels
38 '((:emergency "Emergency%s: " ding)
39 (:error "Error%s: ")
40 (:warning "Warning%s: ")
41 (:debug "Debug%s: "))
42 "List of severity level definitions for `display-warning'.
43Each element looks like (LEVEL STRING FUNCTION) and
44defines LEVEL as a severity level. STRING specifies the
45description of this level. STRING should use `%s' to
46specify where to put the warning group information,
47or it can omit the `%s' so as not to include that information.
48
49The optional FUNCTION, if non-nil, is a function to call
50with no arguments, to get the user's attention.
51
52The standard levels are :emergency, :error, :warning and :debug.
53See `display-warning' for documentation of their meanings.
54Level :debug is ignored by default (see `warning-minimum-level').")
55(put 'warning-levels 'risky-local-variable t)
56
57;; These are for compatibility with XEmacs.
58;; I don't think there is any chance of designing meaningful criteria
59;; to distinguish so many levels.
60(defvar warning-level-aliases
61 '((emergency . :emergency)
62 (error . :error)
63 (warning . :warning)
64 (notice . :warning)
65 (info . :warning)
66 (critical . :emergency)
67 (alarm . :emergency))
68 "Alist of aliases for severity levels for `display-warning'.
69Each element looks like (ALIAS . LEVEL) and defines
70ALIAS as equivalent to LEVEL. LEVEL must be defined in `warning-levels';
71it may not itself be an alias.")
72
73(defcustom warning-minimum-level :warning
74 "Minimum severity level for displaying the warning buffer.
75If a warning's severity level is lower than this,
76the warning is logged in the warnings buffer, but the buffer
77is not immediately displayed. See also `warning-minimum-log-level'."
78 :group 'warnings
79 :type '(choice (const :emergency) (const :error) (const :warning))
80 :version "21.4")
81(defvaralias 'display-warning-minimum-level 'warning-minimum-level)
82
83(defcustom warning-minimum-log-level :warning
84 "Minimum severity level for logging a warning.
85If a warning severity level is lower than this,
86the warning is completely ignored."
87 :group 'warnings
88 :type '(choice (const :emergency) (const :error) (const :warning))
89 :version "21.4")
90(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level)
91
92(defcustom warning-suppress-log-types nil
93 "List of warning types that should not be logged.
94If any element of this list matches the GROUP argument to `display-warning',
95the warning is completely ignored.
96The element must match the first elements of GROUP.
97Thus, (foo bar) as an element matches (foo bar)
98or (foo bar ANYTHING...) as GROUP.
99If GROUP is a symbol FOO, that is equivalent to the list (FOO),
100so only the element (FOO) will match it."
101 :group 'warnings
102 :type '(repeat (repeat symbol))
103 :version "21.4")
104
105(defcustom warning-suppress-types nil
106 "Custom groups for warnings not to display immediately.
107If any element of this list matches the GROUP argument to `display-warning',
108the warning is logged nonetheless, but the warnings buffer is
109not immediately displayed.
110The element must match an initial segment of the list GROUP.
111Thus, (foo bar) as an element matches (foo bar)
112or (foo bar ANYTHING...) as GROUP.
113If GROUP is a symbol FOO, that is equivalent to the list (FOO),
114so only the element (FOO) will match it.
115See also `warning-suppress-log-types'."
116 :group 'warnings
117 :type '(repeat (repeat symbol))
118 :version "21.4")
119
120;;; The autoload cookie is so that programs can bind this variable
121;;; safely, testing the existing value, before they call one of the
122;;; warnings functions.
123;;;###autoload
124(defvar warning-prefix-function nil
125 "Function to generate warning prefixes.
126This function, if non-nil, is called with two arguments,
127the severity level and its entry in `warning-levels',
128and should return the entry that should actually be used.
129The warnings buffer is current when this function is called
130and the function can insert text in it. This text becomes
131the beginning of the warning.")
132
133;;; The autoload cookie is so that programs can bind this variable
134;;; safely, testing the existing value, before they call one of the
135;;; warnings functions.
136;;;###autoload
137(defvar warning-series nil
138 "Non-nil means treat multiple `display-warning' calls as a series.
139A marker indicates a position in the warnings buffer
140which is the start of the current series; it means that
141additional warnings in the same buffer should not move point.
142t means the next warning begins a series (and stores a marker here).
143A symbol with a function definition is like t, except
144also call that function before the next warning.")
145(put 'warning-series 'risky-local-variable t)
146
147;;; The autoload cookie is so that programs can bind this variable
148;;; safely, testing the existing value, before they call one of the
149;;; warnings functions.
150;;;###autoload
151(defvar warning-fill-prefix nil
152 "Non-nil means fill each warning text using this string as `fill-prefix'.")
153
154;;; The autoload cookie is so that programs can bind this variable
155;;; safely, testing the existing value, before they call one of the
156;;; warnings functions.
157;;;###autoload
158(defvar warning-group-format " (%s)"
159 "Format for displaying the warning group in the warning message.
160The result of formatting the group this way gets included in the
161message under the control of the string in `warning-levels'.")
162
163(defun warning-numeric-level (level)
164 "Return a numeric measure of the warning severity level LEVEL."
165 (let* ((elt (assq level warning-levels))
166 (link (memq elt warning-levels)))
167 (length link)))
168
169(defun warning-suppress-p (group suppress-list)
170 "Non-nil if a warning with group GROUP should be suppressed.
171SUPPRESS-LIST is the list of kinds of warnings to suppress."
172 (let (some-match)
173 (dolist (elt suppress-list)
174 (if (symbolp group)
175 ;; If GROUP is a symbol, the ELT must be (GROUP).
176 (if (and (consp elt)
177 (eq (car elt) group)
178 (null (cdr elt)))
179 (setq some-match t))
180 ;; If GROUP is a list, ELT must match it or some initial segment of it.
181 (let ((tem1 group)
182 (tem2 elt)
183 (match t))
184 ;; Check elements of ELT until we run out of them.
185 (while tem2
186 (if (not (equal (car tem1) (car tem2)))
187 (setq match nil))
188 (setq tem1 (cdr tem1)
189 tem2 (cdr tem2)))
190 ;; If ELT is an initial segment of GROUP, MATCH is t now.
191 ;; So set SOME-MATCH.
192 (if match
193 (setq some-match t)))))
194 ;; If some element of SUPPRESS-LIST matched,
195 ;; we return t.
196 some-match))
197
198;;;###autoload
199(defun display-warning (group message &optional level buffer-name)
200 "Display a warning message, MESSAGE.
201GROUP should be a custom group name (a symbol),
202or else a list of symbols whose first element is a custom group name.
203\(The rest of the symbols represent subcategories, for warning purposes
204only, and you can use whatever symbols you like.)
205
206LEVEL should be either :warning, :error, or :emergency.
207:emergency -- a problem that will seriously impair Emacs operation soon
208 if you do not attend to it promptly.
209:error -- data or circumstances that are inherently wrong.
210:warning -- data or circumstances that are not inherently wrong,
211 but raise suspicion of a possible problem.
212:debug -- info for debugging only.
213
214BUFFER-NAME, if specified, is the name of the buffer for logging the
215warning. By default, it is `*Warnings*'.
216
217See the `warnings' custom group for user customization features.
218
219See also `warning-series', `warning-prefix-function' and
220`warning-fill-prefix' for additional programming features."
221 (unless level
222 (setq level :warning))
223 (if (assq level warning-level-aliases)
224 (setq level (cdr (assq level warning-level-aliases))))
225 (or (< (warning-numeric-level level)
226 (warning-numeric-level warning-minimum-log-level))
227 (warning-suppress-p group warning-suppress-log-types)
228 (let* ((groupname (if (consp group) (car group) group))
229 (buffer (get-buffer-create (or buffer-name "*Warnings*")))
230 (level-info (assq level warning-levels))
231 start end)
232 (with-current-buffer buffer
233 (goto-char (point-max))
234 (when (and warning-series (symbolp warning-series))
235 (setq warning-series
236 (prog1 (point-marker)
237 (unless (eq warning-series t)
238 (funcall warning-series)))))
239 (unless (bolp)
240 (newline))
241 (setq start (point))
242 (if warning-prefix-function
243 (setq level-info (funcall warning-prefix-function
244 level level-info)))
245 (insert (format (nth 1 level-info)
246 (format warning-group-format groupname))
247 message)
248 (newline)
249 (when (and warning-fill-prefix (not (string-match "\n" message)))
250 (let ((fill-prefix warning-fill-prefix)
251 (fill-column 78))
252 (fill-region start (point))))
253 (setq end (point))
254 (when (and (markerp warning-series)
255 (eq (marker-buffer warning-series) buffer))
256 (goto-char warning-series)))
257 (if (nth 2 level-info)
258 (funcall (nth 2 level-info)))
259 (if noninteractive
260 ;; Noninteractively, take the text we inserted
261 ;; in the warnings buffer and print it.
262 ;; Do this unconditionally, since there is no way
263 ;; to view logged messages unless we output them.
264 (with-current-buffer buffer
265 (save-excursion
266 ;; Don't include the final newline in the arg
267 ;; to `message', because it adds a newline.
268 (goto-char end)
269 (if (bolp)
270 (forward-char -1))
271 (message "%s" (buffer-substring start (point)))))
272 ;; Interactively, decide whether the warning merits
273 ;; immediate display.
274 (or (< (warning-numeric-level level)
275 (warning-numeric-level warning-minimum-level))
276 (warning-suppress-p group warning-suppress-types)
277 (let ((window (display-buffer buffer)))
278 (when (and (markerp warning-series)
279 (eq (marker-buffer warning-series) buffer))
280 (set-window-start window warning-series))
281 (sit-for 0)))))))
282
283;;;###autoload
284(defun lwarn (group level message &rest args)
285 "Display a warning message made from (format MESSAGE ARGS...).
286Aside from generating the message with `format',
287this is equivalent to `display-warning'.
288
289GROUP should be a custom group name (a symbol).
290or else a list of symbols whose first element is a custom group name.
291\(The rest of the symbols represent subcategories and
292can be whatever you like.)
293
294LEVEL should be either :warning, :error, or :emergency.
295:emergency -- a problem that will seriously impair Emacs operation soon
296 if you do not attend to it promptly.
297:error -- invalid data or circumstances.
298:warning -- suspicious data or circumstances."
299 (display-warning group (apply 'format message args) level))
300
301;;;###autoload
302(defun warn (message &rest args)
303 "Display a warning message made from (format MESSAGE ARGS...).
304Aside from generating the message with `format',
305this is equivalent to `display-warning', using
306`emacs' as the group and `:warning' as the level."
307 (display-warning 'emacs (apply 'format message args)))
308
309(provide 'warnings)
310
311;;; warnings.el ends here
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
new file mode 100644
index 00000000000..4b1dfca6f5b
--- /dev/null
+++ b/lisp/progmodes/which-func.el
@@ -0,0 +1,256 @@
1;;; which-func.el --- print current function in mode line
2
3;; Copyright (C) 1994, 1997, 1998, 2001, 2003 Free Software Foundation, Inc.
4
5;; Author: Alex Rezinsky <alexr@msil.sps.mot.com>
6;; (doesn't seem to be responsive any more)
7;; Keywords: mode-line, imenu, tools
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
25
26;;; Commentary:
27
28;; This package prints name of function where your current point is
29;; located in mode line. It assumes that you work with imenu package
30;; and imenu--index-alist is up to date.
31
32;; KNOWN BUGS
33;; ----------
34;; Really this package shows not "function where the current point is
35;; located now", but "nearest function which defined above the current
36;; point". So if your current point is located after end of function
37;; FOO but before begin of function BAR, FOO will be displayed in mode
38;; line.
39;; - if two windows display the same buffer, both windows
40;; show the same `which-func' information.
41
42;; TODO LIST
43;; ---------
44;; 1. Dependence on imenu package should be removed. Separate
45;; function determination mechanism should be used to determine the end
46;; of a function as well as the beginning of a function.
47;; 2. This package should be realized with the help of overlay
48;; properties instead of imenu--index-alist variable.
49
50;;; History:
51
52;; THANKS TO
53;; ---------
54;; Per Abrahamsen <abraham@iesd.auc.dk>
55;; Some ideas (inserting in mode-line, using of post-command hook
56;; and toggling this mode) have been borrowed from his package
57;; column.el
58;; Peter Eisenhauer <pipe@fzi.de>
59;; Bug fixing in case nested indexes.
60;; Terry Tateyama <ttt@ursa0.cs.utah.edu>
61;; Suggestion to use find-file-hook for first imenu
62;; index building.
63
64;;; Code:
65
66;; Variables for customization
67;; ---------------------------
68;;
69(defvar which-func-unknown "???"
70 "String to display in the mode line when current function is unknown.")
71
72(defgroup which-func nil
73 "Mode to display the current function name in the modeline."
74 :group 'tools
75 :version "20.3")
76
77(defcustom which-func-modes
78 '(emacs-lisp-mode c-mode c++-mode perl-mode cperl-mode makefile-mode
79 sh-mode fortran-mode f90-mode)
80 "List of major modes for which Which Function mode should be used.
81For other modes it is disabled. If this is equal to t,
82then Which Function mode is enabled in any major mode that supports it."
83 :group 'which-func
84 :type '(choice (const :tag "All modes" t)
85 (repeat (symbol :tag "Major mode"))))
86
87(defcustom which-func-non-auto-modes nil
88 "List of major modes where Which Function mode is inactive till Imenu is used.
89This means that Which Function mode won't really do anything
90until you use Imenu, in these modes. Note that files
91larger than `which-func-maxout' behave in this way too;
92Which Function mode doesn't do anything until you use Imenu."
93 :group 'which-func
94 :type '(repeat (symbol :tag "Major mode")))
95
96(defcustom which-func-maxout 500000
97 "Don't automatically compute the Imenu menu if buffer is this big or bigger.
98Zero means compute the Imenu menu regardless of size."
99 :group 'which-func
100 :type 'integer)
101
102(defcustom which-func-format '("[" which-func-current "]")
103 "Format for displaying the function in the mode line."
104 :group 'which-func
105 :type 'sexp)
106;;;###autoload (put 'which-func-format 'risky-local-variable t)
107
108(defvar which-func-cleanup-function nil
109 "Function to transform a string before displaying it in the mode line.
110The function is called with one argument, the string to display.
111Its return value is displayed in the modeline.
112If nil, no function is called. The default value is nil.
113
114This feature can be useful if Imenu is set up to make more
115detailed entries (e.g., containing the argument list of a function),
116and you want to simplify them for the mode line
117\(e.g., removing the parameter list to just have the function name.)")
118
119;;; Code, nothing to customize below here
120;;; -------------------------------------
121;;;
122(require 'imenu)
123
124(defvar which-func-table (make-hash-table :test 'eq :weakness 'key))
125
126(defconst which-func-current
127 '(:eval (gethash (selected-window) which-func-table which-func-unknown)))
128;;;###autoload (put 'which-func-current 'risky-local-variable t)
129
130(defvar which-func-mode nil
131 "Non-nil means display current function name in mode line.
132This makes a difference only if `which-function-mode' is non-nil.")
133(make-variable-buffer-local 'which-func-mode)
134;;(put 'which-func-mode 'permanent-local t)
135
136(add-hook 'find-file-hook 'which-func-ff-hook t)
137
138(defun which-func-ff-hook ()
139 "File find hook for Which Function mode.
140It creates the Imenu index for the buffer, if necessary."
141 (setq which-func-mode
142 (and which-function-mode
143 (or (eq which-func-modes t)
144 (member major-mode which-func-modes))))
145
146 (condition-case nil
147 (if (and which-func-mode
148 (not (member major-mode which-func-non-auto-modes))
149 (or (null which-func-maxout)
150 (< buffer-saved-size which-func-maxout)
151 (= which-func-maxout 0)))
152 (setq imenu--index-alist
153 (save-excursion (funcall imenu-create-index-function))))
154 (error
155 (setq which-func-mode nil))))
156
157(defun which-func-update ()
158 ;; "Update the Which-Function mode display for all windows."
159 ;; (walk-windows 'which-func-update-1 nil 'visible))
160 (which-func-update-1 (selected-window)))
161
162(defun which-func-update-1 (window)
163 "Update the Which-Function mode display for window WINDOW."
164 (with-selected-window window
165 (when which-func-mode
166 (condition-case info
167 (let ((current (which-function)))
168 (unless (equal current (gethash window which-func-table))
169 (puthash window current which-func-table)
170 (force-mode-line-update)))
171 (error
172 (which-func-mode -1)
173 (error "Error in which-func-update: %s" info))))))
174
175;;;###autoload
176(defalias 'which-func-mode 'which-function-mode)
177
178(defvar which-func-update-timer nil)
179
180;; This is the name people would normally expect.
181;;;###autoload
182(define-minor-mode which-function-mode
183 "Toggle Which Function mode, globally.
184When Which Function mode is enabled, the current function name is
185continuously displayed in the mode line, in certain major modes.
186
187With prefix ARG, turn Which Function mode on iff arg is positive,
188and off otherwise."
189 :global t :group 'which-func
190 (if which-function-mode
191 ;;Turn it on
192 (progn
193 (setq which-func-update-timer
194 (run-with-idle-timer idle-update-delay t 'which-func-update))
195 (dolist (buf (buffer-list))
196 (with-current-buffer buf
197 (setq which-func-mode
198 (or (eq which-func-modes t)
199 (member major-mode which-func-modes))))))
200 ;; Turn it off
201 (cancel-timer which-func-update-timer)
202 (setq which-func-update-timer nil)
203 (dolist (buf (buffer-list))
204 (with-current-buffer buf (setq which-func-mode nil)))))
205
206(defvar which-function-imenu-failed nil
207 "Locally t in a buffer if `imenu--make-index-alist' found nothing there.")
208
209(defun which-function ()
210 "Return current function name based on point.
211Uses `imenu--index-alist' or `add-log-current-defun-function'.
212If no function name is found, return nil."
213 (let (name)
214 ;; If Imenu is loaded, try to make an index alist with it.
215 (when (and (boundp 'imenu--index-alist) (null imenu--index-alist)
216 (null which-function-imenu-failed))
217 (imenu--make-index-alist)
218 (unless imenu--index-alist
219 (make-local-variable 'which-function-imenu-failed)
220 (setq which-function-imenu-failed t)))
221 ;; If we have an index alist, use it.
222 (when (and (boundp 'imenu--index-alist) imenu--index-alist)
223 (let ((alist imenu--index-alist)
224 (minoffset (point-max))
225 offset elem pair mark)
226 (while alist
227 (setq elem (car-safe alist)
228 alist (cdr-safe alist))
229 ;; Elements of alist are either ("name" . marker), or
230 ;; ("submenu" ("name" . marker) ... ).
231 (unless (listp (cdr elem))
232 (setq elem (list elem)))
233 (while elem
234 (setq pair (car elem)
235 elem (cdr elem))
236 (and (consp pair)
237 (number-or-marker-p (setq mark (cdr pair)))
238 (if (>= (setq offset (- (point) mark)) 0)
239 (if (< offset minoffset) ; find the closest item
240 (setq minoffset offset
241 name (car pair)))
242 ;; Entries in order, so can skip all those after point.
243 (setq elem nil)))))))
244 ;; Try using add-log support.
245 (when (and (null name) (boundp 'add-log-current-defun-function)
246 add-log-current-defun-function)
247 (setq name (funcall add-log-current-defun-function)))
248 ;; Filter the name if requested.
249 (when name
250 (if which-func-cleanup-function
251 (funcall which-func-cleanup-function name)
252 name))))
253
254(provide 'which-func)
255
256;;; which-func.el ends here
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
new file mode 100644
index 00000000000..e74cb6b8ba7
--- /dev/null
+++ b/lisp/textmodes/enriched.el
@@ -0,0 +1,474 @@
1;;; enriched.el --- read and save files in text/enriched format
2
3;; Copyright (c) 1994, 1995, 1996, 2002 Free Software Foundation, Inc.
4
5;; Author: Boris Goldowsky <boris@gnu.org>
6;; Keywords: wp, faces
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;; This file implements reading, editing, and saving files with
28;; text-properties such as faces, levels of indentation, and true line
29;; breaks distinguished from newlines just used to fit text into the window.
30
31;; The file format used is the MIME text/enriched format, which is a
32;; standard format defined in internet RFC 1563. All standard annotations
33;; are supported except for <smaller> and <bigger>, which are currently not
34;; possible to display.
35
36;; A separate file, enriched.doc, contains further documentation and other
37;; important information about this code. It also serves as an example
38;; file in text/enriched format. It should be in the etc directory of your
39;; emacs distribution.
40
41;;; Code:
42
43(provide 'enriched)
44
45;;;
46;;; Variables controlling the display
47;;;
48
49(defgroup enriched nil
50 "Read and save files in text/enriched format"
51 :group 'wp)
52
53(defcustom enriched-verbose t
54 "*If non-nil, give status messages when reading and writing files."
55 :type 'boolean
56 :group 'enriched)
57
58;;;
59;;; Set up faces & display table
60;;;
61
62;; Emacs doesn't have a "fixed" face by default, since all faces currently
63;; have to be fixed-width. So we just pick one that looks different from the
64;; default.
65(defface fixed
66 '((t (:weight bold)))
67 "Face used for text that must be shown in fixed width.
68Currently, emacs can only display fixed-width fonts, but this may change.
69This face is used for text specifically marked as fixed-width, for example
70in text/enriched files."
71 :group 'enriched)
72
73(defface excerpt
74 '((t (:slant italic)))
75 "Face used for text that is an excerpt from another document.
76This is used in Enriched mode for text explicitly marked as an excerpt."
77 :group 'enriched)
78
79(defconst enriched-display-table (or (copy-sequence standard-display-table)
80 (make-display-table)))
81(aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
82
83(defconst enriched-par-props '(left-margin right-margin justification)
84 "Text-properties that usually apply to whole paragraphs.
85These are set front-sticky everywhere except at hard newlines.")
86
87;;;
88;;; Variables controlling the file format
89;;; (bidirectional)
90
91(defconst enriched-initial-annotation
92 (lambda ()
93 (format "Content-Type: text/enriched\nText-Width: %d\n\n"
94 fill-column))
95 "What to insert at the start of a text/enriched file.
96If this is a string, it is inserted. If it is a list, it should be a lambda
97expression, which is evaluated to get the string to insert.")
98
99(defconst enriched-annotation-format "<%s%s>"
100 "General format of enriched-text annotations.")
101
102(defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-Za-z0-9]+\\)>"
103 "Regular expression matching enriched-text annotations.")
104
105(defconst enriched-translations
106 '((face (bold-italic "bold" "italic")
107 (bold "bold")
108 (italic "italic")
109 (underline "underline")
110 (fixed "fixed")
111 (excerpt "excerpt")
112 (default )
113 (nil enriched-encode-other-face))
114 (left-margin (4 "indent"))
115 (right-margin (4 "indentright"))
116 (justification (none "nofill")
117 (right "flushright")
118 (left "flushleft")
119 (full "flushboth")
120 (center "center"))
121 (PARAMETER (t "param")) ; Argument of preceding annotation
122 ;; The following are not part of the standard:
123 (FUNCTION (enriched-decode-foreground "x-color")
124 (enriched-decode-background "x-bg-color")
125 (enriched-decode-display-prop "x-display"))
126 (read-only (t "x-read-only"))
127 (display (nil enriched-handle-display-prop))
128 (unknown (nil format-annotate-value))
129; (font-size (2 "bigger") ; unimplemented
130; (-2 "smaller"))
131)
132 "List of definitions of text/enriched annotations.
133See `format-annotate-region' and `format-deannotate-region' for the definition
134of this structure.")
135
136(defconst enriched-ignore
137 '(front-sticky rear-nonsticky hard)
138 "Properties that are OK to ignore when saving text/enriched files.
139Any property that is neither on this list nor dealt with by
140`enriched-translations' will generate a warning.")
141
142;;; Internal variables
143
144
145(defcustom enriched-mode-hook nil
146 "Hook run after entering/leaving Enriched mode.
147If you set variables in this hook, you should arrange for them to be restored
148to their old values if you leave Enriched mode. One way to do this is to add
149them and their old values to `enriched-old-bindings'."
150 :type 'hook
151 :group 'enriched)
152
153(defvar enriched-old-bindings nil
154 "Store old variable values that we change when entering mode.
155The value is a list of \(VAR VALUE VAR VALUE...).")
156(make-variable-buffer-local 'enriched-old-bindings)
157
158;;;
159;;; Define the mode
160;;;
161
162(put 'enriched-mode 'permanent-local t)
163;;;###autoload
164(define-minor-mode enriched-mode
165 "Minor mode for editing text/enriched files.
166These are files with embedded formatting information in the MIME standard
167text/enriched format.
168Turning the mode on runs `enriched-mode-hook'.
169
170More information about Enriched mode is available in the file
171etc/enriched.doc in the Emacs distribution directory.
172
173Commands:
174
175\\{enriched-mode-map}"
176 nil " Enriched" nil
177 (cond ((null enriched-mode)
178 ;; Turn mode off
179 (setq buffer-file-format (delq 'text/enriched buffer-file-format))
180 ;; restore old variable values
181 (while enriched-old-bindings
182 (set (pop enriched-old-bindings) (pop enriched-old-bindings))))
183
184 ((memq 'text/enriched buffer-file-format)
185 ;; Mode already on; do nothing.
186 nil)
187
188 (t ; Turn mode on
189 (push 'text/enriched buffer-file-format)
190 ;; Save old variable values before we change them.
191 ;; These will be restored if we exit Enriched mode.
192 (setq enriched-old-bindings
193 (list 'buffer-display-table buffer-display-table
194 'indent-line-function indent-line-function
195 'default-text-properties default-text-properties))
196 (make-local-variable 'indent-line-function)
197 (make-local-variable 'default-text-properties)
198 (setq indent-line-function 'indent-to-left-margin ;WHY?? -sm
199 buffer-display-table enriched-display-table)
200 (use-hard-newlines 1 nil)
201 (let ((sticky (plist-get default-text-properties 'front-sticky))
202 (p enriched-par-props))
203 (dolist (x p)
204 (add-to-list 'sticky x))
205 (if sticky
206 (setq default-text-properties
207 (plist-put default-text-properties
208 'front-sticky sticky)))))))
209
210;;;
211;;; Keybindings
212;;;
213
214(defvar enriched-mode-map nil
215 "Keymap for Enriched mode.")
216
217(if (null enriched-mode-map)
218 (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
219
220(if (not (assq 'enriched-mode minor-mode-map-alist))
221 (setq minor-mode-map-alist
222 (cons (cons 'enriched-mode enriched-mode-map)
223 minor-mode-map-alist)))
224
225(define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
226(define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
227(define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
228(define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
229(define-key enriched-mode-map "\M-S" 'set-justification-center)
230(define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
231(define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
232(define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
233
234;;;
235;;; Some functions dealing with text-properties, especially indentation
236;;;
237
238(defun enriched-map-property-regions (prop func &optional from to)
239 "Apply a function to regions of the buffer based on a text property.
240For each contiguous region of the buffer for which the value of PROPERTY is
241eq, the FUNCTION will be called. Optional arguments FROM and TO specify the
242region over which to scan.
243
244The specified function receives three arguments: the VALUE of the property in
245the region, and the START and END of each region."
246 (save-excursion
247 (save-restriction
248 (if to (narrow-to-region (point-min) to))
249 (goto-char (or from (point-min)))
250 (let ((begin (point))
251 end
252 (marker (make-marker))
253 (val (get-text-property (point) prop)))
254 (while (setq end (text-property-not-all begin (point-max) prop val))
255 (move-marker marker end)
256 (funcall func val begin (marker-position marker))
257 (setq begin (marker-position marker)
258 val (get-text-property marker prop)))
259 (if (< begin (point-max))
260 (funcall func val begin (point-max)))))))
261
262(put 'enriched-map-property-regions 'lisp-indent-hook 1)
263
264(defun enriched-insert-indentation (&optional from to)
265 "Indent and justify each line in the region."
266 (save-excursion
267 (save-restriction
268 (if to (narrow-to-region (point-min) to))
269 (goto-char (or from (point-min)))
270 (if (not (bolp)) (forward-line 1))
271 (while (not (eobp))
272 (if (eolp)
273 nil ; skip blank lines
274 (indent-to (current-left-margin))
275 (justify-current-line t nil t))
276 (forward-line 1)))))
277
278;;;
279;;; Encoding Files
280;;;
281
282;;;###autoload
283(defun enriched-encode (from to orig-buf)
284 (if enriched-verbose (message "Enriched: encoding document..."))
285 (save-restriction
286 (narrow-to-region from to)
287 (delete-to-left-margin)
288 (unjustify-region)
289 (goto-char from)
290 (format-replace-strings '(("<" . "<<")))
291 (format-insert-annotations
292 (format-annotate-region from (point-max) enriched-translations
293 'enriched-make-annotation enriched-ignore))
294 (goto-char from)
295 (insert (if (stringp enriched-initial-annotation)
296 enriched-initial-annotation
297 (save-excursion
298 ;; Eval this in the buffer we are annotating. This
299 ;; fixes a bug which was saving incorrect File-Width
300 ;; information, since we were looking at local
301 ;; variables in the wrong buffer.
302 (if orig-buf (set-buffer orig-buf))
303 (funcall enriched-initial-annotation))))
304 (enriched-map-property-regions 'hard
305 (lambda (v b e)
306 (if (and v (= ?\n (char-after b)))
307 (progn (goto-char b) (insert "\n"))))
308 (point) nil)
309 (if enriched-verbose (message nil))
310 ;; Return new end.
311 (point-max)))
312
313(defun enriched-make-annotation (internal-ann positive)
314 "Format an annotation INTERNAL-ANN.
315INTERNAL-ANN may be a string, for a flag, or a list of the form (PARAM VALUE).
316If POSITIVE is non-nil, this is the opening annotation;
317if nil, the matching close."
318 (cond ((stringp internal-ann)
319 (format enriched-annotation-format (if positive "" "/") internal-ann))
320 ;; Otherwise it is an annotation with parameters, represented as a list
321 (positive
322 (let ((item (car internal-ann))
323 (params (cdr internal-ann)))
324 (concat (format enriched-annotation-format "" item)
325 (mapconcat (lambda (i) (concat "<param>" i "</param>"))
326 params ""))))
327 (t (format enriched-annotation-format "/" (car internal-ann)))))
328
329(defun enriched-encode-other-face (old new)
330 "Generate annotations for random face change.
331One annotation each for foreground color, background color, italic, etc."
332 (cons (and old (enriched-face-ans old))
333 (and new (enriched-face-ans new))))
334
335(defun enriched-face-ans (face)
336 "Return annotations specifying FACE.
337FACE may be a list of faces instead of a single face;
338it can also be anything allowed as an element of a list
339which can be the value of the `face' text property."
340 (cond ((and (consp face) (eq (car face) 'foreground-color))
341 (list (list "x-color" (cdr face))))
342 ((and (consp face) (eq (car face) 'background-color))
343 (list (list "x-bg-color" (cdr face))))
344 ((and (listp face) (eq (car face) :foreground))
345 (list (list "x-color" (cadr face))))
346 ((and (listp face) (eq (car face) :background))
347 (list (list "x-bg-color" (cadr face))))
348 ((listp face)
349 (apply 'append (mapcar 'enriched-face-ans face)))
350 ((let* ((fg (face-attribute face :foreground))
351 (bg (face-attribute face :background))
352 (props (face-font face t))
353 (ans (cdr (format-annotate-single-property-change
354 'face nil props enriched-translations))))
355 (unless (eq fg 'unspecified)
356 (setq ans (cons (list "x-color" fg) ans)))
357 (unless (eq bg 'unspecified)
358 (setq ans (cons (list "x-bg-color" bg) ans)))
359 ans))))
360
361;;;
362;;; Decoding files
363;;;
364
365;;;###autoload
366(defun enriched-decode (from to)
367 (if enriched-verbose (message "Enriched: decoding document..."))
368 (use-hard-newlines 1 'never)
369 (save-excursion
370 (save-restriction
371 (narrow-to-region from to)
372 (goto-char from)
373
374 ;; Deal with header
375 (let ((file-width (enriched-get-file-width)))
376 (enriched-remove-header)
377
378 ;; Deal with newlines
379 (while (search-forward-regexp "\n\n+" nil t)
380 (if (current-justification)
381 (delete-char -1))
382 (set-hard-newline-properties (match-beginning 0) (point)))
383
384 ;; Translate annotations
385 (format-deannotate-region from (point-max) enriched-translations
386 'enriched-next-annotation)
387
388 ;; Indent or fill the buffer
389 (cond (file-width ; File was filled to this width
390 (setq fill-column file-width)
391 (if enriched-verbose (message "Indenting..."))
392 (enriched-insert-indentation))
393 (t ; File was not filled.
394 (if enriched-verbose (message "Filling paragraphs..."))
395 (fill-region (point-min) (point-max))))
396 (if enriched-verbose (message nil)))
397 (point-max))))
398
399(defun enriched-next-annotation ()
400 "Find and return next text/enriched annotation.
401Any \"<<\" strings encountered are converted to \"<\".
402Return value is \(begin end name positive-p), or nil if none was found."
403 (while (and (search-forward "<" nil 1)
404 (progn (goto-char (match-beginning 0))
405 (not (looking-at enriched-annotation-regexp))))
406 (forward-char 1)
407 (if (= ?< (char-after (point)))
408 (delete-char 1)
409 ;; A single < that does not start an annotation is an error,
410 ;; which we note and then ignore.
411 (message "Warning: malformed annotation in file at %s"
412 (1- (point)))))
413 (if (not (eobp))
414 (let* ((beg (match-beginning 0))
415 (end (match-end 0))
416 (name (downcase (buffer-substring
417 (match-beginning 2) (match-end 2))))
418 (pos (not (match-beginning 1))))
419 (list beg end name pos))))
420
421(defun enriched-get-file-width ()
422 "Look for file width information on this line."
423 (save-excursion
424 (if (search-forward "Text-Width: " (+ (point) 1000) t)
425 (read (current-buffer)))))
426
427(defun enriched-remove-header ()
428 "Remove file-format header at point."
429 (while (looking-at "^[-A-Za-z]+: .*\n")
430 (delete-region (point) (match-end 0)))
431 (if (looking-at "^\n")
432 (delete-char 1)))
433
434(defun enriched-decode-foreground (from to &optional color)
435 (if color
436 (list from to 'face (list ':foreground color))
437 (message "Warning: no color specified for <x-color>")
438 nil))
439
440(defun enriched-decode-background (from to &optional color)
441 (if color
442 (list from to 'face (list ':background color))
443 (message "Warning: no color specified for <x-bg-color>")
444 nil))
445
446;;; Handling the `display' property.
447
448
449(defun enriched-handle-display-prop (old new)
450 "Return a list of annotations for a change in the `display' property.
451OLD is the old value of the property, NEW is the new value. Value
452is a list `(CLOSE OPEN)', where CLOSE is a list of annotations to
453close and OPEN a list of annotations to open. Each of these lists
454has the form `(ANNOTATION PARAM ...)'."
455 (let ((annotation "x-display")
456 (param (prin1-to-string (or old new))))
457 (if (null old)
458 (cons nil (list (list annotation param)))
459 (cons (list (list annotation param)) nil))))
460
461(defun enriched-decode-display-prop (start end &optional param)
462 "Decode a `display' property for text between START and END.
463PARAM is a `<param>' found for the property.
464Value is a list `(START END SYMBOL VALUE)' with START and END denoting
465the range of text to assign text property SYMBOL with value VALUE "
466 (let ((prop (when (stringp param)
467 (condition-case ()
468 (car (read-from-string param))
469 (error nil)))))
470 (unless prop
471 (message "Warning: invalid <x-display> parameter %s" param))
472 (list start end 'display prop)))
473
474;;; enriched.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-12 07:04:46 +0000