aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2008-06-03 08:08:01 +0000
committerStefan Monnier2008-06-03 08:08:01 +0000
commita87c1daf657350ebae2cc9935d10dacde0b6f00a (patch)
tree1c59290a7291fa76725a15e5b57401adb5e5193f
parent8d27bcdf2e758dc6a4868c8fdee65b9a93101b67 (diff)
downloademacs-a87c1daf657350ebae2cc9935d10dacde0b6f00a.tar.gz
emacs-a87c1daf657350ebae2cc9935d10dacde0b6f00a.zip
* obsolete/bg-mouse.el, obsolete/float.el, obsolete/hilit19.el,
* obsolete/lselect.el, obsolete/mlsupport.el, obsolete/ooutline.el, * obsolete/profile.el, obsolete/rsz-mini.el, obsolete/uncompress.el, * obsolete/auto-show.el, obsolete/hscroll.el: Remove packages that were obsolete in Emacs-20, or that were obsolete in Emacs-21 and do not contain any more code.
Diffstat
-rw-r--r--lisp/ChangeLog7
-rw-r--r--lisp/obsolete/auto-show.el54
-rw-r--r--lisp/obsolete/bg-mouse.el308
-rw-r--r--lisp/obsolete/float.el460
-rw-r--r--lisp/obsolete/hilit19.el1527
-rw-r--r--lisp/obsolete/hscroll.el106
-rw-r--r--lisp/obsolete/lselect.el247
-rw-r--r--lisp/obsolete/mlsupport.el430
-rw-r--r--lisp/obsolete/ooutline.el587
-rw-r--r--lisp/obsolete/profile.el294
-rw-r--r--lisp/obsolete/rsz-mini.el84
-rw-r--r--lisp/obsolete/uncompress.el115
12 files changed, 7 insertions, 4212 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ec5be377aa7..da9be57157c 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,12 @@
12008-06-03 Stefan Monnier <monnier@iro.umontreal.ca> 12008-06-03 Stefan Monnier <monnier@iro.umontreal.ca>
2 2
3 * obsolete/bg-mouse.el, obsolete/float.el, obsolete/hilit19.el,
4 * obsolete/lselect.el, obsolete/mlsupport.el, obsolete/ooutline.el,
5 * obsolete/profile.el, obsolete/rsz-mini.el, obsolete/uncompress.el,
6 * obsolete/auto-show.el, obsolete/hscroll.el:
7 Remove packages that were obsolete in Emacs-20, or that were obsolete
8 in Emacs-21 and do not contain any more code.
9
3 * vc-dispatcher.el (vc-dir-menu-map-filter): Don't fail if 10 * vc-dispatcher.el (vc-dir-menu-map-filter): Don't fail if
4 vc-client-mode is not set. 11 vc-client-mode is not set.
5 12
diff --git a/lisp/obsolete/auto-show.el b/lisp/obsolete/auto-show.el
deleted file mode 100644
index 2fc3d25feef..00000000000
--- a/lisp/obsolete/auto-show.el
+++ /dev/null
@@ -1,54 +0,0 @@
1;;; auto-show.el --- perform automatic horizontal scrolling as point moves
2;;; This file is in the public domain.
3
4;; This file is part of GNU Emacs.
5
6;; Keywords: scroll display convenience
7;; Author: Pete Ware <ware@cis.ohio-state.edu>
8;; Maintainer: FSF
9
10;;; Commentary:
11
12;; This file has been obsolete since Emacs 21.1.
13
14;; This file contains dummy variables and functions only because Emacs
15;; does hscrolling automatically, now.
16
17;;; Code:
18
19(defgroup auto-show nil
20 "This customization group is kept for compatibility only.
21Emacs now does hscrolling automatically. Please remove references
22to auto-show from your init file and code."
23 :group 'editing)
24
25;;;###autoload
26(defcustom auto-show-mode nil
27 "Obsolete."
28 :version "20.4"
29 :type 'boolean
30 :group 'auto-show)
31
32(defcustom auto-show-shift-amount 8
33 "*Obsolete."
34 :type 'integer
35 :group 'auto-show)
36
37(defcustom auto-show-show-left-margin-threshold 50
38 "*Obsolete."
39 :type 'integer
40 :group 'auto-show)
41
42;;;###autoload
43(defun auto-show-mode (arg)
44 "This command is obsolete."
45 (interactive "P"))
46
47(defun auto-show-make-point-visible (&optional ignore-arg)
48 "This command is obsolete."
49 (interactive))
50
51(provide 'auto-show)
52
53;; arch-tag: 49587cbf-95cc-4061-b564-274aaec37469
54;;; auto-show.el ends here
diff --git a/lisp/obsolete/bg-mouse.el b/lisp/obsolete/bg-mouse.el
deleted file mode 100644
index 153dd98e3ba..00000000000
--- a/lisp/obsolete/bg-mouse.el
+++ /dev/null
@@ -1,308 +0,0 @@
1;;; bg-mouse.el --- GNU Emacs code for BBN Bitgraph mouse
2
3;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
4;; 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Author: John Robinson <jr@bbn-unix.arpa>
7;; Stephen Gildea <gildea@bbn.com>
8;; Maintainer: FSF
9;; Keywords: hardware
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27
28;; This file has been obsolete since Emacs 22.1.
29
30;;; Code:
31
32;;; Original version by John Robinson (jr@bbn-unix.arpa, bbncca!jr), Oct 1985
33;;; Modularized and enhanced by gildea@bbn.com Nov 1987
34;;; Time stamp <89/03/21 14:27:08 gildea>
35
36;;; User customization option:
37
38(defvar bg-mouse-fast-select-window nil
39 "*Non-nil for mouse hits to select new window, then execute; else just select.")
40
41;;; These numbers are summed to make the index into the mouse-map.
42;;; The low three bits correspond to what the mouse actually sends.
43(defconst bg-button-r 1)
44(defconst bg-button-m 2)
45(defconst bg-button-c 2)
46(defconst bg-button-l 4)
47(defconst bg-in-modeline 8)
48(defconst bg-in-scrollbar 16)
49(defconst bg-in-minibuf 24)
50
51;;; semicolon screws up indenting, so use this instead
52(defconst semicolon ?\;)
53
54(defvar bg-mouse-x)
55(defvar bg-mouse-y)
56(defvar bg-cursor-window)
57;; This variable does not exist since 1991, so it's a safe bet
58;; this package is not really used anymore. Still...
59(defvar mouse-map)
60
61;;; Defuns:
62
63(defun bg-mouse-report (prefix-arg)
64 "Read, parse, and execute a BBN BitGraph mouse click.
65
66L-- move point | These apply for mouse click in a window.
67--R set mark | If bg-mouse-fast-select-window is nil,
68L-R kill region | these commands on a nonselected window
69-C- move point and yank | just select that window.
70LC- yank-pop |
71-CR or LCR undo | \"Scroll bar\" is right-hand window column.
72
73on modeline: on \"scroll bar\": in minibuffer:
74L-- scroll-up line to top execute-extended-command
75--R scroll-down line to bottom eval-expression
76-C- proportional goto-char line to middle suspend-emacs
77
78To reinitialize the mouse if the terminal is reset, type ESC : RET"
79 (interactive "P")
80 (bg-get-tty-num semicolon)
81 (let*
82 ((screen-mouse-x (min (1- (frame-width)) ;don't hit column 86!
83 (/ (bg-get-tty-num semicolon) 9)))
84 (screen-mouse-y (- (1- (frame-height)) ;assume default font size.
85 (/ (bg-get-tty-num semicolon) 16)))
86 (bg-mouse-buttons (% (bg-get-tty-num ?c) 8))
87 (bg-mouse-window (bg-window-from-x-y screen-mouse-x screen-mouse-y))
88 (bg-cursor-window (selected-window))
89 (edges (window-edges bg-mouse-window))
90 (minibuf-p (= screen-mouse-y (1- (frame-height))))
91 (in-modeline-p (and (not minibuf-p)
92 (= screen-mouse-y (1- (nth 3 edges)))))
93 (in-scrollbar-p (and (not minibuf-p) (not in-modeline-p)
94 (>= screen-mouse-x (1- (nth 2 edges)))))
95 (same-window-p (eq bg-mouse-window bg-cursor-window))
96 (in-minibuf-p (and minibuf-p
97 (not bg-mouse-window))) ;minibuf must be inactive
98 (bg-mode-bits (+ (if in-minibuf-p bg-in-minibuf 0)
99 (if in-modeline-p bg-in-modeline 0)
100 (if in-scrollbar-p bg-in-scrollbar 0)))
101 (bg-command
102 (lookup-key mouse-map
103 (char-to-string (+ bg-mode-bits bg-mouse-buttons))))
104 (bg-mouse-x (- screen-mouse-x (nth 0 edges)))
105 (bg-mouse-y (- screen-mouse-y (nth 1 edges))))
106 (cond ((or in-modeline-p in-scrollbar-p)
107 (select-window bg-mouse-window)
108 (bg-command-execute bg-command)
109 (select-window bg-cursor-window))
110 ((or same-window-p in-minibuf-p)
111 (bg-command-execute bg-command))
112 (t ;in another window
113 (select-window bg-mouse-window)
114 (if bg-mouse-fast-select-window
115 (bg-command-execute bg-command)))
116 )))
117
118
119;;; Library of commands:
120
121(defun bg-set-point ()
122 "Move point to location of BitGraph mouse."
123 (interactive)
124 (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
125 (setq this-command 'next-line) ;make subsequent line moves work
126 (setq temporary-goal-column bg-mouse-x))
127
128(defun bg-set-mark ()
129 "Set mark at location of BitGraph mouse."
130 (interactive)
131 (push-mark)
132 (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
133 (exchange-point-and-mark))
134
135(defun bg-yank ()
136 "Move point to location of BitGraph mouse and yank."
137 (interactive "*")
138 (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
139 (setq this-command 'yank)
140 (yank))
141
142(defun yank-pop-1 ()
143 (interactive "*")
144 (yank-pop 1))
145
146(defun bg-yank-or-pop ()
147 "Move point to location of BitGraph mouse and yank. If last command
148was a yank, do a yank-pop."
149 (interactive "*")
150 (if (eq last-command 'yank)
151 (yank-pop 1)
152 (bg-yank)))
153
154;;; In 18.51, Emacs Lisp doesn't provide most-positive-fixnum
155(defconst bg-most-positive-fixnum 8388607)
156
157(defun bg-move-by-percentage ()
158 "Go to location in buffer that is the same percentage of the way
159through the buffer as the BitGraph mouse's X position in the window."
160 (interactive)
161 ;; check carefully for overflow in intermediate calculations
162 (goto-char
163 (cond ((zerop bg-mouse-x)
164 0)
165 ((< (buffer-size) (/ bg-most-positive-fixnum bg-mouse-x))
166 ;; no danger of overflow: compute it exactly
167 (/ (* bg-mouse-x (buffer-size))
168 (1- (window-width))))
169 (t
170 ;; overflow possible: approximate
171 (* (/ (buffer-size) (1- (window-width)))
172 bg-mouse-x))))
173 (beginning-of-line)
174 (what-cursor-position))
175
176(defun bg-mouse-line-to-top ()
177 "Scroll the line pointed to by the BitGraph mouse to the top of the window."
178 (interactive)
179 (scroll-up bg-mouse-y))
180
181(defun bg-mouse-line-to-center ()
182 "Scroll the line pointed to by the BitGraph mouse to the center
183of the window"
184 (interactive)
185 (scroll-up (/ (+ 2 bg-mouse-y bg-mouse-y (- (window-height))) 2)))
186
187(defun bg-mouse-line-to-bottom ()
188 "Scroll the line pointed to by the mouse to the bottom of the window."
189 (interactive)
190 (scroll-up (+ bg-mouse-y (- 2 (window-height)))))
191
192(defun bg-kill-region ()
193 (interactive "*")
194 (kill-region (region-beginning) (region-end)))
195
196(defun bg-insert-moused-sexp ()
197 "Insert a copy of the word (actually sexp) that the mouse is pointing at.
198Sexp is inserted into the buffer at point (where the text cursor is)."
199 (interactive)
200 (let ((moused-text
201 (save-excursion
202 (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
203 (if (looking-at "\\s)")
204 (forward-char 1)
205 (forward-sexp 1))
206 (buffer-substring (save-excursion (backward-sexp 1) (point))
207 (point)))))
208 (select-window bg-cursor-window)
209 (delete-horizontal-space)
210 (cond
211 ((bolp)
212 (indent-according-to-mode))
213 ;; In Lisp assume double-quote is closing; in Text assume opening.
214 ;; Why? Because it does the right thing most often.
215 ((save-excursion (forward-char -1)
216 (and (not (looking-at "\\s\""))
217 (looking-at "[`'\"\\]\\|\\s(")))
218 nil)
219 (t
220 (insert " ")))
221 (insert moused-text)
222 (or (eolp)
223 (looking-at "\\s.\\|\\s)")
224 (and (looking-at "'") (looking-at "\\sw")) ;hack for text mode
225 (save-excursion (insert " ")))))
226
227;;; Utility functions:
228
229(defun bg-get-tty-num (term-char)
230 "Read from terminal until TERM-CHAR is read, and return intervening number.
231If non-numeric not matching TERM-CHAR, reprogram the mouse and signal an error."
232 (let
233 ((num 0)
234 (char (- (read-char) 48)))
235 (while (and (>= char 0)
236 (<= char 9))
237 (setq num (+ (* num 10) char))
238 (setq char (- (read-char) 48)))
239 (or (eq term-char (+ char 48))
240 (progn
241 (bg-program-mouse)
242 (error
243 "Invalid data format in bg-mouse command: mouse reinitialized.")))
244 num))
245
246;;; Note that this fails in the minibuf because move-to-column doesn't
247;;; allow for the width of the prompt.
248(defun bg-move-point-to-x-y (x y)
249 "Position cursor in window coordinates.
250X and Y are 0-based character positions in the window."
251 (move-to-window-line y)
252 ;; if not on a wrapped line, zero-column will be 0
253 (let ((zero-column (current-column))
254 (scroll-offset (window-hscroll)))
255 ;; scrolling takes up column 0 to display the $
256 (if (> scroll-offset 0)
257 (setq scroll-offset (1- scroll-offset)))
258 (move-to-column (+ zero-column scroll-offset x))
259 ))
260
261;;; Returns the window that screen position (x, y) is in or nil if none,
262;;; meaning we are in the echo area with a non-active minibuffer.
263(defun bg-window-from-x-y (x y)
264 "Find window corresponding to screen coordinates.
265X and Y are 0-based character positions on the screen."
266 (get-window-with-predicate (lambda (w)
267 (coordinates-in-window-p (cons x y) w))))
268
269(defun bg-command-execute (bg-command)
270 (if (commandp bg-command)
271 (command-execute bg-command)
272 (ding)))
273
274(defun bg-program-mouse ()
275 (send-string-to-terminal "\e:0;7;;;360;512;9;16;9;16c"))
276
277;;; Note that the doc string for mouse-map (as defined in subr.el)
278;;; says it is for the X-window mouse. This is wrong; that keymap
279;;; should be used for your mouse no matter what terminal you have.
280
281(or (keymapp mouse-map)
282 (setq mouse-map (make-keymap)))
283
284(defun bind-bg-mouse-click (click-code function)
285 "Bind bg-mouse CLICK-CODE to run FUNCTION."
286 (define-key mouse-map (char-to-string click-code) function))
287
288(bind-bg-mouse-click bg-button-l 'bg-set-point)
289(bind-bg-mouse-click bg-button-m 'bg-yank)
290(bind-bg-mouse-click bg-button-r 'bg-set-mark)
291(bind-bg-mouse-click (+ bg-button-l bg-button-m) 'yank-pop-1)
292(bind-bg-mouse-click (+ bg-button-l bg-button-r) 'bg-kill-region)
293(bind-bg-mouse-click (+ bg-button-m bg-button-r) 'undo)
294(bind-bg-mouse-click (+ bg-button-l bg-button-m bg-button-r) 'undo)
295(bind-bg-mouse-click (+ bg-in-modeline bg-button-l) 'scroll-up)
296(bind-bg-mouse-click (+ bg-in-modeline bg-button-m) 'bg-move-by-percentage)
297(bind-bg-mouse-click (+ bg-in-modeline bg-button-r) 'scroll-down)
298(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-l) 'bg-mouse-line-to-top)
299(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-m) 'bg-mouse-line-to-center)
300(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-r) 'bg-mouse-line-to-bottom)
301(bind-bg-mouse-click (+ bg-in-minibuf bg-button-l) 'execute-extended-command)
302(bind-bg-mouse-click (+ bg-in-minibuf bg-button-m) 'suspend-emacs)
303(bind-bg-mouse-click (+ bg-in-minibuf bg-button-r) 'eval-expression)
304
305(provide 'bg-mouse)
306
307;; arch-tag: b3d06605-2971-44b1-be2c-e49c24e1a8d3
308;;; bg-mouse.el ends here
diff --git a/lisp/obsolete/float.el b/lisp/obsolete/float.el
deleted file mode 100644
index e86b8633f45..00000000000
--- a/lisp/obsolete/float.el
+++ /dev/null
@@ -1,460 +0,0 @@
1;;; float.el --- obsolete floating point arithmetic package
2
3;; Copyright (C) 1986, 2001, 2002, 2003, 2004, 2005,
4;; 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Author: Bill Rosenblatt
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 3 of the License, or
15;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
24
25;;; Commentary:
26
27;; This file has been obsolete since Emacs 22.1.
28
29;; Floating point numbers are represented by dot-pairs (mant . exp)
30;; where mant is the 24-bit signed integral mantissa and exp is the
31;; base 2 exponent.
32;;
33;; Emacs LISP supports a 24-bit signed integer data type, which has a
34;; range of -(2**23) to +(2**23)-1, or -8388608 to 8388607 decimal.
35;; This gives six significant decimal digit accuracy. Exponents can
36;; be anything in the range -(2**23) to +(2**23)-1.
37;;
38;; User interface:
39;; function f converts from integer to floating point
40;; function string-to-float converts from string to floating point
41;; function fint converts a floating point to integer (with truncation)
42;; function float-to-string converts from floating point to string
43;;
44;; Caveats:
45;; - Exponents outside of the range of +/-100 or so will cause certain
46;; functions (especially conversion routines) to take forever.
47;; - Very little checking is done for fixed point overflow/underflow.
48;; - No checking is done for over/underflow of the exponent
49;; (hardly necessary when exponent can be 2**23).
50;;
51;;
52;; Bill Rosenblatt
53;; June 20, 1986
54;;
55
56;;; Code:
57
58;; fundamental implementation constants
59(defconst exp-base 2
60 "Base of exponent in this floating point representation.")
61
62(defconst mantissa-bits 24
63 "Number of significant bits in this floating point representation.")
64
65(defconst decimal-digits 6
66 "Number of decimal digits expected to be accurate.")
67
68(defconst expt-digits 2
69 "Maximum permitted digits in a scientific notation exponent.")
70
71;; other constants
72(defconst maxbit (1- mantissa-bits)
73 "Number of highest bit")
74
75(defconst mantissa-maxval (1- (ash 1 maxbit))
76 "Maximum permissible value of mantissa")
77
78(defconst mantissa-minval (ash 1 maxbit)
79 "Minimum permissible value of mantissa")
80
81(defconst floating-point-regexp
82 "^[ \t]*\\(-?\\)\\([0-9]*\\)\
83\\(\\.\\([0-9]*\\)\\|\\)\
84\\(\\(\\([Ee]\\)\\(-?\\)\\([0-9][0-9]*\\)\\)\\|\\)[ \t]*$"
85 "Regular expression to match floating point numbers. Extract matches:
861 - minus sign
872 - integer part
884 - fractional part
898 - minus sign for power of ten
909 - power of ten
91")
92
93(defconst high-bit-mask (ash 1 maxbit)
94 "Masks all bits except the high-order (sign) bit.")
95
96(defconst second-bit-mask (ash 1 (1- maxbit))
97 "Masks all bits except the highest-order magnitude bit")
98
99;; various useful floating point constants
100(defconst _f0 '(0 . 1))
101
102(defconst _f1/2 '(4194304 . -23))
103
104(defconst _f1 '(4194304 . -22))
105
106(defconst _f10 '(5242880 . -19))
107
108;; support for decimal conversion routines
109(defvar powers-of-10 (make-vector (1+ decimal-digits) _f1))
110(aset powers-of-10 1 _f10)
111(aset powers-of-10 2 '(6553600 . -16))
112(aset powers-of-10 3 '(8192000 . -13))
113(aset powers-of-10 4 '(5120000 . -9))
114(aset powers-of-10 5 '(6400000 . -6))
115(aset powers-of-10 6 '(8000000 . -3))
116
117(defconst all-decimal-digs-minval (aref powers-of-10 (1- decimal-digits)))
118(defconst highest-power-of-10 (aref powers-of-10 decimal-digits))
119
120(defun fashl (fnum) ; floating-point arithmetic shift left
121 (cons (ash (car fnum) 1) (1- (cdr fnum))))
122
123(defun fashr (fnum) ; floating point arithmetic shift right
124 (cons (ash (car fnum) -1) (1+ (cdr fnum))))
125
126(defun normalize (fnum)
127 (if (> (car fnum) 0) ; make sure next-to-highest bit is set
128 (while (zerop (logand (car fnum) second-bit-mask))
129 (setq fnum (fashl fnum)))
130 (if (< (car fnum) 0) ; make sure highest bit is set
131 (while (zerop (logand (car fnum) high-bit-mask))
132 (setq fnum (fashl fnum)))
133 (setq fnum _f0))) ; "standard 0"
134 fnum)
135
136(defun abs (n) ; integer absolute value
137 (if (>= n 0) n (- n)))
138
139(defun fabs (fnum) ; re-normalize after taking abs value
140 (normalize (cons (abs (car fnum)) (cdr fnum))))
141
142(defun xor (a b) ; logical exclusive or
143 (and (or a b) (not (and a b))))
144
145(defun same-sign (a b) ; two f-p numbers have same sign?
146 (not (xor (natnump (car a)) (natnump (car b)))))
147
148(defun extract-match (str i) ; used after string-match
149 (condition-case ()
150 (substring str (match-beginning i) (match-end i))
151 (error "")))
152
153;; support for the multiplication function
154(defconst halfword-bits (/ mantissa-bits 2)) ; bits in a halfword
155(defconst masklo (1- (ash 1 halfword-bits))) ; isolate the lower halfword
156(defconst maskhi (lognot masklo)) ; isolate the upper halfword
157(defconst round-limit (ash 1 (/ halfword-bits 2)))
158
159(defun hihalf (n) ; return high halfword, shifted down
160 (ash (logand n maskhi) (- halfword-bits)))
161
162(defun lohalf (n) ; return low halfword
163 (logand n masklo))
164
165;; Visible functions
166
167;; Arithmetic functions
168(defun f+ (a1 a2)
169 "Returns the sum of two floating point numbers."
170 (let ((f1 (fmax a1 a2))
171 (f2 (fmin a1 a2)))
172 (if (same-sign a1 a2)
173 (setq f1 (fashr f1) ; shift right to avoid overflow
174 f2 (fashr f2)))
175 (normalize
176 (cons (+ (car f1) (ash (car f2) (- (cdr f2) (cdr f1))))
177 (cdr f1)))))
178
179(defun f- (a1 &optional a2) ; unary or binary minus
180 "Returns the difference of two floating point numbers."
181 (if a2
182 (f+ a1 (f- a2))
183 (normalize (cons (- (car a1)) (cdr a1)))))
184
185(defun f* (a1 a2) ; multiply in halfword chunks
186 "Returns the product of two floating point numbers."
187 (let* ((i1 (car (fabs a1)))
188 (i2 (car (fabs a2)))
189 (sign (not (same-sign a1 a2)))
190 (prodlo (+ (hihalf (* (lohalf i1) (lohalf i2)))
191 (lohalf (* (hihalf i1) (lohalf i2)))
192 (lohalf (* (lohalf i1) (hihalf i2)))))
193 (prodhi (+ (* (hihalf i1) (hihalf i2))
194 (hihalf (* (hihalf i1) (lohalf i2)))
195 (hihalf (* (lohalf i1) (hihalf i2)))
196 (hihalf prodlo))))
197 (if (> (lohalf prodlo) round-limit)
198 (setq prodhi (1+ prodhi))) ; round off truncated bits
199 (normalize
200 (cons (if sign (- prodhi) prodhi)
201 (+ (cdr (fabs a1)) (cdr (fabs a2)) mantissa-bits)))))
202
203(defun f/ (a1 a2) ; SLOW subtract-and-shift algorithm
204 "Returns the quotient of two floating point numbers."
205 (if (zerop (car a2)) ; if divide by 0
206 (signal 'arith-error (list "attempt to divide by zero" a1 a2))
207 (let ((bits (1- maxbit))
208 (quotient 0)
209 (dividend (car (fabs a1)))
210 (divisor (car (fabs a2)))
211 (sign (not (same-sign a1 a2))))
212 (while (natnump bits)
213 (if (< (- dividend divisor) 0)
214 (setq quotient (ash quotient 1))
215 (setq quotient (1+ (ash quotient 1))
216 dividend (- dividend divisor)))
217 (setq dividend (ash dividend 1)
218 bits (1- bits)))
219 (normalize
220 (cons (if sign (- quotient) quotient)
221 (- (cdr (fabs a1)) (cdr (fabs a2)) (1- maxbit)))))))
222
223(defun f% (a1 a2)
224 "Returns the remainder of first floating point number divided by second."
225 (f- a1 (f* (ftrunc (f/ a1 a2)) a2)))
226
227
228;; Comparison functions
229(defun f= (a1 a2)
230 "Returns t if two floating point numbers are equal, nil otherwise."
231 (equal a1 a2))
232
233(defun f> (a1 a2)
234 "Returns t if first floating point number is greater than second,
235nil otherwise."
236 (cond ((and (natnump (car a1)) (< (car a2) 0))
237 t) ; a1 nonnegative, a2 negative
238 ((and (> (car a1) 0) (<= (car a2) 0))
239 t) ; a1 positive, a2 nonpositive
240 ((and (<= (car a1) 0) (natnump (car a2)))
241 nil) ; a1 nonpos, a2 nonneg
242 ((/= (cdr a1) (cdr a2)) ; same signs. exponents differ
243 (> (cdr a1) (cdr a2))) ; compare the mantissas.
244 (t
245 (> (car a1) (car a2))))) ; same exponents.
246
247(defun f>= (a1 a2)
248 "Returns t if first floating point number is greater than or equal to
249second, nil otherwise."
250 (or (f> a1 a2) (f= a1 a2)))
251
252(defun f< (a1 a2)
253 "Returns t if first floating point number is less than second,
254nil otherwise."
255 (not (f>= a1 a2)))
256
257(defun f<= (a1 a2)
258 "Returns t if first floating point number is less than or equal to
259second, nil otherwise."
260 (not (f> a1 a2)))
261
262(defun f/= (a1 a2)
263 "Returns t if first floating point number is not equal to second,
264nil otherwise."
265 (not (f= a1 a2)))
266
267(defun fmin (a1 a2)
268 "Returns the minimum of two floating point numbers."
269 (if (f< a1 a2) a1 a2))
270
271(defun fmax (a1 a2)
272 "Returns the maximum of two floating point numbers."
273 (if (f> a1 a2) a1 a2))
274
275(defun fzerop (fnum)
276 "Returns t if the floating point number is zero, nil otherwise."
277 (= (car fnum) 0))
278
279(defun floatp (fnum)
280 "Returns t if the arg is a floating point number, nil otherwise."
281 (and (consp fnum) (integerp (car fnum)) (integerp (cdr fnum))))
282
283;; Conversion routines
284(defun f (int)
285 "Convert the integer argument to floating point, like a C cast operator."
286 (normalize (cons int '0)))
287
288(defun int-to-hex-string (int)
289 "Convert the integer argument to a C-style hexadecimal string."
290 (let ((shiftval -20)
291 (str "0x")
292 (hex-chars "0123456789ABCDEF"))
293 (while (<= shiftval 0)
294 (setq str (concat str (char-to-string
295 (aref hex-chars
296 (logand (lsh int shiftval) 15))))
297 shiftval (+ shiftval 4)))
298 str))
299
300(defun ftrunc (fnum) ; truncate fractional part
301 "Truncate the fractional part of a floating point number."
302 (cond ((natnump (cdr fnum)) ; it's all integer, return number as is
303 fnum)
304 ((<= (cdr fnum) (- maxbit)) ; it's all fractional, return 0
305 '(0 . 1))
306 (t ; otherwise mask out fractional bits
307 (let ((mant (car fnum)) (exp (cdr fnum)))
308 (normalize
309 (cons (if (natnump mant) ; if negative, use absolute value
310 (ash (ash mant exp) (- exp))
311 (- (ash (ash (- mant) exp) (- exp))))
312 exp))))))
313
314(defun fint (fnum) ; truncate and convert to integer
315 "Convert the floating point number to integer, with truncation,
316like a C cast operator."
317 (let* ((tf (ftrunc fnum)) (tint (car tf)) (texp (cdr tf)))
318 (cond ((>= texp mantissa-bits) ; too high, return "maxint"
319 mantissa-maxval)
320 ((<= texp (- mantissa-bits)) ; too low, return "minint"
321 mantissa-minval)
322 (t ; in range
323 (ash tint texp))))) ; shift so that exponent is 0
324
325(defun float-to-string (fnum &optional sci)
326 "Convert the floating point number to a decimal string.
327Optional second argument non-nil means use scientific notation."
328 (let* ((value (fabs fnum)) (sign (< (car fnum) 0))
329 (power 0) (result 0) (str "")
330 (temp 0) (pow10 _f1))
331
332 (if (f= fnum _f0)
333 "0"
334 (if (f>= value _f1) ; find largest power of 10 <= value
335 (progn ; value >= 1, power is positive
336 (while (f<= (setq temp (f* pow10 highest-power-of-10)) value)
337 (setq pow10 temp
338 power (+ power decimal-digits)))
339 (while (f<= (setq temp (f* pow10 _f10)) value)
340 (setq pow10 temp
341 power (1+ power))))
342 (progn ; value < 1, power is negative
343 (while (f> (setq temp (f/ pow10 highest-power-of-10)) value)
344 (setq pow10 temp
345 power (- power decimal-digits)))
346 (while (f> pow10 value)
347 (setq pow10 (f/ pow10 _f10)
348 power (1- power)))))
349 ; get value in range 100000 to 999999
350 (setq value (f* (f/ value pow10) all-decimal-digs-minval)
351 result (ftrunc value))
352 (let (int)
353 (if (f> (f- value result) _f1/2) ; round up if remainder > 0.5
354 (setq int (1+ (fint result)))
355 (setq int (fint result)))
356 (setq str (int-to-string int))
357 (if (>= int 1000000)
358 (setq power (1+ power))))
359
360 (if sci ; scientific notation
361 (setq str (concat (substring str 0 1) "." (substring str 1)
362 "E" (int-to-string power)))
363
364 ; regular decimal string
365 (cond ((>= power (1- decimal-digits))
366 ; large power, append zeroes
367 (let ((zeroes (- power decimal-digits)))
368 (while (natnump zeroes)
369 (setq str (concat str "0")
370 zeroes (1- zeroes)))))
371
372 ; negative power, prepend decimal
373 ((< power 0) ; point and zeroes
374 (let ((zeroes (- (- power) 2)))
375 (while (natnump zeroes)
376 (setq str (concat "0" str)
377 zeroes (1- zeroes)))
378 (setq str (concat "0." str))))
379
380 (t ; in range, insert decimal point
381 (setq str (concat
382 (substring str 0 (1+ power))
383 "."
384 (substring str (1+ power)))))))
385
386 (if sign ; if negative, prepend minus sign
387 (concat "-" str)
388 str))))
389
390
391;; string to float conversion.
392;; accepts scientific notation, but ignores anything after the first two
393;; digits of the exponent.
394(defun string-to-float (str)
395 "Convert the string to a floating point number.
396Accepts a decimal string in scientific notation, with exponent preceded
397by either E or e. Only the six most significant digits of the integer
398and fractional parts are used; only the first two digits of the exponent
399are used. Negative signs preceding both the decimal number and the exponent
400are recognized."
401
402 (if (string-match floating-point-regexp str 0)
403 (let (power)
404 (f*
405 ; calculate the mantissa
406 (let* ((int-subst (extract-match str 2))
407 (fract-subst (extract-match str 4))
408 (digit-string (concat int-subst fract-subst))
409 (mant-sign (equal (extract-match str 1) "-"))
410 (leading-0s 0) (round-up nil))
411
412 ; get rid of leading 0's
413 (setq power (- (length int-subst) decimal-digits))
414 (while (and (< leading-0s (length digit-string))
415 (= (aref digit-string leading-0s) ?0))
416 (setq leading-0s (1+ leading-0s)))
417 (setq power (- power leading-0s)
418 digit-string (substring digit-string leading-0s))
419
420 ; if more than 6 digits, round off
421 (if (> (length digit-string) decimal-digits)
422 (setq round-up (>= (aref digit-string decimal-digits) ?5)
423 digit-string (substring digit-string 0 decimal-digits))
424 (setq power (+ power (- decimal-digits (length digit-string)))))
425
426 ; round up and add minus sign, if necessary
427 (f (* (+ (string-to-number digit-string)
428 (if round-up 1 0))
429 (if mant-sign -1 1))))
430
431 ; calculate the exponent (power of ten)
432 (let* ((expt-subst (extract-match str 9))
433 (expt-sign (equal (extract-match str 8) "-"))
434 (expt 0) (chunks 0) (tens 0) (exponent _f1)
435 (func 'f*))
436
437 (setq expt (+ (* (string-to-number
438 (substring expt-subst 0
439 (min expt-digits (length expt-subst))))
440 (if expt-sign -1 1))
441 power))
442 (if (< expt 0) ; if power of 10 negative
443 (setq expt (- expt) ; take abs val of exponent
444 func 'f/)) ; and set up to divide, not multiply
445
446 (setq chunks (/ expt decimal-digits)
447 tens (% expt decimal-digits))
448 ; divide or multiply by "chunks" of 10**6
449 (while (> chunks 0)
450 (setq exponent (funcall func exponent highest-power-of-10)
451 chunks (1- chunks)))
452 ; divide or multiply by remaining power of ten
453 (funcall func exponent (aref powers-of-10 tens)))))
454
455 _f0)) ; if invalid, return 0
456
457(provide 'float)
458
459;; arch-tag: cc0c89c6-5718-49af-978e-585f6b14e347
460;;; float.el ends here
diff --git a/lisp/obsolete/hilit19.el b/lisp/obsolete/hilit19.el
deleted file mode 100644
index e989f4a7af1..00000000000
--- a/lisp/obsolete/hilit19.el
+++ /dev/null
@@ -1,1527 +0,0 @@
1;;; hilit19.el --- customizable highlighting for Emacs 19
2
3;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Author: Jonathan Stigelman <stig@hackvan.com> (broken email address. checked April 2008)
7;; Maintainer: FSF
8;; (actually no longer maintained)
9;; Keywords: faces
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27
28;; This file has been obsolete since Emacs 21.1.
29
30;; Hilit19.el is a customizable highlighting package for Emacs 19. It supports
31;; not only source code highlighting, but also Info, RMAIL, VM, gnus...
32;; Hilit19 knows (or thinks it knows) how to highlight emacs buffers in
33;; about 25 different modes.
34;;
35;; WHERE TO GET THE LATEST VERSIONS OF HILIT19.EL (beta and release):
36;;
37;; http://hackvan.com/pub/stig/src/elisp/
38;;
39;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40;;
41;; TO SUBMIT BUG REPORTS (or feedback of any sort)...
42;;
43;; M-x hilit-submit-feedback RET
44;;
45;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46;;
47;; hilit19.el,v 2.19 1993/09/08 18:44:10 stig Release
48;;
49;; LCD Archive Entry:
50;; hilit19|Jonathan Stigelman|stig@hackvan.com|
51;; Comprehensive (and comparatively fast) regex-based highlighting for Emacs 19|
52;; 1993/09/08 18:44:10|Release 2.19|~/packages/hilit19.el.Z|
53;;
54;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55;;
56;; GENERAL OVERVIEW
57;;
58;; This package installs numerous hooks to colorfully highlight your
59;; source code buffers as well as mail and news buffers. Most
60;; programming languages have predefined highlighting patterns.
61;; Just load hilit19 and files will be automatically highlighted as
62;; they're loaded.
63;;
64;; Rehighlight a buffer by typing C-S-l (control-shift-lowercase-L).
65;;
66;; If, when you edit the buffer, the coloring gets messed up, just
67;; redraw and the coloring will be adjusted. If automatic highlighting
68;; in the current buffer has been turned off, then typing C-u C-S-l will
69;; force a rehighlight of the entire buffer.
70;;
71;; Hilit19 can build faces by examining the names that you give to them
72;; For example, green/black-bold-italic-underline would be created as
73;; a face with a green foreground, and a black background, using a
74;; bold-italic font...with underlining for good measure.
75;;
76;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
77;;
78;; SETUP -- In your .emacs:
79;;
80;;
81;; (cond (window-system
82;; (setq hilit-mode-enable-list '(not text-mode)
83;; hilit-background-mode 'light
84;; hilit-inhibit-hooks nil
85;; hilit-inhibit-rebinding nil)
86;;
87;; (require 'hilit19)
88;; ))
89;;
90;; If you like font-lock-mode and want to use both packages, then you can
91;; disable hilit for the modes in which you want to use font-lock by listing
92;; said modes in hilit-mode-enable-list.
93;;
94;; (hilit-translate type 'RoyalBlue ; enable highlighting in C/C++
95;; string nil) ; disable string highlighting
96;;
97;; To get 100% of the utility of hilit19, you may also have to apply the
98;; patches below for info.el and vm5.33L_19/vm-summary.el
99;;
100;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
101;;
102;; SETUP -- Are you using the right font for Emacs?
103;;
104;; Emacs cannot properly find bold and italic fonts unless you specify a
105;; verbose X11 font name. If you specify a font for emacs in your
106;; .Xdefaults, it *MUST* be specified using the long form of the font name.
107;; Here's a good font menu:
108;;
109;; (setq
110;; x-fixed-font-alist
111;; '("Font Menu"
112;; ("Misc"
113;; ("6x12" "-misc-fixed-medium-r-semicondensed--12-110-75-75-c-60-*-1")
114;; ("6x13" "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-*-1")
115;; ("lucida 13"
116;; "-b&h-lucidatypewriter-medium-r-normal-sans-0-0-0-0-m-0-*-1")
117;; ("7x13" "-misc-fixed-medium-r-normal--13-120-75-75-c-70-*-1")
118;; ("7x14" "-misc-fixed-medium-r-normal--14-130-75-75-c-70-*-1")
119;; ("9x15" "-misc-fixed-medium-r-normal--15-140-*-*-c-*-*-1")
120;; ("")
121;; ("clean 8x8" "-schumacher-clean-medium-r-normal--*-80-*-*-c-*-*-1")
122;; ("clean 8x14" "-schumacher-clean-medium-r-normal--*-140-*-*-c-*-*-1")
123;; ("clean 8x10" "-schumacher-clean-medium-r-normal--*-100-*-*-c-*-*-1")
124;; ("clean 8x16" "-schumacher-clean-medium-r-normal--*-160-*-*-c-*-*-1")
125;; ("")
126;; ("sony 8x16" "-sony-fixed-medium-r-normal--16-120-100-100-c-80-*-1")
127;; ("")
128;; ("-- Courier --")
129;; ("Courier 10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-*-1")
130;; ("Courier 12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-*-1")
131;; ("Courier 14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-*-1")
132;; ("Courier 18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-*-1")
133;; ("Courier 18-b" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-*-1")
134;; )))
135;;
136;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
137;;
138;; KNOWN BUGS/TO DO LIST/HELP WANTED/APPLY WITHIN
139;;
140;; * unbalanced, unescaped double quote characters can confuse hilit19.
141;; This will be fixed someday, so don't bug me about it.
142;;
143;; * ALTHOUGH HILIT19 IS FASTER THAN FONT-LOCK-MODE...
144;; For various reasons, the speed of the package could still stand to be
145;; improved. If you care to do a little profiling and make things tighter...
146;;
147;; * hilit-toggle-highlight is flaky when auto-rehighlight is neither t nor nil.
148;; Does anyone actually USE this? I think I might just remove it.
149;;
150;; PROJECTS THAT YOU CAN TAKE OVER BECAUSE I DON'T MUCH CARE ABOUT THEM...
151;;
152;; * Moved hilit-wysiwyg-replace here from my version of man.el, this is not
153;; a bug. The bug is that I don't have a reverse operation yet...just a
154;; stub Wysiwyg-anything really belongs in a package of its own.
155;;
156;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
157;;
158;; Thanks to the following people for their input:
159;; ebert@enpc.enpc.fr (Rolf EBERT), ada, LaTeX & bibtex highlights
160;; Vivek Khera <khera@cs.duke.edu>, gnus hooks + random advice & patches
161;; brian@athe.WUstl.EDU (Brian Dunford-Shore), prolog highlights
162;; John Ladwig <jladwig@soils.umn.edu>, 1st pass nroff highlights
163;; campo@sunthpi3.difi.unipi.it (Massimo Campostrini), fortran highlights
164;; jayb@laplace.MATH.ColoState.EDU (Jay Bourland), 1st pass dired
165;; Yoshio Turner <yoshio@CS.UCLA.EDU>, modula 2 highlights
166;; Fritz Knabe <knabe@ecrc.de>, advice & patches
167;; Alon Albert <alon@milcse.rtsg.mot.com>, advice & patches
168;; dana@thumper.bellcore.com (Dana A. Chee), working on the multi-frame bug
169;; derway@ndc.com (Don Erway), for breaking it...
170;; moss_r@summer.chem.su.oz.au (Richard Moss), first pass at add-pattern
171;; Olivier Lecarme <ol@aiguemarine.unice.fr>, Pascal & Icon patterns
172;;
173;; With suggestions and minor regex patches from numerous others...
174;;
175;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
176;;
177;; hilit19.el,v
178;; Revision 2.19 1993/09/08 18:44:10 stig
179;; installed patch for elusive bug in hilit-rehighlight-region that caused
180;; hilit-unhighlight-region to hang in an infinite loop.
181;;
182;; Revision 2.18 1993/08/27 03:51:00 stig
183;; minor mods to lisp-mode and c/c++ mode patterns
184;;
185;; Revision 2.17 1993/08/25 02:19:17 stig
186;; work-around for bug in next-overlay-change that caused dired and jargon-mode
187;; to hang in an endless loop. Perhaps other modes were doing this too.
188;;
189;; Revision 2.16 1993/08/22 19:46:00 stig
190;; bug fix for next-overlay-change and accompanying change to
191;; hilit-unhighlight-region
192;;
193;; Revision 2.15 1993/08/20 12:16:22 stig
194;; minor change to fortran patterns
195;;
196;; Revision 2.14 1993/08/17 14:12:10 stig
197;; added default face mapping for 'formula' which is needed for new latex
198;; patterns.
199;;
200;; twiddled the calendar-mode patterns a bit.
201;;
202;; Revision 2.13 1993/08/16 04:33:54 stig
203;; hilit-set-mode-patterns was screwing up two part patterns. it doesn't now.
204;;
205;; Revision 2.12 1993/08/16 00:16:41 stig
206;; changed references to default-bold-italic to just bold-italic because the
207;; font for that face is maintained by emacs.
208;;
209;; the pattern matcher now starts its searches from the end of the most
210;; recently highlighted region (which is not necessarily the end of the most
211;; recently matched regex).
212;;
213;; multiple errors in pattern matcher now just give an error instead of lots of
214;; annoying messages and dings.
215;;
216;; no longer use vm-summary-mode-hooks.
217;;
218;; some code moved from hilit-highlight-region to hilit-set-mode-patterns.
219;; This will affect you if you pass your patterns directly to
220;; hilit-highlight-region....use a pseudo-mode instead.
221;;
222;; pattern changes to C/C++, latex, texinfo, fortran, nroff, etc.
223;;
224;; Revision 2.11 1993/08/13 12:12:37 stig
225;; removed some crufty commented-out code
226;;
227;; diverged lisp-mode and emacs-lisp-mode...also added lisp keywords.
228;;
229;; Revision 2.10 1993/08/13 09:47:06 stig
230;; added calendar-mode, icon-mode and pascal-mode patterns
231;;
232;; commented out hilit-toggle-highlight because I want to phase it out entirely
233;;
234;; Revision 2.9 1993/08/13 08:44:22 stig
235;; added optional case-fold argument to hilit-set-mode-patterns, this case-fold
236;; parameter is now stored in hilit-patterns-alist.
237;;
238;; Revision 2.8 1993/08/12 22:05:03 stig
239;; fixed some typos in documentation
240;;
241;; twiddled some of the color defaults for dark backgrounds
242;;
243;; always get 'mono color defaults if (not (x-display-color-p))
244;;
245;; added hilit-rehighlight-buffer-quietly to dired-after-readin-hook
246;;
247;; fixed bug in hilit-string-find that mishandled strings of the form: "\\"
248;;
249;; NEW FUNCTION: hilit-add-mode-pattern... kinda like add-hook for patterns
250;;
251;; fixed minor pattern bugs for latex-mode and emacs-lisp-mode
252;;
253;; Revision 2.7 1993/07/30 02:43:01 stig
254;; added const to the list of modifiers for C/C++ types
255;;
256;; Revision 2.6 1993/07/30 00:30:54 stig
257;; now permit selection of arbitrary subexpressions for highlighting...
258;; fixed keyword patterns for C/C++ using this technique.
259;;
260;; Revision 2.5 1993/07/28 05:02:56 stig
261;; improvements to makefile regular expressions
262;; removed about 130 lines just by compacting the big defconst for
263;; hilit-face-translation-table into a mapcar and defining a separate table
264;; of default faces.
265;;
266;; Revision 2.4 1993/07/27 14:09:05 stig
267;; documented another "known problem" to "head off gripe mail at the pass."
268;;
269;; Revision 2.3 1993/07/27 02:15:49 stig
270;; (hilit-lookup-face-create) incorporated patch which improves its behavior
271;; with more than one frame... Still can't have bold on the same face in two
272;; different fonts sizes at the same time...
273;;
274;; Revision 2.2 1993/07/27 02:02:59 stig
275;; vastly improved the makefile patterns
276;; added hook for mh-show-mode
277;;
278;; Revision 2.1 1993/07/24 17:46:21 stig
279;; Phasing out Info-select-hook... Version 19.18 will use Info-selection-hook.
280;;
281;; Revision 2.0 1993/07/24 13:50:10 stig
282;; better documentation and added the function hilit-submit-feedback.
283;; C-S-l (control shift l) repaints the buffer. Other bindings are optional.
284;; multi-line highlights no longer cause problems when
285;; hilit-auto-rehighlight is 'visible
286;; added hilit-predefined-face-list...
287;; changed name of hilit-mode-alist to hilit-patterns-alist
288;; added hilit-message-quietly to mail-setup-hook
289;; added hilit-parser-alist which can be used to apply different patterns to
290;; different parts of a buffer. This could be integrated in a far more
291;; elegant manner, but it presently serves the purpose of not applying
292;; message header patterns to message bodies in mail-mode and its kin.
293;; hilit-set-mode-patterns now takes a list of modes and an optional parse-fn
294;;
295
296;;;;;; AND THIS CAN BE APPLIED TO VM 5.33L_19
297;;
298;; *** ../site/vm5.33L_19/vm-summary.el Fri Jun 4 22:17:11 1993
299;; --- ./vm-summary.el Tue Jun 22 16:39:30 1993
300;; ***************
301;; *** 152,158 ****
302;; (insert "->")
303;; (delete-char 2)
304;; (forward-char -2)
305;; ! (and w vm-auto-center-summary (vm-auto-center-summary))))
306;; (and old-window (select-window old-window)))))))
307;;
308;; (defun vm-mark-for-display-update (message)
309;; --- 152,159 ----
310;; (insert "->")
311;; (delete-char 2)
312;; (forward-char -2)
313;; ! (and w vm-auto-center-summary (vm-auto-center-summary))
314;; ! (run-hooks 'vm-summary-pointer-hook)))
315;; (and old-window (select-window old-window)))))))
316;;
317;; (defun vm-mark-for-display-update (message)
318;;
319;;;;;;
320
321;;; Code:
322
323;; User Options:
324
325(defvar hilit-quietly nil
326 "* If non-nil, this inhibits progress indicators during highlighting")
327
328(defvar hilit-auto-highlight t
329 "* t if we should highlight all buffers as we find 'em, nil to disable
330 automatic highlighting by the find-file hook.")
331
332(defvar hilit-auto-highlight-maxout 60000 ; hilit19 keeps getting bigger...
333 "* auto-highlight is disabled in buffers larger than this")
334
335(defvar hilit-auto-rehighlight t
336 "* If this is non-nil, then hilit-redraw and hilit-recenter will also
337 rehighlight part or all of the current buffer. t will rehighlight the
338 whole buffer, a NUMBER will rehighlight that many lines before and after
339 the cursor, and the symbol 'visible' will rehighlight only the visible
340 portion of the current buffer. This variable is buffer-local.")
341
342(make-variable-buffer-local 'hilit-auto-rehighlight)
343
344(defvar hilit-auto-rehighlight-fallback '(20000 . 100)
345 "* Cons of the form (THRESHOLD . FALLBACK), where FALLBACK is assigned to
346 hilit-auto-rehighlight if the size of a newly opened buffer is larger than
347 THRESHOLD.")
348
349(defvar hilit-face-check t
350 "* t slows down highlighting but permits the user to change fonts without
351 losing bold and italic faces... t causes hilit-lookup-face-create to dig
352 through the frame parameters for the current window every time it's called.
353 If you never change fonts in emacs, set this to nil.")
354
355;; Variables which must be set before loading hilit19.
356
357(defvar hilit-inhibit-rebinding nil
358 "If non-nil, this inhibits replacement of recenter, yank, and yank-pop.")
359
360(defvar hilit-inhibit-hooks nil
361 "If non-nil, this inhibits installation of hooks for Info, gnus, & vm.")
362
363(defvar hilit-background-mode 'light
364 "'mono inhibits color, 'dark or 'light indicate the background brightness.")
365
366(defvar hilit-mode-enable-list nil
367 "If a list of modes to exclusively enable or specifically disable.
368The sense of the list is negated if it begins with the symbol 'not'.
369Set this variable before you load hilit19.
370
371Ex: (perl-mode jargon-mode c-mode) ; just perl, C, and jargon modes
372 (not text-mode) ; all modes except text mode")
373
374;; Variables that are not generally modified directly
375
376(defvar hilit-parser-alist nil
377 "alist of major-mode values and parsers called by hilit-rehighlight-buffer.
378
379Parsers for a given mode are IGNORED for partial rehighlights...maybe you'd
380like to make this more universal?")
381
382(defvar hilit-patterns-alist nil
383 "alist of major-mode values and default highlighting patterns
384
385A highlighting pattern is a list of the form (start end face), where
386start is a regex, end is either a regex or a match number for start, and face
387is the name of an entry in hilit-face-translation-table, the name of a face,
388or nil (which disables the pattern).
389
390Each entry in the alist is of the form:
391 (mode . (case-fold pattern [pattern ...]))
392
393See the hilit-lookup-face-create documentation for valid face names.")
394
395(defvar hilit-predefined-face-list (face-list)
396 "List of faces with which hilit-lookup-face-create will NOT tamper.
397
398If hilit19 is dumped into emacs at your site, you may have to set this in
399your init file.")
400
401;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
402;; Use this to report bugs:
403
404(eval-when-compile (require 'reporter)) ; no compilation gripes
405
406(defun hilit-submit-feedback ()
407 "Submit feedback on hilit19 to hilit@hackvan.com"
408 (interactive)
409 (require 'reporter)
410 (and (y-or-n-p "Do you really want to submit a report on hilit19? ")
411 (reporter-submit-bug-report
412 "bug-gnu-emacs@gnu.org"
413 "hilit19.el (Release 2.19)"
414 (and (y-or-n-p "Do you need to include a dump hilit variables? ")
415 (append
416 '(
417 hilit-quietly hilit-inhibit-hooks
418 hilit-background-mode hilit-mode-enable-list
419 hilit-auto-highlight hilit-auto-highlight-maxout
420 hilit-auto-rehighlight hilit-auto-rehighlight-fallback
421 hilit-face-check
422 )
423 (and (y-or-n-p "Have you modified the standard patterns? ")
424 (yes-or-no-p "Are your patterns *REALLY* relevant? ")
425 '(hilit-parser-alist
426 hilit-patterns-alist
427 hilit-predefined-face-list
428 ))))
429 (function
430 (lambda ()
431 (and (y-or-n-p "Is this a problem with font display? ")
432 (insert "\nFrame Configuration:\n====================\n"
433 (prin1-to-string (frame-configuration-to-register ?F))
434 "\n"
435 ))))
436 nil
437 (concat
438 "This is (check all that apply, and delete what's irrelevant):\n"
439 " [ ] a _MASSIVE_THANK_YOU_ for writing hilit19.el\n"
440 " [ ] An invitation to attend the next Hackers Conference\n"
441 " [ ] You're a RIGHTEOUS HACKER, what are your rates?\n"
442 " [ ] I've used the force and read the source, but I'M CONFUSED\n"
443 " [ ] a PATCH. (output of 'diff -uw old.el new.el' or 'diff -cw')\n"
444 " [ ] a SERIOUS AND REPRODUCIBLE BUG that is not an EMACS bug\n"
445 " - I *swear* that it's not already mentioned in the KNOWN BUGS\n"
446 " - I HAVE CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hilit19.el.gz\n"
447 " for a newer release that fixes the problem.\n"
448 " >> I HAVE ALSO CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hl319.el.gz\n"
449 " This is the alpha version...what will become hilit19 (Beta 3.0).\n"
450 "\n"
451 "Hey Stig, I *know* you're busy but...\n"))))
452
453;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
454;;
455;; These faces are either a valid face name, or nil
456;; if you want to change them, you must do so AFTER hilit19 is loaded
457
458(defconst hilit-default-face-table
459 '(
460 ;; used for C/C++ and Emacs Lisp and perl
461 (comment firebrick-italic moccasin italic)
462 (include purple Plum1 bold-italic)
463 (define ForestGreen-bold green bold)
464 (defun blue-bold cyan-bold bold-italic)
465 (decl RoyalBlue cyan bold)
466 (type nil yellow nil)
467 (keyword RoyalBlue cyan bold-italic)
468 (label red-underline orange-underlined underline)
469 (string grey40 orange underline)
470
471 ;; some further faces for Ada
472 (struct black-bold white-bold bold)
473 (glob-struct magenta Plum1 default-bold-underline)
474 (named-param DarkGoldenrod Goldenrod underline)
475
476 ;; and another one for LaTeX
477 (crossref DarkGoldenrod Goldenrod underline)
478 (formula Goldenrod DarkGoldenrod underline)
479
480 ;; compilation buffers
481 (active-error default/pink-bold default/DeepPink-bold default-underline)
482 (error red-bold yellow bold)
483 (warning blue-italic green italic)
484
485 ;; Makefiles (some faces borrowed from C/C++ too)
486 (rule blue-bold-underline cyan-underline default-bold-underline)
487
488 ;; VM, GNUS and Text mode
489 (msg-subject blue-bold yellow bold)
490 (msg-from purple-bold green bold)
491 (msg-header firebrick-bold cyan italic)
492 (msg-separator black/tan-bold black/lightblue nil)
493 (msg-quote ForestGreen pink italic)
494
495 (summary-seen grey40 white nil)
496 (summary-killed grey50 white nil)
497 (summary-Xed OliveDrab2 green nil)
498 (summary-deleted firebrick white italic)
499 (summary-unread RoyalBlue yellow bold)
500 (summary-new blue-bold yellow-bold bold-italic)
501 (summary-current default/skyblue-bold green/dimgrey-bold reverse-default)
502
503 (gnus-group-unsubscribed grey50 white nil)
504 (gnus-group-empty nil nil nil)
505 (gnus-group-full ForestGreen green italic)
506 (gnus-group-overflowing firebrick red bold-italic)
507
508 ;; dired mode
509 (dired-directory blue-bold cyan bold)
510 (dired-link firebrick-italic green italic)
511 (dired-ignored ForestGreen moccasin nil)
512 (dired-deleted red-bold-italic orange bold-italic)
513 (dired-marked purple Plum1 nil)
514
515 ;; Info-mode, and jargon-mode.el and prep.ai.mit.edu:/pub/gnu/jargon*
516 (jargon-entry blue-bold cyan bold)
517 (jargon-xref purple-bold Plum1 italic)
518 (jargon-keyword firebrick-underline yellow underline)
519 )
520 "alist of default faces (face . (light-default dark-default mono-default))
521
522There is no way for the user to modify this table such that it will have any
523effect upon the translations used by hilit19. Instead, use the function
524hilit-translate AFTER hilit19 has been loaded.
525
526See also the documentation for hilit-lookup-face-create.")
527
528(defconst hilit-face-translation-table
529 (let ((index (or (and (x-display-color-p)
530 (cdr (assq hilit-background-mode
531 '((light . 1) (dark . 2)))))
532 3)))
533 (mapcar (function (lambda (x) (cons (car x) (nth index x))))
534 hilit-default-face-table))
535 "alist that maps symbolic face-names to real face names")
536
537;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
538;; To translate one face to another...
539;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
540
541(defmacro hilit-translate (&rest args)
542 "(hilit-translate FROM TO FROM TO ...): translate each face FROM to the
543value of its TO face. This is like setq for faces.
544
545The function hilit-lookup-face-create will repeatedly translate until no more
546translations for the face exist in the translation table.
547
548See the documentation for hilit-lookup-face-create for names of valid faces."
549 (or (zerop (% (length args) 2))
550 (error "wrong number of args"))
551 (let (cmdl from to)
552 (while args
553 (setq from (car args) to (nth 1 args) args (nthcdr 2 args)
554 cmdl (cons (list 'hilit-associate ''hilit-face-translation-table
555 (list 'quote from) to)
556 cmdl)))
557 (cons 'progn cmdl)))
558
559;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
560;; This function actually translates and then creates the faces...
561;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
562
563(defun hilit-lookup-face-create (face &optional force)
564 "Get a FACE, or create it if it doesn't exist. In order for it to
565properly create the face, the following naming convention must be used:
566 [reverse-](fgcolor[/bgcolor])[-bold][-italic][-underline]
567Example: (hilit-lookup-face-create 'comment-face) might create and return 'red
568
569Each color is either the name of an X color (see .../X11/lib/X11/rgb.txt),
570a hexadecimal specification of the form \"hex-[0-9A-Fa-f]+\", or \"default\".
571
572An optional argument, FORCE, will cause the face to be recopied from the
573default...which is probably of use only if you've changed fonts.
574
575See the documentation for hilit-translate and hilit-face-translation-table."
576
577;; translate the face ...
578 (let ((trec t) visited)
579 (while trec
580 (cond ((memq face visited) (error "face translation loop: %S" visited))
581 (t (setq visited (cons face visited)
582 trec (assq face hilit-face-translation-table))
583 (and trec (setq face (cdr trec)))))))
584
585 ;; make the face if we need to...
586 (let* ((fn (symbol-name face))
587 (frame (selected-frame))
588 (basefont (cdr (assq 'font (frame-parameters frame))))
589 error fgcolor bgcolor)
590 (cond
591 ((or (null face)
592 (memq face hilit-predefined-face-list))
593 ;; do nothing if the face is nil or if it's predefined.
594 )
595 ((or force
596 (not (memq face (face-list)))
597 (and hilit-face-check
598 (not (string= (get face 'basefont) basefont))))
599 (copy-face 'default 'scratch-face)
600 (if (string-match "^reverse-?" fn)
601 (progn (invert-face 'scratch-face)
602 (setq fn (substring fn (match-end 0)))))
603
604 ;; parse foreground color
605 (if (string-match "^\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn)
606 (setq fgcolor (concat
607 (if (match-beginning 1) "#")
608 (substring fn (match-beginning 2) (match-end 2)))
609 fn (substring fn (match-end 0)))
610 (error "bad face name %S" face))
611
612 ;; parse background color
613 (if (string-match "^/\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn)
614 (setq bgcolor (concat
615 (and (match-beginning 1) "#")
616 (substring fn (match-beginning 2) (match-end 2)))
617 fn (substring fn (match-end 0))))
618
619 (and (string= "default" fgcolor) (setq fgcolor nil))
620 (and (string= "default" bgcolor) (setq bgcolor nil))
621
622 ;; catch errors if we can't allocate the color(s)
623 (condition-case nil
624 (progn (and fgcolor (set-face-foreground 'scratch-face fgcolor))
625 (and bgcolor (set-face-background 'scratch-face bgcolor))
626 (copy-face 'scratch-face face)
627 (put face 'basefont basefont))
628 (error (message "couldn't allocate color for '%s'"
629 (symbol-name face))
630 (setq face 'default)
631 (setq error t)))
632 (or error
633 ;; don't bother w/ bold or italic if we didn't get the color
634 ;; we wanted, but ignore errors making the face bold or italic
635 ;; if the font isn't available, there's nothing to do about it...
636 (progn
637 (when (display-graphic-p frame)
638 (set-face-font face basefont frame))
639 (set-face-underline-p face (string-match "underline" fn))
640 (if (string-match ".*bold" fn)
641 ;; make face bold in all frames
642 (make-face-bold face nil 'noerr))
643 (if (string-match ".*italic" fn)
644 ;; make face italic in all frames
645 (make-face-italic face nil 'noerr))
646 ))
647 )))
648 face)
649
650;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
651;; Region Highlight/Unhighlight code (Both overlay and text-property versions)
652;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
653
654(defsubst hilit-region-set-face (start end face-name &optional prio prop)
655 "Highlight region from START to END using FACE and, optionally, PRIO.
656The optional 5th arg, PROP is a property to set instead of 'hilit."
657 (let ((overlay (make-overlay start end)))
658 (overlay-put overlay 'face face-name)
659 (overlay-put overlay (or prop 'hilit) t)
660 (and prio (overlay-put overlay 'priority prio))))
661
662(defun hilit-unhighlight-region (start end &optional quietly)
663 "Unhighlights the region from START to END, optionally in a QUIET way"
664 (interactive "r")
665 (or quietly hilit-quietly (message "Unhighlighting"))
666 (let ((lstart 0))
667 (while (and start (> start lstart) (< start end))
668 (mapc (function (lambda (ovr)
669 (and (overlay-get ovr 'hilit) (delete-overlay ovr))))
670 (overlays-at start))
671 (setq lstart start start (next-overlay-change start))))
672 (or quietly hilit-quietly (message "Done unhighlighting")))
673
674;;;; These functions use text properties instead of overlays. Text properties
675;;;; are copied through kill and yank...which might be convenient, but is not
676;;;; terribly efficient as of 19.12, ERGO it's been disabled
677;;
678;;(defsubst hilit-region-set-face (start end face-name &optional prio prop)
679;; "Highlight region from START to END using FACE and, optionally, PRIO.
680;;The optional 5th arg, PROP is a property to set instead of 'hilit."
681;; (put-text-property start end 'face face-name)
682;; )
683;;
684;;(defun hilit-unhighlight-region (start end &optional quietly)
685;; "Unhighlights the region from START to END, optionally in a QUIET way"
686;; (interactive "r")
687;; (let ((buffer-read-only nil)
688;; (bm (buffer-modified-p)))
689;; (remove-text-properties start end '(face))
690;; (set-buffer-modified-p bm)))
691;;;;
692
693;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
694;; Pattern Application code and user functions
695;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
696
697(defun hilit-highlight-region (start end &optional patterns quietly)
698 "Highlights the area of the buffer between START and END (the region when
699interactive). Without the optional PATTERNS argument, the pattern for
700major-mode is used. If PATTERNS is a symbol, then the patterns associated
701with that symbol are used. QUIETLY suppresses progress messages if
702non-nil."
703 (interactive "r")
704 (cond ((null patterns)
705 (setq patterns (cdr (assq major-mode hilit-patterns-alist))))
706 ((symbolp patterns)
707 (setq patterns (cdr (assq patterns hilit-patterns-alist)))))
708 ;; txt prop: (setq patterns (reverse patterns))
709 (let ((case-fold-search (car patterns))
710 (prio (1- (length patterns)))
711 ;; txt prop: (buffer-read-only nil)
712 ;; txt prop: (bm (buffer-modified-p))
713 p pstart pend face mstart (puke-count 0))
714 ;; txt prop: (unwind-protect
715 (setq patterns (cdr patterns)) ; remove case-fold from head of pattern
716 (save-excursion
717 (save-restriction
718 (narrow-to-region start end)
719 (while patterns
720 (setq p (car patterns))
721 (setq pstart (car p)
722 pend (nth 1 p)
723 face (hilit-lookup-face-create (nth 2 p)))
724 (if (not face) ; skipped if nil
725 nil
726 (or quietly hilit-quietly
727 (message "highlighting %d: %s%s" prio pstart
728 (if (stringp pend) (concat " ... " pend) "")))
729 (goto-char (point-min))
730 (condition-case msg
731 (cond
732 ((symbolp pstart)
733 ;; inner loop -- special function to find pattern
734 (let (region)
735 (while (setq region (funcall pstart pend))
736 (hilit-region-set-face (car region) (cdr region)
737 face prio))))
738 ((stringp pend)
739 ;; inner loop -- regex-start ... regex-end
740 (while (re-search-forward pstart nil t nil)
741 (goto-char (setq mstart (match-beginning 0)))
742 (if (re-search-forward pend nil t nil)
743 (hilit-region-set-face mstart (match-end 0)
744 face prio)
745 (forward-char 1))))
746 ((numberp pend)
747 ;; inner loop -- just one regex to match whole pattern
748 (while (re-search-forward pstart nil t nil)
749 (goto-char (match-end pend))
750 (hilit-region-set-face (match-beginning pend)
751 (match-end pend) face prio)))
752 (t (error "malformed pattern")))
753 (error (if (> (setq puke-count (1+ puke-count)) 1)
754 (error msg)
755 (message "Error: '%s'" msg)
756 (ding) (sit-for 4)))))
757 (setq prio (1- prio)
758 patterns (cdr patterns)))
759 ))
760 (or quietly hilit-quietly (message "")) ; "Done highlighting"
761 ;; txt prop: (set-buffer-modified-p bm)) ; unwind protection
762 ))
763
764(defun hilit-rehighlight-region (start end &optional quietly)
765 "Re-highlights the region, optionally in a QUIET way"
766 (interactive "r")
767 (save-restriction
768 (widen)
769 (setq start (apply 'min start (mapcar 'overlay-start (overlays-at start)))
770 end (apply 'max end (mapcar 'overlay-end (overlays-at end))))
771 (hilit-unhighlight-region start end quietly)
772 (hilit-highlight-region start end nil quietly)))
773
774(defun hilit-rehighlight-buffer (&optional quietly)
775 "Re-highlights the buffer, optionally in a QUIET way"
776 (interactive "")
777 (let ((parse-fn (cdr (assq major-mode hilit-parser-alist))))
778 (if parse-fn
779 (funcall parse-fn quietly)
780 (hilit-rehighlight-region (point-min) (point-max) quietly)))
781 nil)
782
783(defun hilit-rehighlight-buffer-quietly ()
784 (hilit-rehighlight-buffer t))
785
786(defun hilit-rehighlight-message (quietly)
787 "Highlight a buffer containing a news article or mail message."
788 (save-excursion
789 (goto-char (point-min))
790 ;; find separation between headers and body (either a blank line or
791 ;; the message separator line in mail-mode)
792 (re-search-forward "^\\(\\|--text follows this line--\\)$" nil 'noerr)
793 (hilit-unhighlight-region (point-min) (point-max) quietly)
794 (hilit-highlight-region (point-min) (point) 'msg-header quietly)
795 (hilit-highlight-region (point) (point-max) 'msg-body quietly)))
796
797(defalias 'hilit-highlight-buffer 'hilit-rehighlight-buffer)
798
799;; Well, I want to remove this function...there's one sure way to find out if
800;; anyone uses it or not...and that's to comment it out.
801;;
802;; (defun hilit-toggle-highlight (arg)
803;; "Locally toggle highlighting. With arg, forces highlighting off."
804;; (interactive "P")
805;; ;; FIXME -- this loses numeric information in hilit-auto-rehighlight
806;; (setq hilit-auto-rehighlight
807;; (and (not arg) (not hilit-auto-rehighlight)))
808;; (if hilit-auto-rehighlight
809;; (hilit-rehighlight-buffer)
810;; (hilit-unhighlight-region (point-min) (point-max)))
811;; (message "Rehighlighting is set to %s" hilit-auto-rehighlight))
812
813;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
814;; HOOKS
815;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
816
817(defun hilit-find-file-hook ()
818 "Find-file hook for hilit package. See the variable hilit-auto-highlight."
819 (cond ((and hilit-auto-highlight
820 (assq major-mode hilit-patterns-alist))
821 (if (> buffer-saved-size (car hilit-auto-rehighlight-fallback))
822 (setq hilit-auto-rehighlight
823 (cdr hilit-auto-rehighlight-fallback)))
824 (if (> buffer-saved-size hilit-auto-highlight-maxout)
825 nil
826 (let ((bm (buffer-modified-p)))
827 (hilit-rehighlight-buffer)
828 (set-buffer-modified-p bm))))))
829
830(defun hilit-repaint-command (arg)
831 "Rehighlights according to the value of hilit-auto-rehighlight, or the
832prefix argument if that is specified.
833\t\\[hilit-repaint-command]\t\trepaint according to hilit-auto-rehighlight
834\t^U \\[hilit-repaint-command]\trepaint entire buffer
835\t^U - \\[hilit-repaint-command]\trepaint visible portion of buffer
836\t^U n \\[hilit-repaint-command]\trepaint n lines to either side of point"
837 (interactive "P")
838 (let (st en quietly)
839 (or arg (setq arg hilit-auto-rehighlight))
840 (cond ((or (eq arg 'visible) (eq arg '-))
841 (setq st (window-start) en (window-end) quietly t))
842 ((numberp arg)
843 (setq st (save-excursion (forward-line (- arg)) (point))
844 en (save-excursion (forward-line arg) (point))))
845 (arg
846 (hilit-rehighlight-buffer)))
847 (if st
848 (hilit-rehighlight-region st en quietly))))
849
850(defun hilit-recenter (arg)
851 "Recenter, then rehighlight according to hilit-auto-rehighlight. If called
852with an unspecified prefix argument (^U but no number), then a rehighlight of
853the entire buffer is forced."
854 (interactive "P")
855 (recenter arg)
856 ;; force display update
857 (sit-for 0)
858 (hilit-repaint-command (consp arg)))
859
860(defun hilit-yank (arg)
861 "Yank with rehighlighting"
862 (interactive "*P")
863 (let ((transient-mark-mode nil))
864 (yank arg)
865 (and hilit-auto-rehighlight
866 (hilit-rehighlight-region (region-beginning) (region-end) t))
867 (setq this-command 'yank)))
868
869(defun hilit-yank-pop (arg)
870 "Yank-pop with rehighlighting"
871 (interactive "*p")
872 (let ((transient-mark-mode nil))
873 (yank-pop arg)
874 (and hilit-auto-rehighlight
875 (hilit-rehighlight-region (region-beginning) (region-end) t))
876 (setq this-command 'yank)))
877
878;;; this line highlighting stuff is untested. play with it only if you feel
879;;; adventurous...don't ask me to fix it...though you're welcome to. -- Stig
880;;
881;; (defun hilit-rehighlight-line-quietly (&rest args)
882;; "Quietly rehighlight just this line.
883;; Useful as an after change hook in VM/gnus summary buffers and dired buffers.
884;; If only there were an after-change-function, that is..."
885;; (save-excursion
886;; (push-mark nil t)
887;; (hilit-rehighlight-yank-region)
888;; (and orig-achange-function (apply orig-achange-function args))))
889;;
890;; (defun hilit-install-line-hooks ()
891;; (make-variable-buffer-local 'after-change-function)
892;; (make-local-variable 'orig-achange-function)
893;; (setq orig-achange-function after-change-function)
894;; (setq after-change-function 'hilit-rehighlight-line-quietly))
895
896;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
897;; Wysiwyg Stuff... take it away and build a whole package around it!
898;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
899;;
900;; ; For the Jargon-impaired, WYSIWYG === What You See Is What You Get
901;; ; Sure, it sucks to type. Oh, well.
902;; (defun hilit-wysiwyg-replace ()
903;; "Replace overstruck text with normal text that's been overlaid with the
904;; appropriate text attribute. Suitable for a find-file hook."
905;; (save-excursion
906;; (goto-char (point-min))
907;; (let ((wysb (hilit-lookup-face-create 'wysiwyg-bold))
908;; (wysu (hilit-lookup-face-create 'wysiwyg-underline))
909;; (bmod (buffer-modified-p)))
910;; (while (re-search-forward "\\(.\b.\\)+" nil t)
911;; (let ((st (match-beginning 0)) (en (match-end 0)))
912;; (goto-char st)
913;; (if (looking-at "_")
914;; (hilit-region-set-face st en wysu 100 'wysiwyg)
915;; (hilit-region-set-face st en wysb 100 'wysiwyg))
916;; (while (and (< (point) en) (looking-at ".\b"))
917;; (replace-match "") (forward-char))
918;; ))
919;; (set-buffer-modified-p bmod))))
920;;
921;; ; is this more appropriate as a write-file-hook or a write-contents-hook?
922;; (defun hilit-wysiwyg-write-repair ()
923;; "Replace wysiwyg overlays with overstrike text."
924;; (message "*sigh* hilit-wysiwyg-write-repair not implemented yet")
925;;
926;; For efficiency, this hook should copy the current buffer to a scratch
927;; buffer and do its overstriking there. Overlays are not copied, so it'll
928;; be necessary to hop back and forth. This is OK since you're not fiddling
929;; with--making or deleting--any overlays. THEN write the new buffer,
930;; delete it, and RETURN T. << important
931;;
932;; Just so you know...there is already an emacs function called
933;; underline-region that does underlining. I think that the thing to do is
934;; extend that to do overstriking as well.
935;;
936;; (while (< start end)
937;; (mapcar (function (lambda (ovr)
938;; (and (overlay-get ovr 'hilit) (delete-overlay ovr))))
939;; (overlays-at start))
940;; (setq start (next-overlay-change start)))
941;; nil)
942
943;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
944;; Initialization.
945;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
946
947(define-minor-mode hilit-mode
948 "Obsolete minor mode. Use `global-font-lock-mode' instead."
949 :global t
950
951 (unless (and hilit-inhibit-rebinding hilit-mode)
952 (substitute-key-definition
953 (if hilit-mode 'yank 'hilit-yank)
954 (if hilit-mode 'hilit-yank 'yank)
955 (current-global-map))
956 (substitute-key-definition
957 (if hilit-mode 'yank-pop 'hilit-yank-pop)
958 (if hilit-mode 'hilit-yank-pop 'yank-pop)
959 (current-global-map))
960 (substitute-key-definition
961 (if hilit-mode 'recenter 'hilit-recenter)
962 (if hilit-mode 'hilit-recenter 'recenter)
963 (current-global-map)))
964
965 (if hilit-mode
966 (global-set-key [?\C-\S-l] 'hilit-repaint-command)
967 (global-unset-key [?\C-\S-l]))
968
969 (if hilit-mode
970 (add-hook 'find-file-hook 'hilit-find-file-hook t)
971 (remove-hook 'find-file-hook 'hilit-find-file-hook))
972
973 (unless (and hilit-inhibit-hooks hilit-mode)
974 (condition-case c
975 (progn
976
977 ;; BUFFER highlights...
978 (mapc (lambda (hook)
979 (if hilit-mode
980 (add-hook hook 'hilit-rehighlight-buffer-quietly)
981 (remove-hook hook 'hilit-rehighlight-buffer-quietly)))
982 '(
983 Info-selection-hook
984
985 ;; runs too early vm-summary-mode-hooks
986 vm-summary-pointer-hook
987 vm-preview-message-hook
988 vm-show-message-hook
989
990 rmail-show-message-hook
991 mail-setup-hook
992 mh-show-mode-hook
993
994 dired-after-readin-hook
995 ))
996 )
997 (error (message "Error loading highlight hooks: %s" c)
998 (ding) (sit-for 1)))))
999
1000(eval-when-compile (require 'gnus)) ; no compilation gripes
1001
1002;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1003;; Default patterns for various modes.
1004;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1005
1006;;; do I need this? I changed the defconst to a defvar because defconst is
1007;;; inappropriate, but I don't know why I wanted hilit-patterns-alist to be
1008;;; reset on every reload...
1009
1010(setq hilit-patterns-alist nil)
1011
1012(defun hilit-associate (alist key val)
1013 "creates, or destructively replaces, the pair (key . val) in alist"
1014 (let ((oldentry (assq key (eval alist))))
1015 (if oldentry
1016 (setcdr oldentry val)
1017 (set alist (cons (cons key val) (eval alist))))))
1018
1019(defun hilit-set-mode-patterns (modelist patterns
1020 &optional parse-fn case-fold)
1021 "Sets the default highlighting patterns for MODE to PATTERNS.
1022See the variable hilit-mode-enable-list.
1023
1024Takes optional arguments PARSE-FN and CASE-FOLD."
1025 ;; change pattern
1026 (mapc (function (lambda (p)
1027 (and (stringp (car p))
1028 (null (nth 1 p))
1029 (setcar (cdr p) 0))))
1030 patterns)
1031 (setq patterns (cons case-fold patterns))
1032
1033 (or (consp modelist) (setq modelist (list modelist)))
1034 (let (ok (flip (eq (car hilit-mode-enable-list) 'not)))
1035 (mapcar (function
1036 (lambda (m)
1037 (setq ok (or (null hilit-mode-enable-list)
1038 (memq m hilit-mode-enable-list)))
1039 (and flip (setq ok (not ok)))
1040 (and ok
1041 (progn
1042 (and parse-fn
1043 (hilit-associate 'hilit-parser-alist m parse-fn))
1044 (hilit-associate 'hilit-patterns-alist m patterns)))))
1045 modelist)))
1046
1047(defun hilit-add-pattern (pstart pend face &optional mode first)
1048 "Highlight pstart with face for the current major-mode.
1049Optionally, place the new pattern first in the pattern list"
1050 (interactive "sPattern start regex: \nsPattern end regex (default none): \nxFace: ")
1051
1052 (and (equal pstart "") (error "Must specify starting regex"))
1053 (cond ((equal pend "") (setq pend 0))
1054 ((string-match "^[0-9]+$" pend) (setq pend (string-to-number pend))))
1055 (or mode (setq mode major-mode))
1056 (let ((old-patterns (cdr (assq mode hilit-patterns-alist)))
1057 (new-pat (list pstart pend face)))
1058 (cond ((not old-patterns)
1059 (hilit-set-mode-patterns mode (list new-pat)))
1060 (first
1061 (setcdr old-patterns (cons new-pat (cdr old-patterns))))
1062 (t
1063 (nconc old-patterns (list new-pat)))))
1064 (and (interactive-p) (hilit-rehighlight-buffer)))
1065
1066(defun hilit-string-find (qchar)
1067 "Looks for a string and returns (start . end) or nil. The argument QCHAR
1068is the character that would precede a character constant double quote.
1069Finds strings delimited by double quotes. The first double quote may not be
1070preceded by QCHAR and the closing double quote may not be preceded by an odd
1071number of backslashes."
1072 (let (st en)
1073 (while (and (search-forward "\"" nil t)
1074 (eq qchar (char-after (1- (setq st (match-beginning 0)))))))
1075 (while (and (search-forward "\"" nil t)
1076 (save-excursion
1077 (setq en (point))
1078 (forward-char -1)
1079 (skip-chars-backward "\\\\")
1080 (forward-char 1)
1081 (not (zerop (% (- en (point)) 2))))))
1082 (and en (cons st en))))
1083
1084;; return types on same line...
1085;; ("^[a-zA-z].*\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1086
1087;; On another note, a working pattern for grabbing function definitions for C is
1088;;
1089;; ("^[a-zA-Z_]+.*[;{]$" nil ForestGreen) ; global defns ( start at col 1 )
1090;; ("^[a-zA-Z_]+.*(" ")" defun)
1091;; ; defuns assumed to start at col 1, not with # or {
1092;;
1093;; this will make external declarations/definitions green, and function
1094;; definitions the defun face. Hmmm - seems to work for me anyway.
1095
1096(let ((comments '(("/\\*" "\\*/" comment)))
1097 (c++-comments '(("//.*$" nil comment)
1098 ("^/.*$" nil comment)))
1099 (strings '((hilit-string-find ?' string)))
1100 (preprocessor '(("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define)
1101 ("^#.*$" nil include))))
1102
1103 (hilit-set-mode-patterns
1104 '(c-mode c++-c-mode elec-c-mode)
1105 (append
1106 comments strings preprocessor
1107 '(
1108 ;; function decls are expected to have types on the previous line
1109 ("^\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1110 ("^\\(typedef\\|struct\\|union\\|enum\\).*$" nil decl)
1111 ;; datatype -- black magic regular expression
1112 ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type)
1113 ;; key words
1114 ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\)\\>[^_]" 1 keyword)
1115 )))
1116
1117 (hilit-set-mode-patterns
1118 'c++-mode
1119 (append
1120 comments c++-comments strings preprocessor
1121 '(
1122 ;; function decls are expected to have types on the previous line
1123 ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1124 ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1125 ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl)
1126 ;; datatype -- black magic regular expression
1127 ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\|class\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type)
1128 ;; key words
1129 ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|delete\\|new\\)\\>[^_]"
1130 1 keyword))))
1131
1132 (hilit-set-mode-patterns
1133 '(objc-mode objective-C-mode)
1134 (append
1135 comments c++-comments strings preprocessor
1136 '(
1137 ;; function decls are expected to have types on the previous line
1138 ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1139 ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
1140
1141 ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl)
1142 ;; datatype -- black magic regular expression
1143 ("[ \n\t({]\\(\\(const\\|register\\|volatile\\|unsigned\\|extern\\|static\\)\\s +\\)*\\(\\(\\w\\|[$_]\\)+_t\\|float\\|double\\|void\\|char\\|short\\|int\\|long\\|FILE\\|\\(\\(struct\\|union\\|enum\\|class\\)\\([ \t]+\\(\\w\\|[$_]\\)*\\)\\)\\)\\(\\s +\\*+)?\\|[ \n\t;()]\\)" nil type)
1144 ;; key words
1145 ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|interface\\|implementation\\|end\\|super\\|self\\)\\>[^_]"
1146 1 keyword))))
1147 )
1148
1149(hilit-set-mode-patterns
1150 'perl-mode
1151 '(("\\s #.*$" nil comment)
1152 ("^#.*$" nil comment)
1153 ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string)
1154 ("^\\(__....?__\\|\\s *\\sw+:\\)" nil label)
1155 ("^require.*$" nil include)
1156 ("^package.*$" nil decl)
1157 ("^\\s *sub\\s +\\(\\w\\|[_']\\)+" nil defun)
1158 ("\\b\\(do\\|if\\|unless\\|while\\|until\\|else\\|elsif\\|for\\|foreach\\|continue\\|next\\|redo\\|last\\|goto\\|return\\|die\\|exit\\)\\b" nil keyword)))
1159
1160(hilit-set-mode-patterns
1161 'ada-mode
1162 '(;; comments
1163 ("--.*$" nil comment)
1164 ;; main structure
1165 ("[ \t\n]procedure[ \t]" "\\([ \t]\\(is\\|renames\\)\\|);\\)" glob-struct)
1166 ("[ \t\n]task[ \t]" "[ \t]is" glob-struct)
1167 ("[ \t\n]function[ \t]" "return[ \t]+[A-Za-z_0-9]+[ \t]*\\(is\\|;\\|renames\\)" glob-struct)
1168 ("[ \t\n]package[ \t]" "[ \t]\\(is\\|renames\\)" glob-struct)
1169 ;; if there is nothing before "private", it is part of the structure
1170 ("^[ \t]*private[ \t\n]" nil glob-struct)
1171 ;; if there is no indentation before the "end", then it is most
1172 ;; probably the end of the package
1173 ("^end.*$" ";" glob-struct)
1174 ;; program structure -- "null", "delay" and "terminate" omitted
1175 ("[ \n\t]\\(in\\|out\\|select\\|if\\|else\\|case\\|when\\|and\\|or\\|not\\|accept\\|loop\\|do\\|then\\|elsif\\|else\\|for\\|while\\|exit\\)[ \n\t;]" nil struct)
1176 ;; block structure
1177 ("[ \n\t]\\(begin\\|end\\|declare\\|exception\\|generic\\|raise\\|return\\|package\\|body\\)[ \n\t;]" nil struct)
1178 ;; type declaration
1179 ("^[ \t]*\\(type\\|subtype\\).*$" ";" decl)
1180 ("[ \t]+is record.*$" "end record;" decl)
1181 ;; "pragma", "with", and "use" are close to C cpp directives
1182 ("^[ \t]*\\(with\\|pragma\\|use\\)" ";" include)
1183 ;; nice for named parameters, but not so beautiful in case statements
1184 ("[A-Za-z_0-9.]+[ \t]*=>" nil named-param)
1185 ;; string constants probably not everybody likes this one
1186 ("\"" ".*\"" string)))
1187
1188(hilit-set-mode-patterns
1189 'fortran-mode
1190 '(("^[*Cc].*$" nil comment)
1191 ("'[^'\n]*'" nil string)
1192 ("\\(^[ \t]*[0-9]+\\|[ \t]continue[ \t\n]\\|format\\)" nil define)
1193 ("[ \t]\\(do\\|do[ \t]*[0-9]+\\|go[ \t]*to[ \t]*[0-9]+\\|end[ \t]*do\\|if\\|else[ \t]*if\\|then\\|else\\|end[ \t]*if\\)[ \t\n(]" nil define)
1194 ("[ \t]\\(call\\|program\\|subroutine\\|function\\|stop\\|return\\|end\\|include\\)[ \t\n]" nil include)
1195 ("[ \t]\\(parameter[\t\n ]*([^)]*)\\|data\\|save\\|common[ \t\n]*/[^/]*/\\)"
1196 nil decl)
1197 ("^ ." nil type)
1198 ("implicit[ \t]*none" nil decl)
1199 ("\\([ \t]\\|implicit[ \t]*\\)\\(dimension\\|integer\\|real\\|double[ \t]*precision\\|character\\|logical\\|complex\\|double[ \t]*complex\\)\\([*][0-9]*\\|[ \t\n]\\)" nil keyword)
1200 )
1201 nil 'case-insensitive)
1202
1203(hilit-set-mode-patterns
1204 '(m2-mode modula-2-mode)
1205 '(("(\\*" "\\*)" comment)
1206 (hilit-string-find ?\\ string)
1207 ("^[ \t]*PROCEDURE[ \t]+\\w+[^ \t(;]*" nil defun)
1208 ("\\<\\(RECORD\\|ARRAY\\|OF\\|POINTER\\|TO\\|BEGIN\\|END\\|FOR\\|IF\\|THEN\\|ELSE\\|ELSIF\\|CASE\\|WHILE\\|DO\\|MODULE\\|FROM\\|RETURN\\|IMPORT\\|EXPORT\\|VAR\\|LOOP\\|UNTIL\\|\\DEFINITION\\|IMPLEMENTATION\\|AND\\|OR\\|NOT\\|CONST\\|TYPE\\|QUALIFIED\\)\\>" nil keyword)
1209 )
1210 nil 'case-insensitive)
1211
1212(hilit-set-mode-patterns 'prolog-mode
1213 '(("/\\*" "\\*/" comment)
1214 ("%.*$" nil comment)
1215 (":-" nil defun)
1216 ("!" nil label)
1217 ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string)
1218 ("\\b\\(is\\|mod\\)\\b" nil keyword)
1219 ("\\(->\\|-->\\|;\\|==\\|\\\\==\\|=<\\|>=\\|<\\|>\\|=\\|\\\\=\\|=:=\\|=\\\.\\\.\\|\\\\\\\+\\)" nil decl)
1220 ("\\(\\\[\\||\\|\\\]\\)" nil include)))
1221
1222(hilit-set-mode-patterns
1223 '(
1224 LaTeX-mode japanese-LaTeX-mode SliTeX-mode
1225 japanese-SliTeX-mode FoilTeX-mode latex-mode
1226 )
1227 '(
1228 ;; comments
1229 ("[^\\]%.*$" nil comment)
1230
1231 ;; the following two match \foo[xx]{xx} or \foo*{xx} or \foo{xx}
1232 ("\\\\\\(sub\\)*\\(paragraph\\|section\\)\\(\*\\|\\[.*\\]\\)?{" "}"
1233 keyword)
1234 ("\\\\\\(chapter\\|part\\)\\(\*\\|\\[.*\\]\\)?{" "}" keyword)
1235 ("\\\\footnote\\(mark\\|text\\)?{" "}" keyword)
1236 ("\\\\[a-z]+box" nil keyword)
1237 ("\\\\\\(v\\|h\\)space\\(\*\\)?{" "}" keyword)
1238
1239 ;; (re-)define new commands/environments/counters
1240 ("\\\\\\(re\\)?new\\(environment\\|command\\){" "}" defun)
1241 ("\\\\new\\(length\\|theorem\\|counter\\){" "}" defun)
1242
1243 ;; various declarations/definitions
1244 ("\\\\\\(setlength\\|settowidth\\|addtolength\\|setcounter\\|addtocounter\\)" nil define)
1245 ("\\\\\\(title\\|author\\|date\\|thanks\\){" "}" define)
1246
1247 ("\\\\documentstyle\\(\\[.*\\]\\)?{" "}" decl)
1248 ("\\\\\\(begin\\|end\\|nofiles\\|includeonly\\){" "}" decl)
1249 ("\\\\\\(raggedright\\|makeindex\\|makeglossary\\|maketitle\\)\\b" nil
1250 decl)
1251 ("\\\\\\(pagestyle\\|thispagestyle\\|pagenumbering\\){" "}" decl)
1252 ("\\\\\\(normalsize\\|small\\|footnotesize\\|scriptsize\\|tiny\\|large\\|Large\\|LARGE\\|huge\\|Huge\\)\\b" nil decl)
1253 ("\\\\\\(appendix\\|tableofcontents\\|listoffigures\\|listoftables\\)\\b"
1254 nil decl)
1255 ("\\\\\\(bf\\|em\\|it\\|rm\\|sf\\|sl\\|ss\\|tt\\)\\b" nil decl)
1256
1257 ;; label-like things
1258 ("\\\\item\\(\\[[^]]*\\]\\)?" nil label)
1259 ("\\\\caption\\(\\[[^]]*\\]\\)?{" "}" label)
1260
1261 ;; formulas
1262 ("[^\\]\\\\(" "\\\\)" formula) ; \( \)
1263 ("[^\\]\\\\\\[" "\\\\\\]" formula) ; \[ \]
1264 ("[^\\$]\\(\\$\\(\\$[^$]*\\$\\|[^$]*\\)\\$\\)" 1 formula) ; '$...$' or '$$...$$'
1265
1266 ;; things that bring in external files
1267 ("\\\\\\(include\\|input\\|bibliography\\){" "}" include)
1268
1269 ;; "wysiwyg" emphasis -- these don't work with nested expressions
1270 ;; ("{\\\\\\(em\\|it\\|sl\\)" "}" italic)
1271 ;; ("{\\\\bf" "}" bold)
1272
1273 ("``" "''" string)
1274
1275 ;; things that do some sort of cross-reference
1276 ("\\\\\\(\\(no\\)?cite\\|\\(page\\)?ref\\|label\\|index\\|glossary\\){" "}" crossref)
1277 ))
1278
1279(hilit-set-mode-patterns
1280 'bibtex-mode
1281 '(;;(";.*$" nil comment)
1282 ("%.*$" nil comment)
1283 ("@[a-zA-Z]+" nil keyword)
1284 ("{[ \t]*[-a-z:_A-Z0-9]+," nil label) ; is wrong sometimes
1285 ("^[ \t]*[a-zA-Z]+[ \t]*=" nil define)))
1286
1287(hilit-set-mode-patterns
1288 'compilation-mode
1289 '(
1290 ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+: warning:.*$" nil warning)
1291 ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+:.*$" nil error)
1292 ))
1293
1294(hilit-set-mode-patterns
1295 'makefile-mode
1296 '(("^#.*$" nil comment)
1297 ("[^$]#.*$" nil comment)
1298 ;; rules
1299 ("^[^ \t\n]*%[^ \t\n]*[ \t]*::?[ \t]*[^ \t\n]*[ \t]*\\(#.*\\)?$" nil rule)
1300 ("^[.][A-Za-z][A-Za-z]?\..*$" nil rule)
1301 ;; variable definition
1302 ("^[_A-Za-z0-9]+[ \t]*\+?=" nil define)
1303 ("\\( \\|:=\\)[_A-Za-z0-9]+[ \t]*\\+=" nil define)
1304 ;; variable references
1305 ("\\$\\([^ \t\n{(]\\|[{(]@?[_A-Za-z0-9:.,%/=]+[)}]\\)" nil keyword)
1306 ("^[A-Za-z0-9.,/_-]+[ \t]*:.*$" nil defun)
1307 ("^include " nil include)))
1308
1309(let* ((header-patterns '(("^Subject:.*$" nil msg-subject)
1310 ("^From:.*$" nil msg-from)
1311 ("^--text follows this line--$" nil msg-separator)
1312 ("^[A-Za-z][A-Za-z0-9-]+:" nil msg-header)))
1313 (body-patterns '(("^\\(In article\\|[ \t]*\\w*[]<>}|]\\).*$"
1314 nil msg-quote)))
1315 (message-patterns (append header-patterns body-patterns)))
1316 (hilit-set-mode-patterns 'msg-header header-patterns)
1317 (hilit-set-mode-patterns 'msg-body body-patterns)
1318 (hilit-set-mode-patterns '(vm-mode text-mode mail-mode rmail-mode
1319 gnus-article-mode news-reply-mode mh-show-mode)
1320 message-patterns
1321 'hilit-rehighlight-message))
1322
1323(hilit-set-mode-patterns
1324 'gnus-group-mode
1325 '(("^ U.*$" nil gnus-group-unsubscribed)
1326 ("^\\*? +[01]?[0-9]:.*$" nil gnus-group-empty)
1327 ("^ +[2-9][0-9]:.*$" nil gnus-group-full)
1328 ("^ +[0-9][0-9][0-9]+:.*$" nil gnus-group-overflowing)))
1329
1330(hilit-set-mode-patterns
1331 'vm-summary-mode
1332 '(("^ .*$" nil summary-seen)
1333 ("^->.*$" nil summary-current)
1334 ("^ D.*$" nil summary-deleted)
1335 ("^ U.*$" nil summary-unread)
1336 ("^ N.*$" nil summary-new)))
1337
1338
1339;;; this will match only comments w/ an even (zero is even) number of quotes...
1340;;; which is still inadequate because it matches comments in multi-line strings
1341;;; how anal do you want to get about never highlighting comments in strings?
1342;;; I could twiddle with this forever and still it wouldn't be perfect.
1343;;; (";\\([^\"\n]*\"[^\"\n]*\"\\)*[^\"\n]*$" nil comment)
1344
1345(hilit-set-mode-patterns
1346 '(emacs-lisp-mode lisp-interaction-mode)
1347 '(
1348 (";.*" nil comment)
1349
1350;;; This almost works...but I think I'll stick with the parser function
1351;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string)
1352 (hilit-string-find ?\\ string)
1353
1354 ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|subst\\)[ \t\n]"
1355 "\\()\\|nil\\)" defun)
1356 ("^\\s *(defvar\\s +\\S +" nil decl)
1357 ("^\\s *(defconst\\s +\\S +" nil define)
1358 ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include)
1359 ("\\s *\\&\\(rest\\|optional\\)\\s *" nil keyword)
1360 ("(\\(let\\*?\\|cond\\|if\\|or\\|and\\|map\\(car\\|concat\\)\\|prog[n1*]?\\|while\\|lambda\\|function\\|set\\([qf]\\|car\\|cdr\\)?\\|nconc\\|eval-when-compile\\|condition-case\\|unwind-protect\\|catch\\|throw\\|error\\)[ \t\n]" 1 keyword)
1361 ))
1362
1363(hilit-set-mode-patterns
1364 '(lisp-mode ilisp-mode)
1365 '(
1366 (";.*" nil comment)
1367 ("#|" "|#" comment)
1368;;; This almost works...but I think I'll stick with the parser function
1369;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string)
1370 (hilit-string-find ?\\ string)
1371
1372 ;; this is waaaaaaaay too slow
1373 ;; ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|method\\|subst\\)\\s \\S +[ \t\n]+\\(nil\\|(\\(([^()]*)\\|[^()]+\\)*)\\)" nil defun)
1374 ("^\\s *(def\\(un\\|macro\\|advice\\|subst\\|method\\)\\s " "\\()\\|nil\\)" defun)
1375
1376 ("^\\s *(\\(def\\(var\\|type\\|parameter\\)\\|declare\\)\\s +\\S +" nil decl)
1377 ("^\\s *(def\\(const\\(ant\\)?\\|class\\|struct\\)\\s \\S +[ \t\n]+" nil define)
1378 ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include)
1379 ("[ \t]\\&\\(key\\|rest\\|optional\\|aux\\)\\s *" nil keyword)
1380 ("(\\(let\\*?\\|locally\\|cond\\|if\\*?\\|or\\|and\\|map\\(car\\|c[ao]n\\)?\\|prog[nv1*]?\\|while\\|when\\|unless\\|do\\(\\*\\|list\\|times\\)\\|list\\|lambda\\|function\\|values\\|set\\([qf]\\|car\\|cdr\\)?\\|rplac[ad]\\|nconc\\|block\\|go\\|return\\(-from\\)?\\|[ec]?\\(type\\)?case\\|multiple-value-\\(bind\\|setq\\|list\\|call\\|prog1\\)\\|unwind-protect\\|handler-case\\|catch\\|throw\\|eval-when\\(-compile\\)?\\)[ \t\n]" 1 keyword)
1381 ))
1382
1383
1384(hilit-set-mode-patterns
1385 'plain-tex-mode
1386 '(("^%%.*$" nil comment)
1387 ("{\\\\em\\([^}]+\\)}" nil comment)
1388 ("\\(\\\\\\w+\\)" nil keyword)
1389 ("{\\\\bf\\([^}]+\\)}" nil keyword)
1390 ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" nil defun)
1391 ("\\\\\\(begin\\|end\\){\\([A-Za-z0-9\\*]+\\)}" nil defun)
1392 ;; ("[^\\\\]\\$\\([^$]*\\)\\$" nil string)
1393 ("\\$\\([^$]*\\)\\$" nil string)
1394 ))
1395
1396;; Reasonable extensions would include smarter parameter handling for such
1397;; things as the .IX and .I macros, which alternate the handling of following
1398;; arguments.
1399
1400(hilit-set-mode-patterns
1401 'nroff-mode
1402 '(("^\\.[\\\][\\\"].*$" nil comment)
1403 ("^\\.so .*$" nil include)
1404 ("^\\.[ST]H.*$" nil defun)
1405;; ("^[^\\.].*\"[^\\\"]*\\(\\\\\\(.\\)[^\\\"]*\\)*\"" nil string)
1406 ("\"" "[^\\]\"" string)
1407 ("^\\.[A-Z12\\\\].*$" nil define)
1408 ("\\([\\\][^ ]*\\)" nil keyword)
1409 ("^\\.[A-Z].*$" nil keyword))
1410 nil 'case-insensitive)
1411
1412(hilit-set-mode-patterns
1413 'texinfo-mode
1414 '(("^\\(@c\\|@comment\\)\\>.*$" nil comment)
1415 ("@\\(emph\\|strong\\|b\\|i\\){[^}]+}" nil comment)
1416;; seems broken
1417;; ("\\$[^$]*\\$" nil string)
1418 ("@\\(file\\|kbd\\|key\\){[^}]+}" nil string)
1419 ("^\\*.*$" nil defun)
1420 ("@\\(if\\w+\\|format\\|item\\)\\b.*$" nil defun)
1421 ("@end +[A-Za-z0-9]+[ \t]*$" nil defun)
1422 ("@\\(samp\\|code\\|var\\){[^}]+}" nil defun)
1423 ("@\\w+\\({[^}]+}\\)?" nil keyword)
1424 ))
1425
1426(hilit-set-mode-patterns
1427 'dired-mode
1428 (append
1429 '(("^D.*$" nil dired-deleted)
1430 ("^\\*.*$" nil dired-marked)
1431 ("^ d.*$" nil dired-directory)
1432 ("^ l.*$" nil dired-link)
1433 ("^ -.*#.*#$" nil dired-ignored))
1434 (list (cons
1435 (concat "^ .*\\("
1436 (mapconcat 'regexp-quote completion-ignored-extensions "\\|")
1437 "\\)$")
1438 '(nil dired-ignored)))))
1439
1440(hilit-set-mode-patterns
1441 'jargon-mode
1442 '(("^:[^:]*:" nil jargon-entry)
1443 ("{[^}]*}+" nil jargon-xref)))
1444
1445(hilit-set-mode-patterns
1446 'Info-mode
1447 '(("^\\* [^:]+:+" nil jargon-entry)
1448 ("\\*[Nn]ote\\b[^:]+:+" nil jargon-xref)
1449 (" \\(Next\\|Prev\\|Up\\):" nil jargon-xref)
1450 ("- \\(Variable\\|Function\\|Macro\\|Command\\|Special Form\\|User Option\\):.*$"
1451 nil jargon-keyword))) ; lisp manual
1452
1453(hilit-set-mode-patterns
1454 'calendar-mode
1455 '(("[A-Z][a-z]+ [0-9]+" nil define) ; month and year
1456 ("S M Tu W Th F S" nil label))) ; week days
1457
1458(hilit-set-mode-patterns
1459 'asm-mode
1460 '(("/\\*" "\\*/" comment)
1461 ("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define)
1462 ("^#.*$" nil include)
1463 ;; labels
1464 ("^.+:" nil defun)
1465 ;; assembler directives
1466 ("^[ \t]*\\..*$" nil decl)
1467 ;; register names
1468 ("\\$[a-z0-9]+" nil string)
1469 ;; mnemonics
1470 ("^[ \t]*[a-z]+" nil struct)))
1471
1472(hilit-set-mode-patterns
1473 'pascal-mode
1474 '(("(\\*" "\\*)" comment)
1475 ("{" "}" comment)
1476 ;; Doesn't work when there are strings in comments....
1477 ;; ("'[^']*'" nil string)
1478 ("^#.*$" nil include)
1479 ("^[ \t]*\\(procedure\\|function\\)[ \t]+\\w+[^ \t(;]*" nil defun)
1480 ("\\<\\(program\\|begin\\|end\\)\\>" nil defun)
1481 ("\\<\\(external\\|forward\\)\\>" nil include)
1482 ("\\<\\(label\\|const\\|type\\|var\\)\\>" nil define)
1483 ("\\<\\(record\\|array\\|file\\)\\>" nil type)
1484 ("\\<\\(of\\|to\\|for\\|if\\|then\\|else\\|case\\|while\\|do\\|until\\|and\\|or\\|not\\|with\\|repeat\\)\\>" nil keyword)
1485 )
1486 nil 'case-insensitive)
1487
1488(hilit-set-mode-patterns
1489 'icon-mode
1490 '(("#.*$" nil comment)
1491 ("\"[^\\\"]*\\(\\\\.[^\\\"]*\\)*\"" nil string)
1492 ;; charsets: these do not work because of a conflict with strings
1493 ;; ("'[^\\']*\\(\\\\.[^\\']*\\)*'" nil string)
1494 ("^[ \t]*procedure[ \t]+\\w+[ \t]*(" ")" defun)
1495 ("^[ \t]*record.*(" ")" include)
1496 ("^[ \t]*\\(global\\|link\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil include)
1497 ("^[ \t]*\\(local\\|static\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil decl)
1498 ("\\<\\(initial\\|end\\)\\>" nil glob-struct)
1499 ("\\<\\(while\\|until\\|return\\|every\\|if\\|then\\|else\\|to\\|case\\|of\\|suspend\\|create\\|do\\|repeat\\|break\\)\\>" nil keyword)
1500 ))
1501
1502;; as you can see, I had two similar problems for Pascal and Icon. In
1503;; Pascal, strings are delimited with ' and an embedded quote is doubled,
1504;; thus string syntax would be extremely simple. However, if a string
1505;; occurs within a comment, the following text is considered a string.
1506;;
1507;; In Icon, strings are similar to C ones, but there are also charsets,
1508;; delimited with simple quotes. I could not manage to use both regexps at
1509;; the same time.
1510
1511;; The problem I have with my patterns for Icon is that this language has a
1512;; string similar constant to the C one (but a string can be cut on several
1513;; lines, if terminated by a dash and continued with initial blanks, like
1514;; this:
1515;; "This is a somewhat long -
1516;; string, written on three -
1517;; successive lines"
1518;; in order to insert a double quote in a string, you have to escape it
1519;; with a \), bu also a character set constant (named a charset), which
1520;; uses single quotes instead of double ones. It would seem intuitive to
1521;; highlight both constants in the same way.
1522
1523
1524(provide 'hilit19)
1525
1526;; arch-tag: db99739a-4837-41ee-ad02-3baced8ae71d
1527;;; hilit19.el ends here
diff --git a/lisp/obsolete/hscroll.el b/lisp/obsolete/hscroll.el
deleted file mode 100644
index 98300503f86..00000000000
--- a/lisp/obsolete/hscroll.el
+++ /dev/null
@@ -1,106 +0,0 @@
1;;; hscroll.el --- automatically scroll truncated lines horizontally
2
3;; Copyright (C) 1992, 1993, 1995, 1996, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Author: Wayne Mesard <wmesard@esd.sgi.com>
7;; Keywords: display
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 3 of the License, or
14;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; This file has been obsolete since Emacs 21.1.
27
28;; This file contains dummy variables and functions only because Emacs
29;; does hscrolling automatically, now.
30
31;;; Code:
32
33;;;
34;;; PUBLIC VARIABLES
35;;;
36
37(defvar hscroll-version "0.0")
38
39(defgroup hscroll nil
40 "This customization group is kept for compatibility only.
41Emacs now does hscrolling automatically. Please remove references
42to hscroll from your init file and code."
43 :group 'editing)
44
45
46(defcustom hscroll-global-mode nil
47 "*Obsolete."
48 :group 'hscroll
49 :type 'boolean
50 :require 'hscroll
51 :version "20.3")
52
53(defcustom hscroll-margin 5
54 "*Obsolete."
55 :group 'hscroll
56 :type 'integer)
57
58(defcustom hscroll-snap-threshold 30
59 "*Obsolete."
60 :group 'hscroll
61 :type 'integer)
62
63(defcustom hscroll-step-percent 25
64 "*Obsolete."
65 :group 'hscroll
66 :type 'integer)
67
68(defcustom hscroll-mode-name " Hscr"
69 "*Obsolete."
70 :group 'hscroll
71 :type 'string)
72
73;;;
74;;; PUBLIC COMMANDS
75;;;
76
77;;;###autoload
78(defun turn-on-hscroll ()
79 "This function is obsolete.
80Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
81Also see `automatic-hscrolling'.")
82
83;;;###autoload
84(defun hscroll-mode (&optional arg)
85 "This function is obsolete.
86Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
87Also see `automatic-hscrolling'."
88 (interactive "P"))
89
90;;;###autoload
91(defun hscroll-global-mode (&optional arg)
92 "This function is obsolete.
93Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
94Also see `automatic-hscrolling'."
95 (interactive "P"))
96
97(defun hscroll-window-maybe ()
98 "This function is obsolete.
99Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
100Also see `automatic-hscrolling'."
101 (interactive))
102
103(provide 'hscroll)
104
105;; arch-tag: 48377520-e5ca-401d-b360-3881b2d5a05a
106;;; hscroll.el ends here
diff --git a/lisp/obsolete/lselect.el b/lisp/obsolete/lselect.el
deleted file mode 100644
index bf689eb5ec7..00000000000
--- a/lisp/obsolete/lselect.el
+++ /dev/null
@@ -1,247 +0,0 @@
1;;; lselect.el --- Lucid interface to X Selections
2
3;; Copyright (C) 1990, 1993, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Maintainer: FSF
7;; Keywords: emulations
8
9;; This won't completely work until we support or emulate Lucid-style extents.
10;; Based on Lucid's selection code.
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 3 of the License, or
17;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
26
27;;; Commentary:
28
29;; This file has been obsolete since Emacs 23.1.
30
31;;; Code:
32
33;; The selection code requires us to use certain symbols whose names are
34;; all upper-case; this may seem tasteless, but it makes there be a 1:1
35;; correspondence between these symbols and X Atoms (which are upcased.)
36
37;; This is Lucid/XEmacs stuff
38(defvar mouse-highlight-priority)
39(defvar x-lost-selection-functions)
40(defvar zmacs-regions)
41
42(defalias 'x-get-cutbuffer 'x-get-cut-buffer)
43(defalias 'x-store-cutbuffer 'x-set-cut-buffer)
44
45(or (facep 'primary-selection)
46 (make-face 'primary-selection))
47
48(or (facep 'secondary-selection)
49 (make-face 'secondary-selection))
50
51(defun x-get-secondary-selection ()
52 "Return text selected from some X window."
53 (x-get-selection-internal 'SECONDARY 'STRING))
54
55(defvar primary-selection-extent nil
56 "The extent of the primary selection; don't use this.")
57
58(defvar secondary-selection-extent nil
59 "The extent of the secondary selection; don't use this.")
60
61
62(defun x-select-make-extent-for-selection (selection previous-extent face)
63 ;; Given a selection, this makes an extent in the buffer which holds that
64 ;; selection, for highlighting purposes. If the selection isn't associated
65 ;; with a buffer, this does nothing.
66 (let ((buffer nil)
67 (valid (and (extentp previous-extent)
68 (extent-buffer previous-extent)
69 (buffer-name (extent-buffer previous-extent))))
70 start end)
71 (cond ((stringp selection)
72 ;; if we're selecting a string, lose the previous extent used
73 ;; to highlight the selection.
74 (setq valid nil))
75 ((consp selection)
76 (setq start (min (car selection) (cdr selection))
77 end (max (car selection) (cdr selection))
78 valid (and valid
79 (eq (marker-buffer (car selection))
80 (extent-buffer previous-extent)))
81 buffer (marker-buffer (car selection))))
82 ((extentp selection)
83 (setq start (extent-start-position selection)
84 end (extent-end-position selection)
85 valid (and valid
86 (eq (extent-buffer selection)
87 (extent-buffer previous-extent)))
88 buffer (extent-buffer selection)))
89 )
90 (if (and (not valid)
91 (extentp previous-extent)
92 (extent-buffer previous-extent)
93 (buffer-name (extent-buffer previous-extent)))
94 (delete-extent previous-extent))
95 (if (not buffer)
96 ;; string case
97 nil
98 ;; normal case
99 (if valid
100 (set-extent-endpoints previous-extent start end)
101 (setq previous-extent (make-extent start end buffer))
102 ;; use same priority as mouse-highlighting so that conflicts between
103 ;; the selection extent and a mouse-highlighted extent are resolved
104 ;; by the usual size-and-endpoint-comparison method.
105 (set-extent-priority previous-extent mouse-highlight-priority)
106 (set-extent-face previous-extent face)))))
107
108
109(defun x-own-selection (selection &optional type)
110 "Make a primary X Selection of the given argument.
111The argument may be a string, a cons of two markers, or an extent.
112In the latter cases the selection is considered to be the text
113between the markers, or the between extents endpoints."
114 (interactive (if (not current-prefix-arg)
115 (list (read-string "Store text for pasting: "))
116 (list (cons ;; these need not be ordered.
117 (copy-marker (point-marker))
118 (copy-marker (mark-marker))))))
119 (or type (setq type 'PRIMARY))
120 (x-set-selection selection type)
121 (cond ((eq type 'PRIMARY)
122 (setq primary-selection-extent
123 (x-select-make-extent-for-selection
124 selection primary-selection-extent 'primary-selection)))
125 ((eq type 'SECONDARY)
126 (setq secondary-selection-extent
127 (x-select-make-extent-for-selection
128 selection secondary-selection-extent 'secondary-selection))))
129 selection)
130
131
132(defun x-own-secondary-selection (selection &optional type)
133 "Make a secondary X Selection of the given argument. The argument may be a
134string or a cons of two markers (in which case the selection is considered to
135be the text between those markers.)"
136 (interactive (if (not current-prefix-arg)
137 (list (read-string "Store text for pasting: "))
138 (list (cons ;; these need not be ordered.
139 (copy-marker (point-marker))
140 (copy-marker (mark-marker))))))
141 (x-own-selection selection 'SECONDARY))
142
143
144(defun x-own-clipboard (string)
145 "Paste the given string to the X Clipboard."
146 (x-own-selection string 'CLIPBOARD))
147
148
149(defun x-disown-selection (&optional secondary-p)
150 "Assuming we own the selection, disown it. With an argument, discard the
151secondary selection instead of the primary selection."
152 (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
153
154(defun x-dehilight-selection (selection)
155 "for use as a value of `x-lost-selection-functions'."
156 (cond ((eq selection 'PRIMARY)
157 (if primary-selection-extent
158 (let ((inhibit-quit t))
159 (delete-extent primary-selection-extent)
160 (setq primary-selection-extent nil)))
161 (if zmacs-regions (zmacs-deactivate-region)))
162 ((eq selection 'SECONDARY)
163 (if secondary-selection-extent
164 (let ((inhibit-quit t))
165 (delete-extent secondary-selection-extent)
166 (setq secondary-selection-extent nil)))))
167 nil)
168
169(setq x-lost-selection-functions 'x-dehilight-selection)
170
171(defun x-notice-selection-requests (selection type successful)
172 "for possible use as the value of `x-sent-selection-functions'."
173 (if (not successful)
174 (message "Selection request failed to convert %s to %s"
175 selection type)
176 (message "Sent selection %s as %s" selection type)))
177
178(defun x-notice-selection-failures (selection type successful)
179 "for possible use as the value of `x-sent-selection-functions'."
180 (or successful
181 (message "Selection request failed to convert %s to %s"
182 selection type)))
183
184;(setq x-sent-selection-functions 'x-notice-selection-requests)
185;(setq x-sent-selection-functions 'x-notice-selection-failures)
186
187
188;; Random utility functions
189
190(defun x-kill-primary-selection ()
191 "If there is a selection, delete the text it covers, and copy it to
192both the kill ring and the Clipboard."
193 (interactive)
194 (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
195 (setq last-command nil)
196 (or primary-selection-extent
197 (error "the primary selection is not an extent?"))
198 (save-excursion
199 (set-buffer (extent-buffer primary-selection-extent))
200 (kill-region (extent-start-position primary-selection-extent)
201 (extent-end-position primary-selection-extent)))
202 (x-disown-selection nil))
203
204(defun x-delete-primary-selection ()
205 "If there is a selection, delete the text it covers *without* copying it to
206the kill ring or the Clipboard."
207 (interactive)
208 (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
209 (setq last-command nil)
210 (or primary-selection-extent
211 (error "the primary selection is not an extent?"))
212 (save-excursion
213 (set-buffer (extent-buffer primary-selection-extent))
214 (delete-region (extent-start-position primary-selection-extent)
215 (extent-end-position primary-selection-extent)))
216 (x-disown-selection nil))
217
218(defun x-copy-primary-selection ()
219 "If there is a selection, copy it to both the kill ring and the Clipboard."
220 (interactive)
221 (setq last-command nil)
222 (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
223 (or primary-selection-extent
224 (error "the primary selection is not an extent?"))
225 (save-excursion
226 (set-buffer (extent-buffer primary-selection-extent))
227 (copy-region-as-kill (extent-start-position primary-selection-extent)
228 (extent-end-position primary-selection-extent))))
229
230(defun x-yank-clipboard-selection ()
231 "If someone owns a Clipboard selection, insert it at point."
232 (interactive)
233 (setq last-command nil)
234 (let ((clip (x-get-clipboard)))
235 (or clip (error "there is no clipboard selection"))
236 (push-mark)
237 (insert clip)))
238
239(provide 'lselect)
240
241
242;; Local variables:
243;; byte-compile-warnings: (not unresolved)
244;; End:
245
246;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556
247;;; lselect.el ends here
diff --git a/lisp/obsolete/mlsupport.el b/lisp/obsolete/mlsupport.el
deleted file mode 100644
index 04f6b8fa9e2..00000000000
--- a/lisp/obsolete/mlsupport.el
+++ /dev/null
@@ -1,430 +0,0 @@
1;;; mlsupport.el --- run-time support for mocklisp code
2
3;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
4;; 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Maintainer: FSF
7;; Keywords: 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 3 of the License, or
14;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; This file has been obsolete since Emacs 22.1.
27
28;; This package provides equivalents of certain primitives from Gosling
29;; Emacs (including the commercial UniPress versions). These have an
30;; ml- prefix to distinguish them from native GNU Emacs functions with
31;; similar names. The package mlconvert.el translates Mocklisp code
32;; to use these names.
33
34;;; Code:
35
36(defmacro ml-defun (&rest defs)
37 (list 'ml-defun-1 (list 'quote defs)))
38
39(defun ml-defun-1 (args)
40 (while args
41 (fset (car (car args)) (cons 'mocklisp (cdr (car args))))
42 (setq args (cdr args))))
43
44(defmacro declare-buffer-specific (&rest vars)
45 (cons 'progn (mapcar (function (lambda (var) (list 'make-variable-buffer-local (list 'quote var)))) vars)))
46
47(defun ml-set-default (varname value)
48 (set-default (intern varname) value))
49
50; Lossage: must make various things default missing args to the prefix arg
51; Alternatively, must make provide-prefix-argument do something hairy.
52
53(defun >> (val count) (lsh val (- count)))
54(defun novalue () nil)
55
56(defun ml-not (arg) (if (zerop arg) 1 0))
57
58(defun provide-prefix-arg (arg form)
59 (funcall (car form) arg))
60
61(defun define-keymap (name)
62 (fset (intern name) (make-keymap)))
63
64;; Make it work to use ml-use-...-map on "esc" and such.
65(fset 'esc-map esc-map)
66(fset 'ctl-x-map ctl-x-map)
67
68(defun ml-use-local-map (name)
69 (use-local-map (intern (concat name "-map"))))
70
71(defun ml-use-global-map (name)
72 (use-global-map (intern (concat name "-map"))))
73
74(defun local-bind-to-key (name key)
75 (or (current-local-map)
76 (use-local-map (make-keymap)))
77 (define-key (current-local-map)
78 (if (integerp key)
79 (if (>= key 128)
80 (concat (char-to-string meta-prefix-char)
81 (char-to-string (- key 128)))
82 (char-to-string key))
83 key)
84 (intern name)))
85
86(defun bind-to-key (name key)
87 (define-key global-map (if (integerp key) (char-to-string key) key)
88 (intern name)))
89
90(defun ml-autoload (name file)
91 (autoload (intern name) file))
92
93(defun ml-define-string-macro (name defn)
94 (fset (intern name) defn))
95
96(defun push-back-character (char)
97 (setq unread-command-events (list char)))
98
99(defun to-col (column)
100 (indent-to column 0))
101
102(defmacro is-bound (&rest syms)
103 (cons 'and (mapcar (function (lambda (sym) (list 'boundp (list 'quote sym)))) syms)))
104
105(defmacro declare-global (&rest syms)
106 (cons 'progn (mapcar (function (lambda (sym) (list 'defvar sym nil))) syms)))
107
108(defmacro error-occurred (&rest body)
109 (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
110
111(defun return-prefix-argument (value)
112 (setq prefix-arg value))
113
114(defun ml-prefix-argument ()
115 (if (null current-prefix-arg) 1
116 (if (listp current-prefix-arg) (car current-prefix-arg)
117 (if (eq current-prefix-arg '-) -1
118 current-prefix-arg))))
119
120(defun ml-print (varname)
121 (interactive "vPrint variable: ")
122 (if (boundp varname)
123 (message "%s => %s" (symbol-name varname) (symbol-value varname))
124 (message "%s has no value" (symbol-name varname))))
125
126(defun ml-set (str val) (set (intern str) val))
127
128(defun ml-message (&rest args) (message "%s" (apply 'concat args)))
129
130(defun set-auto-fill-hook (arg)
131 (setq auto-fill-function (intern arg)))
132
133(defun auto-execute (function pattern)
134 (if (/= (aref pattern 0) ?*)
135 (error "Only patterns starting with * supported in auto-execute"))
136 (setq auto-mode-alist (cons (cons (concat "\\." (substring pattern 1)
137 "\\'")
138 function)
139 auto-mode-alist)))
140
141(defun move-to-comment-column ()
142 (indent-to comment-column))
143
144(defun erase-region ()
145 (delete-region (point) (mark)))
146
147(defun delete-region-to-buffer (bufname)
148 (copy-to-buffer bufname (point) (mark))
149 (delete-region (point) (mark)))
150
151(defun copy-region-to-buffer (bufname)
152 (copy-to-buffer bufname (point) (mark)))
153
154(defun append-region-to-buffer (bufname)
155 (append-to-buffer bufname (point) (mark)))
156
157(defun prepend-region-to-buffer (bufname)
158 (prepend-to-buffer bufname (point) (mark)))
159
160(defun delete-next-character ()
161 (delete-char (ml-prefix-argument)))
162
163(defun delete-next-word ()
164 (delete-region (point) (progn (forward-word (ml-prefix-argument)) (point))))
165
166(defun delete-previous-word ()
167 (delete-region (point) (progn (backward-word (ml-prefix-argument)) (point))))
168
169(defun delete-previous-character ()
170 (delete-backward-char (ml-prefix-argument)))
171
172(defun forward-character ()
173 (forward-char (ml-prefix-argument)))
174
175(defun backward-character ()
176 (backward-char (ml-prefix-argument)))
177
178(defun ml-newline ()
179 (newline (ml-prefix-argument)))
180
181(defun ml-next-line ()
182 (forward-line (ml-prefix-argument)))
183
184(defun ml-previous-line ()
185 (forward-line (- (ml-prefix-argument))))
186
187(defun delete-to-kill-buffer ()
188 (kill-region (point) (mark)))
189
190(defun narrow-region ()
191 (narrow-to-region (point) (mark)))
192
193(defun ml-newline-and-indent ()
194 (let ((column (current-indentation)))
195 (newline (ml-prefix-argument))
196 (indent-to column)))
197
198(defun newline-and-backup ()
199 (open-line (ml-prefix-argument)))
200
201(defun quote-char ()
202 (quoted-insert (ml-prefix-argument)))
203
204(defun ml-current-column ()
205 (1+ (current-column)))
206
207(defun ml-current-indent ()
208 (1+ (current-indentation)))
209
210(defun region-around-match (&optional n)
211 (set-mark (match-beginning n))
212 (goto-char (match-end n)))
213
214(defun region-to-string ()
215 (buffer-substring (min (point) (mark)) (max (point) (mark))))
216
217(defun use-abbrev-table (name)
218 (let ((symbol (intern (concat name "-abbrev-table"))))
219 (or (boundp symbol)
220 (define-abbrev-table symbol nil))
221 (symbol-value symbol)))
222
223(defun define-hooked-local-abbrev (name exp hook)
224 (define-abbrev local-abbrev-table name exp (intern hook)))
225
226(defun define-hooked-global-abbrev (name exp hook)
227 (define-abbrev global-abbrev-table name exp (intern hook)))
228
229(defun case-word-lower ()
230 (ml-casify-word 'downcase-region))
231
232(defun case-word-upper ()
233 (ml-casify-word 'upcase-region))
234
235(defun case-word-capitalize ()
236 (ml-casify-word 'capitalize-region))
237
238(defun ml-casify-word (fun)
239 (save-excursion
240 (forward-char 1)
241 (forward-word -1)
242 (funcall fun (point)
243 (progn (forward-word (ml-prefix-argument))
244 (point)))))
245
246(defun case-region-lower ()
247 (downcase-region (point) (mark)))
248
249(defun case-region-upper ()
250 (upcase-region (point) (mark)))
251
252(defun case-region-capitalize ()
253 (capitalize-region (point) (mark)))
254
255(defvar saved-command-line-args nil)
256
257(defun argc ()
258 (or saved-command-line-args
259 (setq saved-command-line-args command-line-args
260 command-line-args ()))
261 (length command-line-args))
262
263(defun argv (i)
264 (or saved-command-line-args
265 (setq saved-command-line-args command-line-args
266 command-line-args ()))
267 (nth i saved-command-line-args))
268
269(defun invisible-argc ()
270 (length (or saved-command-line-args
271 command-line-args)))
272
273(defun invisible-argv (i)
274 (nth i (or saved-command-line-args
275 command-line-args)))
276
277(defun exit-emacs ()
278 (interactive)
279 (condition-case ()
280 (exit-recursive-edit)
281 (error (kill-emacs))))
282
283;; Lisp function buffer-size returns total including invisible;
284;; mocklisp wants just visible.
285(defun ml-buffer-size ()
286 (- (point-max) (point-min)))
287
288(defun previous-command ()
289 last-command)
290
291(defun beginning-of-window ()
292 (goto-char (window-start)))
293
294(defun end-of-window ()
295 (goto-char (window-start))
296 (vertical-motion (- (window-height) 2)))
297
298(defun ml-search-forward (string)
299 (search-forward string nil nil (ml-prefix-argument)))
300
301(defun ml-re-search-forward (string)
302 (re-search-forward string nil nil (ml-prefix-argument)))
303
304(defun ml-search-backward (string)
305 (search-backward string nil nil (ml-prefix-argument)))
306
307(defun ml-re-search-backward (string)
308 (re-search-backward string nil nil (ml-prefix-argument)))
309
310(defvar use-users-shell 1
311 "Mocklisp compatibility variable; 1 means use shell from SHELL env var.
3120 means use /bin/sh.")
313
314(defvar use-csh-option-f 1
315 "Mocklisp compatibility variable; 1 means pass -f when calling csh.")
316
317(defun filter-region (command)
318 (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
319 (csh (equal (file-name-nondirectory shell) "csh")))
320 (call-process-region (point) (mark) shell t t nil
321 (if (and csh use-csh-option-f) "-cf" "-c")
322 (concat "exec " command))))
323
324(defun execute-monitor-command (command)
325 (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
326 (csh (equal (file-name-nondirectory shell) "csh")))
327 (call-process shell nil t t
328 (if (and csh use-csh-option-f) "-cf" "-c")
329 (concat "exec " command))))
330
331(defun use-syntax-table (name)
332 (set-syntax-table (symbol-value (intern (concat name "-syntax-table")))))
333
334(defun line-to-top-of-window ()
335 (recenter (1- (ml-prefix-argument))))
336
337(defun ml-previous-page (&optional arg)
338 (let ((count (or arg (ml-prefix-argument))))
339 (while (> count 0)
340 (scroll-down nil)
341 (setq count (1- count)))
342 (while (< count 0)
343 (scroll-up nil)
344 (setq count (1+ count)))))
345
346(defun ml-next-page ()
347 (ml-previous-page (- (ml-prefix-argument))))
348
349(defun page-next-window (&optional arg)
350 (let ((count (or arg (ml-prefix-argument))))
351 (while (> count 0)
352 (scroll-other-window nil)
353 (setq count (1- count)))
354 (while (< count 0)
355 (scroll-other-window '-)
356 (setq count (1+ count)))))
357
358(defun ml-next-window ()
359 (select-window (next-window)))
360
361(defun ml-previous-window ()
362 (select-window (previous-window)))
363
364(defun scroll-one-line-up ()
365 (scroll-up (ml-prefix-argument)))
366
367(defun scroll-one-line-down ()
368 (scroll-down (ml-prefix-argument)))
369
370(defun split-current-window ()
371 (split-window (selected-window)))
372
373(defun last-key-struck () last-command-char)
374
375(defun execute-mlisp-line (string)
376 (eval (read string)))
377
378(defun move-dot-to-x-y (x y)
379 (goto-char (window-start (selected-window)))
380 (vertical-motion (1- y))
381 (move-to-column (1- x)))
382
383(defun ml-modify-syntax-entry (string)
384 (let ((i 5)
385 (len (length string))
386 (datastring (substring string 0 2)))
387 (if (= (aref string 0) ?\-)
388 (aset datastring 0 ?\ ))
389 (if (= (aref string 2) ?\{)
390 (if (= (aref string 4) ?\ )
391 (aset datastring 0 ?\<)
392 (error "Two-char comment delimiter: use modify-syntax-entry directly")))
393 (if (= (aref string 3) ?\})
394 (if (= (aref string 4) ?\ )
395 (aset datastring 0 ?\>)
396 (error "Two-char comment delimiter: use modify-syntax-entry directly")))
397 (while (< i len)
398 (modify-syntax-entry (aref string i) datastring)
399 (setq i (1+ i))
400 (if (and (< i len)
401 (= (aref string i) ?\-))
402 (let ((c (aref string (1- i)))
403 (lim (aref string (1+ i))))
404 (while (<= c lim)
405 (modify-syntax-entry c datastring)
406 (setq c (1+ c)))
407 (setq i (+ 2 i)))))))
408
409
410
411(defun ml-substr (string from to)
412 (let ((length (length string)))
413 (if (< from 0) (setq from (+ from length)))
414 (if (< to 0) (setq to (+ to length)))
415 (substring string from (+ from to))))
416
417(defun ml-concat (&rest args)
418 (let ((newargs nil) this)
419 (while args
420 (setq this (car args))
421 (if (numberp this)
422 (setq this (number-to-string this)))
423 (setq newargs (cons this newargs)
424 args (cdr args)))
425 (apply 'concat (nreverse newargs))))
426
427(provide 'mlsupport)
428
429;; arch-tag: b0ad09bc-8cb2-4be0-8888-2e874839bcbc
430;;; mlsupport.el ends here
diff --git a/lisp/obsolete/ooutline.el b/lisp/obsolete/ooutline.el
deleted file mode 100644
index 4ce90d9eb58..00000000000
--- a/lisp/obsolete/ooutline.el
+++ /dev/null
@@ -1,587 +0,0 @@
1;;; ooutline.el --- outline mode commands for Emacs
2
3;; Copyright (C) 1986, 1993, 1994, 1997, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Maintainer: FSF
7;; Keywords: outlines
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 3 of the License, or
14;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; This file has been obsolete since Emacs 21.1.
27
28;; This package is a major mode for editing outline-format documents.
29;; An outline can be `abstracted' to show headers at any given level,
30;; with all stuff below hidden. See the Emacs manual for details.
31
32;;; Code:
33
34;; Jan '86, Some new features added by Peter Desnoyers and rewritten by RMS.
35
36(defgroup outlines nil
37 "Support for hierarchical outlining."
38 :prefix "outline-"
39 :group 'editing)
40
41
42(defcustom outline-regexp nil
43 "*Regular expression to match the beginning of a heading.
44Any line whose beginning matches this regexp is considered to start a heading.
45The recommended way to set this is with a Local Variables: list
46in the file it applies to. See also outline-heading-end-regexp."
47 :type '(choice regexp (const nil))
48 :group 'outlines)
49
50;; Can't initialize this in the defvar above -- some major modes have
51;; already assigned a local value to it.
52(or (default-value 'outline-regexp)
53 (setq-default outline-regexp "[*\^L]+"))
54
55(defcustom outline-heading-end-regexp "[\n\^M]"
56 "*Regular expression to match the end of a heading line.
57You can assume that point is at the beginning of a heading when this
58regexp is searched for. The heading ends at the end of the match.
59The recommended way to set this is with a \"Local Variables:\" list
60in the file it applies to."
61 :type 'regexp
62 :group 'outlines)
63
64(defvar outline-mode-prefix-map nil)
65
66(if outline-mode-prefix-map
67 nil
68 (setq outline-mode-prefix-map (make-sparse-keymap))
69 (define-key outline-mode-prefix-map "\C-n" 'outline-next-visible-heading)
70 (define-key outline-mode-prefix-map "\C-p" 'outline-previous-visible-heading)
71 (define-key outline-mode-prefix-map "\C-i" 'show-children)
72 (define-key outline-mode-prefix-map "\C-s" 'show-subtree)
73 (define-key outline-mode-prefix-map "\C-d" 'hide-subtree)
74 (define-key outline-mode-prefix-map "\C-u" 'outline-up-heading)
75 (define-key outline-mode-prefix-map "\C-f" 'outline-forward-same-level)
76 (define-key outline-mode-prefix-map "\C-b" 'outline-backward-same-level)
77 (define-key outline-mode-prefix-map "\C-t" 'hide-body)
78 (define-key outline-mode-prefix-map "\C-a" 'show-all)
79 (define-key outline-mode-prefix-map "\C-c" 'hide-entry)
80 (define-key outline-mode-prefix-map "\C-e" 'show-entry)
81 (define-key outline-mode-prefix-map "\C-l" 'hide-leaves)
82 (define-key outline-mode-prefix-map "\C-k" 'show-branches)
83 (define-key outline-mode-prefix-map "\C-q" 'hide-sublevels)
84 (define-key outline-mode-prefix-map "\C-o" 'hide-other))
85
86(defvar outline-mode-menu-bar-map nil)
87(if outline-mode-menu-bar-map
88 nil
89 (setq outline-mode-menu-bar-map (make-sparse-keymap))
90
91 (define-key outline-mode-menu-bar-map [hide]
92 (cons "Hide" (make-sparse-keymap "Hide")))
93
94 (define-key outline-mode-menu-bar-map [hide hide-other]
95 '("Hide Other" . hide-other))
96 (define-key outline-mode-menu-bar-map [hide hide-sublevels]
97 '("Hide Sublevels" . hide-sublevels))
98 (define-key outline-mode-menu-bar-map [hide hide-subtree]
99 '("Hide Subtree" . hide-subtree))
100 (define-key outline-mode-menu-bar-map [hide hide-entry]
101 '("Hide Entry" . hide-entry))
102 (define-key outline-mode-menu-bar-map [hide hide-body]
103 '("Hide Body" . hide-body))
104 (define-key outline-mode-menu-bar-map [hide hide-leaves]
105 '("Hide Leaves" . hide-leaves))
106
107 (define-key outline-mode-menu-bar-map [show]
108 (cons "Show" (make-sparse-keymap "Show")))
109
110 (define-key outline-mode-menu-bar-map [show show-subtree]
111 '("Show Subtree" . show-subtree))
112 (define-key outline-mode-menu-bar-map [show show-children]
113 '("Show Children" . show-children))
114 (define-key outline-mode-menu-bar-map [show show-branches]
115 '("Show Branches" . show-branches))
116 (define-key outline-mode-menu-bar-map [show show-entry]
117 '("Show Entry" . show-entry))
118 (define-key outline-mode-menu-bar-map [show show-all]
119 '("Show All" . show-all))
120
121 (define-key outline-mode-menu-bar-map [headings]
122 (cons "Headings" (make-sparse-keymap "Headings")))
123
124 (define-key outline-mode-menu-bar-map [headings outline-backward-same-level]
125 '("Previous Same Level" . outline-backward-same-level))
126 (define-key outline-mode-menu-bar-map [headings outline-forward-same-level]
127 '("Next Same Level" . outline-forward-same-level))
128 (define-key outline-mode-menu-bar-map [headings outline-previous-visible-heading]
129 '("Previous" . outline-previous-visible-heading))
130 (define-key outline-mode-menu-bar-map [headings outline-next-visible-heading]
131 '("Next" . outline-next-visible-heading))
132 (define-key outline-mode-menu-bar-map [headings outline-up-heading]
133 '("Up" . outline-up-heading)))
134
135(defvar outline-mode-map nil "")
136
137(if outline-mode-map
138 nil
139 (setq outline-mode-map (nconc (make-sparse-keymap) text-mode-map))
140 (define-key outline-mode-map "\C-c" outline-mode-prefix-map)
141 (define-key outline-mode-map [menu-bar] outline-mode-menu-bar-map))
142
143(defcustom outline-minor-mode nil
144 "Non-nil if using Outline mode as a minor mode of some other mode."
145 :type 'boolean
146 :group 'outlines)
147(make-variable-buffer-local 'outline-minor-mode)
148(put 'outline-minor-mode 'permanent-local t)
149(or (assq 'outline-minor-mode minor-mode-alist)
150 (setq minor-mode-alist (append minor-mode-alist
151 (list '(outline-minor-mode " Outl")))))
152
153(defvar outline-font-lock-keywords
154 '(;; Highlight headings according to the level.
155 ("^\\([*]+\\)[ \t]*\\([^\n\r]+\\)?[ \t]*[\n\r]"
156 (1 font-lock-string-face)
157 (2 (let ((len (- (match-end 1) (match-beginning 1))))
158 (or (cdr (assq len '((1 . font-lock-function-name-face)
159 (2 . font-lock-keyword-face)
160 (3 . font-lock-comment-face))))
161 font-lock-variable-name-face))
162 nil t))
163 ;; Highlight citations of the form [1] and [Mar94].
164 ("\\[\\([[:upper:]][[:alpha:]]+\\)*[0-9]+\\]" . font-lock-type-face))
165 "Additional expressions to highlight in Outline mode.")
166
167(defun outline-mode ()
168 "Set major mode for editing outlines with selective display.
169Headings are lines which start with asterisks: one for major headings,
170two for subheadings, etc. Lines not starting with asterisks are body lines.
171
172Body text or subheadings under a heading can be made temporarily
173invisible, or visible again. Invisible lines are attached to the end
174of the heading, so they move with it, if the line is killed and yanked
175back. A heading with text hidden under it is marked with an ellipsis (...).
176
177Commands:\\<outline-mode-map>
178\\[outline-next-visible-heading] outline-next-visible-heading move by visible headings
179\\[outline-previous-visible-heading] outline-previous-visible-heading
180\\[outline-forward-same-level] outline-forward-same-level similar but skip subheadings
181\\[outline-backward-same-level] outline-backward-same-level
182\\[outline-up-heading] outline-up-heading move from subheading to heading
183
184\\[hide-body] make all text invisible (not headings).
185\\[show-all] make everything in buffer visible.
186
187The remaining commands are used when point is on a heading line.
188They apply to some of the body or subheadings of that heading.
189\\[hide-subtree] hide-subtree make body and subheadings invisible.
190\\[show-subtree] show-subtree make body and subheadings visible.
191\\[show-children] show-children make direct subheadings visible.
192 No effect on body, or subheadings 2 or more levels down.
193 With arg N, affects subheadings N levels down.
194\\[hide-entry] make immediately following body invisible.
195\\[show-entry] make it visible.
196\\[hide-leaves] make body under heading and under its subheadings invisible.
197 The subheadings remain visible.
198\\[show-branches] make all subheadings at all levels visible.
199
200The variable `outline-regexp' can be changed to control what is a heading.
201A line is a heading if `outline-regexp' matches something at the
202beginning of the line. The longer the match, the deeper the level.
203
204Turning on outline mode calls the value of `text-mode-hook' and then of
205`outline-mode-hook', if they are non-nil."
206 (interactive)
207 (kill-all-local-variables)
208 (setq selective-display t)
209 (use-local-map outline-mode-map)
210 (setq mode-name "Outline")
211 (setq major-mode 'outline-mode)
212 (define-abbrev-table 'text-mode-abbrev-table ())
213 (setq local-abbrev-table text-mode-abbrev-table)
214 (set-syntax-table text-mode-syntax-table)
215 (make-local-variable 'paragraph-start)
216 (setq paragraph-start (concat paragraph-start "\\|\\("
217 outline-regexp "\\)"))
218 ;; Inhibit auto-filling of header lines.
219 (make-local-variable 'auto-fill-inhibit-regexp)
220 (setq auto-fill-inhibit-regexp outline-regexp)
221 (make-local-variable 'paragraph-separate)
222 (setq paragraph-separate (concat paragraph-separate "\\|\\("
223 outline-regexp "\\)"))
224 (make-local-variable 'font-lock-defaults)
225 (setq font-lock-defaults '(outline-font-lock-keywords t))
226 (make-local-variable 'change-major-mode-hook)
227 (add-hook 'change-major-mode-hook 'show-all)
228 (run-mode-hooks 'text-mode-hook 'outline-mode-hook))
229
230(defcustom outline-minor-mode-prefix "\C-c@"
231 "*Prefix key to use for Outline commands in Outline minor mode.
232The value of this variable is checked as part of loading Outline mode.
233After that, changing the prefix key requires manipulating keymaps."
234 :type 'string
235 :group 'outlines)
236
237(defvar outline-minor-mode-map nil)
238(if outline-minor-mode-map
239 nil
240 (setq outline-minor-mode-map (make-sparse-keymap))
241 (define-key outline-minor-mode-map [menu-bar]
242 outline-mode-menu-bar-map)
243 (define-key outline-minor-mode-map outline-minor-mode-prefix
244 outline-mode-prefix-map))
245
246(or (assq 'outline-minor-mode minor-mode-map-alist)
247 (setq minor-mode-map-alist
248 (cons (cons 'outline-minor-mode outline-minor-mode-map)
249 minor-mode-map-alist)))
250
251(defun outline-minor-mode (&optional arg)
252 "Toggle Outline minor mode.
253With arg, turn Outline minor mode on if arg is positive, off otherwise.
254See the command `outline-mode' for more information on this mode."
255 (interactive "P")
256 (setq outline-minor-mode
257 (if (null arg) (not outline-minor-mode)
258 (> (prefix-numeric-value arg) 0)))
259 (if outline-minor-mode
260 (progn
261 (setq selective-display t)
262 (run-hooks 'outline-minor-mode-hook))
263 (setq selective-display nil))
264 ;; When turning off outline mode, get rid of any ^M's.
265 (or outline-minor-mode
266 (outline-flag-region (point-min) (point-max) ?\n))
267 (force-mode-line-update))
268
269(defvar outline-level 'outline-level
270 "Function of no args to compute a header's nesting level in an outline.
271It can assume point is at the beginning of a header line.")
272
273;; This used to count columns rather than characters, but that made ^L
274;; appear to be at level 2 instead of 1. Columns would be better for
275;; tab handling, but the default regexp doesn't use tabs, and anyone
276;; who changes the regexp can also redefine the outline-level variable
277;; as appropriate.
278(defun outline-level ()
279 "Return the depth to which a statement is nested in the outline.
280Point must be at the beginning of a header line. This is actually
281the number of characters that `outline-regexp' matches."
282 (save-excursion
283 (looking-at outline-regexp)
284 (- (match-end 0) (match-beginning 0))))
285
286(defun outline-next-preface ()
287 "Skip forward to just before the next heading line.
288If there's no following heading line, stop before the newline
289at the end of the buffer."
290 (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
291 nil 'move)
292 (goto-char (match-beginning 0)))
293 (if (memq (preceding-char) '(?\n ?\^M))
294 (forward-char -1)))
295
296(defun outline-next-heading ()
297 "Move to the next (possibly invisible) heading line."
298 (interactive)
299 (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
300 nil 'move)
301 (goto-char (1+ (match-beginning 0)))))
302
303(defun outline-back-to-heading ()
304 "Move to previous heading line, or beg of this line if it's a heading.
305Only visible heading lines are considered."
306 (beginning-of-line)
307 (or (outline-on-heading-p)
308 (re-search-backward (concat "^\\(" outline-regexp "\\)") nil t)
309 (error "before first heading")))
310
311(defun outline-on-heading-p ()
312 "Return t if point is on a (visible) heading line."
313 (save-excursion
314 (beginning-of-line)
315 (and (bolp)
316 (looking-at outline-regexp))))
317
318(defun outline-end-of-heading ()
319 (if (re-search-forward outline-heading-end-regexp nil 'move)
320 (forward-char -1)))
321
322(defun outline-next-visible-heading (arg)
323 "Move to the next visible heading line.
324With argument, repeats or can move backward if negative.
325A heading line is one that starts with a `*' (or that
326`outline-regexp' matches)."
327 (interactive "p")
328 (if (< arg 0)
329 (beginning-of-line)
330 (end-of-line))
331 (or (re-search-forward (concat "^\\(" outline-regexp "\\)") nil t arg)
332 (error ""))
333 (beginning-of-line))
334
335(defun outline-previous-visible-heading (arg)
336 "Move to the previous heading line.
337With argument, repeats or can move forward if negative.
338A heading line is one that starts with a `*' (or that
339`outline-regexp' matches)."
340 (interactive "p")
341 (outline-next-visible-heading (- arg)))
342
343(defun outline-flag-region (from to flag)
344 "Hides or shows lines from FROM to TO, according to FLAG.
345If FLAG is `\\n' (newline character) then text is shown,
346while if FLAG is `\\^M' (control-M) the text is hidden."
347 (let (buffer-read-only)
348 (subst-char-in-region from to
349 (if (= flag ?\n) ?\^M ?\n)
350 flag t)))
351
352(defun hide-entry ()
353 "Hide the body directly following this heading."
354 (interactive)
355 (outline-back-to-heading)
356 (outline-end-of-heading)
357 (save-excursion
358 (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\^M)))
359
360(defun show-entry ()
361 "Show the body directly following this heading."
362 (interactive)
363 (save-excursion
364 (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\n)))
365
366(defun hide-body ()
367 "Hide all of buffer except headings."
368 (interactive)
369 (hide-region-body (point-min) (point-max)))
370
371(defun hide-region-body (start end)
372 "Hide all body lines in the region, but not headings."
373 (save-excursion
374 (save-restriction
375 (narrow-to-region start end)
376 (goto-char (point-min))
377 (if (outline-on-heading-p)
378 (outline-end-of-heading))
379 (while (not (eobp))
380 (outline-flag-region (point)
381 (progn (outline-next-preface) (point)) ?\^M)
382 (if (not (eobp))
383 (progn
384 (forward-char
385 (if (looking-at "[\n\^M][\n\^M]")
386 2 1))
387 (outline-end-of-heading)))))))
388
389(defun show-all ()
390 "Show all of the text in the buffer."
391 (interactive)
392 (outline-flag-region (point-min) (point-max) ?\n))
393
394(defun hide-subtree ()
395 "Hide everything after this heading at deeper levels."
396 (interactive)
397 (outline-flag-subtree ?\^M))
398
399(defun hide-leaves ()
400 "Hide all body after this heading at deeper levels."
401 (interactive)
402 (outline-back-to-heading)
403 (outline-end-of-heading)
404 (hide-region-body (point) (progn (outline-end-of-subtree) (point))))
405
406(defun show-subtree ()
407 "Show everything after this heading at deeper levels."
408 (interactive)
409 (outline-flag-subtree ?\n))
410
411(defun hide-sublevels (levels)
412 "Hide everything but the top LEVELS levels of headers, in whole buffer."
413 (interactive "p")
414 (if (< levels 1)
415 (error "Must keep at least one level of headers"))
416 (setq levels (1- levels))
417 (save-excursion
418 (goto-char (point-min))
419 ;; Keep advancing to the next top-level heading.
420 (while (or (and (bobp) (outline-on-heading-p))
421 (outline-next-heading))
422 (let ((end (save-excursion (outline-end-of-subtree) (point))))
423 ;; Hide everything under that.
424 (outline-flag-region (point) end ?\^M)
425 ;; Show the first LEVELS levels under that.
426 (if (> levels 0)
427 (show-children levels))
428 ;; Move to the next, since we already found it.
429 (goto-char end)))))
430
431(defun hide-other ()
432 "Hide everything except for the current body and the parent headings."
433 (interactive)
434 (hide-sublevels 1)
435 (let ((last (point))
436 (pos (point)))
437 (while (save-excursion
438 (and (re-search-backward "[\n\r]" nil t)
439 (eq (following-char) ?\r)))
440 (save-excursion
441 (beginning-of-line)
442 (if (eq last (point))
443 (progn
444 (outline-next-heading)
445 (outline-flag-region last (point) ?\n))
446 (show-children)
447 (setq last (point)))))))
448
449(defun outline-flag-subtree (flag)
450 (save-excursion
451 (outline-back-to-heading)
452 (outline-end-of-heading)
453 (outline-flag-region (point)
454 (progn (outline-end-of-subtree) (point))
455 flag)))
456
457(defun outline-end-of-subtree ()
458 (outline-back-to-heading)
459 (let ((opoint (point))
460 (first t)
461 (level (funcall outline-level)))
462 (while (and (not (eobp))
463 (or first (> (funcall outline-level) level)))
464 (setq first nil)
465 (outline-next-heading))
466 (if (memq (preceding-char) '(?\n ?\^M))
467 (progn
468 ;; Go to end of line before heading
469 (forward-char -1)
470 (if (memq (preceding-char) '(?\n ?\^M))
471 ;; leave blank line before heading
472 (forward-char -1))))))
473
474(defun show-branches ()
475 "Show all subheadings of this heading, but not their bodies."
476 (interactive)
477 (show-children 1000))
478
479(defun show-children (&optional level)
480 "Show all direct subheadings of this heading.
481Prefix arg LEVEL is how many levels below the current level should be shown.
482Default is enough to cause the following heading to appear."
483 (interactive "P")
484 (setq level
485 (if level (prefix-numeric-value level)
486 (save-excursion
487 (outline-back-to-heading)
488 (let ((start-level (funcall outline-level)))
489 (outline-next-heading)
490 (if (eobp)
491 1
492 (max 1 (- (funcall outline-level) start-level)))))))
493 (save-excursion
494 (save-restriction
495 (outline-back-to-heading)
496 (setq level (+ level (funcall outline-level)))
497 (narrow-to-region (point)
498 (progn (outline-end-of-subtree)
499 (if (eobp) (point-max) (1+ (point)))))
500 (goto-char (point-min))
501 (while (and (not (eobp))
502 (progn
503 (outline-next-heading)
504 (not (eobp))))
505 (if (<= (funcall outline-level) level)
506 (save-excursion
507 (outline-flag-region (save-excursion
508 (forward-char -1)
509 (if (memq (preceding-char) '(?\n ?\^M))
510 (forward-char -1))
511 (point))
512 (progn (outline-end-of-heading) (point))
513 ?\n)))))))
514
515(defun outline-up-heading (arg)
516 "Move to the heading line of which the present line is a subheading.
517With argument, move up ARG levels."
518 (interactive "p")
519 (outline-back-to-heading)
520 (if (eq (funcall outline-level) 1)
521 (error ""))
522 (while (and (> (funcall outline-level) 1)
523 (> arg 0)
524 (not (bobp)))
525 (let ((present-level (funcall outline-level)))
526 (while (not (< (funcall outline-level) present-level))
527 (outline-previous-visible-heading 1))
528 (setq arg (- arg 1)))))
529
530(defun outline-forward-same-level (arg)
531 "Move forward to the ARG'th subheading at same level as this one.
532Stop at the first and last subheadings of a superior heading."
533 (interactive "p")
534 (outline-back-to-heading)
535 (while (> arg 0)
536 (let ((point-to-move-to (save-excursion
537 (outline-get-next-sibling))))
538 (if point-to-move-to
539 (progn
540 (goto-char point-to-move-to)
541 (setq arg (1- arg)))
542 (progn
543 (setq arg 0)
544 (error ""))))))
545
546(defun outline-get-next-sibling ()
547 "Move to next heading of the same level, and return point or nil if none."
548 (let ((level (funcall outline-level)))
549 (outline-next-visible-heading 1)
550 (while (and (> (funcall outline-level) level)
551 (not (eobp)))
552 (outline-next-visible-heading 1))
553 (if (< (funcall outline-level) level)
554 nil
555 (point))))
556
557(defun outline-backward-same-level (arg)
558 "Move backward to the ARG'th subheading at same level as this one.
559Stop at the first and last subheadings of a superior heading."
560 (interactive "p")
561 (outline-back-to-heading)
562 (while (> arg 0)
563 (let ((point-to-move-to (save-excursion
564 (outline-get-last-sibling))))
565 (if point-to-move-to
566 (progn
567 (goto-char point-to-move-to)
568 (setq arg (1- arg)))
569 (progn
570 (setq arg 0)
571 (error ""))))))
572
573(defun outline-get-last-sibling ()
574 "Move to next heading of the same level, and return point or nil if none."
575 (let ((level (funcall outline-level)))
576 (outline-previous-visible-heading 1)
577 (while (and (> (funcall outline-level) level)
578 (not (bobp)))
579 (outline-previous-visible-heading 1))
580 (if (< (funcall outline-level) level)
581 nil
582 (point))))
583
584(provide 'outline)
585
586;; arch-tag: 14ed00e1-bd40-4db8-86e5-3b82ce326e45
587;;; ooutline.el ends here
diff --git a/lisp/obsolete/profile.el b/lisp/obsolete/profile.el
deleted file mode 100644
index 87b976de6b1..00000000000
--- a/lisp/obsolete/profile.el
+++ /dev/null
@@ -1,294 +0,0 @@
1;;; profile.el --- Emacs profiler (OBSOLETE; use elp.el instead)
2
3;; Copyright (C) 1992, 1994, 1998, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Author: Boaz Ben-Zvi <boaz@lcs.mit.edu>
7;; Created: 07 Feb 1992
8;; Version: 1.0
9;; Adapted-By: ESR
10;; Keywords: lisp, tools
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 3 of the License, or
17;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
26
27;;; Commentary:
28
29;; This file has been obsolete since Emacs 21.1.
30
31;; DESCRIPTION:
32;; ------------
33;; This program can be used to monitor running time performance of Emacs Lisp
34;; functions. It takes a list of functions and report the real time spent
35;; inside these functions. (Actually, for each function it reports the amount
36;; of time spent while at least one instance of that function is on the call
37;; stack. So if profiled function FOO calls profiled function BAR, the time
38;; spent inside BAR is credited to both functions.)
39
40;; HOW TO USE:
41;; -----------
42;; Set the variable profile-functions-list to the list of functions
43;; (as symbols) You want to profile. Call M-x profile-functions to set
44;; this list on and start using your program. Note that profile-functions
45;; MUST be called AFTER all the functions in profile-functions-list have
46;; been loaded !! (This call modifies the code of the profiled functions.
47;; Hence if you reload these functions, you need to call profile-functions
48;; again! ).
49;; To display the results do M-x profile-results . For example:
50;;-------------------------------------------------------------------
51;; (setq profile-functions-list '(sokoban-set-mode-line sokoban-load-game
52;; sokoban-move-vertical sokoban-move))
53;; (load "sokoban")
54;; M-x profile-functions
55;; ... I play the sokoban game ..........
56;; M-x profile-results
57;;
58;; Function Time (Seconds.Useconds)
59;; ======== =======================
60;; sokoban-move 0.539088
61;; sokoban-move-vertical 0.410130
62;; sokoban-load-game 0.453235
63;; sokoban-set-mode-line 1.949203
64;;-----------------------------------------------------
65;; To clear all the settings to profile use profile-finish.
66;; To set one function at a time (instead of or in addition to setting the
67;; above list and M-x profile-functions) use M-x profile-a-function.
68
69;;; Code:
70
71;;;
72;;; User modifiable VARIABLES
73;;;
74
75(defvar profile-functions-list nil "*List of functions to profile.")
76(defvar profile-buffer "*profile*"
77 "Name of profile buffer.")
78(defvar profile-distinct nil
79 "If non-nil, each time slice gets credited to at most one function.
80\(Namely, the most recent one in the call stack.) If nil, then the
81time reported for a function includes the entire time from beginning
82to end, even if it called some other function that was also profiled.")
83
84;;;
85;;; V A R I A B L E S
86;;;
87
88(defvar profile-time-list nil
89 "List of cumulative calls and time for each profiled function.
90Each element looks like (FUN NCALLS SEC . USEC).")
91(defvar profile-init-list nil
92 "List of entry time for each function.
93Both how many times invoked and real time of start.
94Each element looks like (FUN DEPTH HISEC LOSEC USEC), where DEPTH is
95the current recursion depth, and HISEC, LOSEC, and USEC represent the
96starting time of the call (or of the outermost recursion).")
97(defvar profile-max-fun-name 0
98 "Max length of name of any function profiled.")
99(defvar profile-call-stack nil
100 "A list of the profiled functions currently executing.
101Used only when profile-distinct is non-nil.")
102(defvar profile-last-time nil
103 "The start time of the current time slice.
104Used only when profile-distinct is non-nil.")
105
106(defconst profile-million 1000000)
107
108;;;
109;;; F U N C T I O N S
110;;;
111
112(defun profile-functions (&optional flist)
113 "Profile all the functions listed in `profile-functions-list'.
114With argument FLIST, use the list FLIST instead."
115 (interactive "P")
116 (mapcar 'profile-a-function (or flist profile-functions-list)))
117
118(defun profile-print (entry)
119 "Print one ENTRY (from `profile-time-list')."
120 (let* ((calls (car (cdr entry)))
121 (timec (cdr (cdr entry)))
122 (avgtime (and (not (zerop calls))
123 (/ (+ (car timec)
124 (/ (cdr timec) (float profile-million)))
125 calls))))
126 (insert (format (concat "%-"
127 (int-to-string profile-max-fun-name)
128 "s %7d %10d.%06d")
129 (car entry) calls (car timec) (cdr timec))
130 (if (null avgtime)
131 "\n"
132 (format " %18.6f\n" avgtime)))))
133
134(defun profile-results ()
135 "Display profiling results in the buffer `*profile*'.
136\(The buffer name comes from `profile-buffer'.)"
137 (interactive)
138 (switch-to-buffer profile-buffer)
139 (erase-buffer)
140 (insert "Function" (make-string (- profile-max-fun-name 6) ? ))
141 (insert " Calls Total time (sec) Avg time per call\n")
142 (insert (make-string profile-max-fun-name ?=) " ")
143 (insert "====== ================ =================\n")
144 (mapcar 'profile-print profile-time-list))
145
146(defun profile-add-time (dest now prev)
147 "Add to DEST the difference between timestamps NOW and PREV.
148DEST is a pair (SEC . USEC) which is modified in place.
149NOW and PREV are triples as returned by `current-time'."
150 (let ((sec (+ (car dest)
151 (* 65536 (- (car now) (car prev)))
152 (- (cadr now) (cadr prev))))
153 (usec (+ (cdr dest)
154 (- (car (cddr now)) (car (cddr prev))))))
155 (if (< usec 0)
156 (setq sec (1- sec)
157 usec (+ usec profile-million))
158 (if (>= usec profile-million)
159 (setq sec (1+ sec)
160 usec (- usec profile-million))))
161 (setcar dest sec)
162 (setcdr dest usec)))
163
164(defun profile-function-prolog (fun)
165 "Mark the beginning of a call to function FUN."
166 (if profile-distinct
167 (let ((profile-time (current-time)))
168 (if profile-call-stack
169 (profile-add-time (cdr (cdr (assq (car profile-call-stack)
170 profile-time-list)))
171 profile-time profile-last-time))
172 (setq profile-call-stack (cons fun profile-call-stack)
173 profile-last-time profile-time))
174 (let ((profile-time (current-time))
175 (init-time (cdr (assq fun profile-init-list))))
176 (if (null init-time) (error "Function %s missing from list" fun))
177 (if (not (zerop (car init-time)));; is it a recursive call ?
178 (setcar init-time (1+ (car init-time)))
179 (setcar init-time 1) ; mark first entry
180 (setcdr init-time profile-time)))))
181
182(defun profile-function-epilog (fun)
183 "Mark the end of a call to function FUN."
184 (if profile-distinct
185 (let ((profile-time (current-time))
186 (accum (cdr (assq fun profile-time-list))))
187 (setcar accum (1+ (car accum)))
188 (profile-add-time (cdr accum) profile-time profile-last-time)
189 (setq profile-call-stack (cdr profile-call-stack)
190 profile-last-time profile-time))
191 (let ((profile-time (current-time))
192 (init-time (cdr (assq fun profile-init-list)))
193 (accum (cdr (assq fun profile-time-list))))
194 (if (or (null init-time)
195 (null accum))
196 (error "Function %s missing from list" fun))
197 (setcar init-time (1- (car init-time))) ; pop one level in recursion
198 ;; Update only if we've finished the outermost recursive call
199 (when (zerop (car init-time))
200 (setcar accum (1+ (car accum)))
201 (profile-add-time (cdr accum) profile-time (cdr init-time))))))
202
203(defun profile-convert-byte-code (function)
204 (let ((defn (symbol-function function)))
205 (if (byte-code-function-p defn)
206 ;; It is a compiled code object.
207 (let* ((contents (append defn nil))
208 (body
209 (list (list 'byte-code (nth 1 contents)
210 (nth 2 contents) (nth 3 contents)))))
211 (if (nthcdr 5 contents)
212 (setq body (cons (list 'interactive (nth 5 contents)) body)))
213 (if (nth 4 contents)
214 ;; Use `documentation' here, to get the actual string,
215 ;; in case the compiled function has a reference
216 ;; to the .elc file.
217 (setq body (cons (documentation function) body)))
218 (fset function (cons 'lambda (cons (car contents) body)))))))
219
220(defun profile-a-function (fun)
221 "Profile the function FUN."
222 (interactive "aFunction to profile: ")
223 (let ((def (symbol-function fun)))
224 (when (eq (car-safe def) 'autoload)
225 (load (car (cdr def)))
226 (setq def (symbol-function fun)))
227 (fetch-bytecode def))
228 (profile-convert-byte-code fun)
229 (let ((def (symbol-function fun)) (funlen (length (symbol-name fun))))
230 (or (eq (car def) 'lambda)
231 (error "To profile: %s must be a user-defined function" fun))
232 (setq profile-time-list ; add a new entry
233 (cons (cons fun (cons 0 (cons 0 0))) profile-time-list))
234 (setq profile-init-list ; add a new entry
235 (cons (cons fun (cons 0 nil)) profile-init-list))
236 (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen))
237 (fset fun (profile-fix-fun fun def))))
238
239(defun profile-fix-fun (fun def)
240 "Take function FUN and return it fixed for profiling.
241DEF is (symbol-function FUN)."
242 (if (< (length def) 3)
243 def ; nothing to change
244 (let ((prefix (list (car def) (car (cdr def))))
245 (suffix (cdr (cdr def))))
246 ;; Skip the doc string, if there is a string
247 ;; which serves only as a doc string,
248 ;; and put it in PREFIX.
249 (if (and (stringp (car suffix)) (cdr suffix))
250 (setq prefix (nconc prefix (list (car suffix)))
251 suffix (cdr suffix)))
252 ;; Check for an interactive spec.
253 ;; If found, put it into PREFIX and skip it.
254 (if (and (listp (car suffix))
255 (eq (car (car suffix)) 'interactive))
256 (setq prefix (nconc prefix (list (car suffix)))
257 suffix (cdr suffix)))
258 (if (eq (car-safe (car suffix)) 'profile-function-prolog)
259 def ; already profiled
260 ;; Prepare new function definition.
261 ;; If you change this structure, also change profile-restore-fun.
262 (nconc prefix
263 (list (list 'profile-function-prolog
264 (list 'quote fun))
265 (list 'unwind-protect
266 (cons 'progn suffix)
267 (list 'profile-function-epilog
268 (list 'quote fun)))))))))
269
270(defun profile-restore-fun (fun)
271 "Restore profiled function FUN to its original state."
272 (let ((def (symbol-function fun)) body index)
273 ;; move index beyond header
274 (setq index (cdr-safe def))
275 (if (stringp (car (cdr index)))
276 (setq index (cdr index)))
277 (if (eq (car-safe (car (cdr index))) 'interactive)
278 (setq index (cdr index)))
279 (if (eq (car-safe (car (cdr index))) 'profile-function-prolog)
280 (setcdr index (cdr (car (cdr (car (cdr (cdr index))))))))))
281
282(defun profile-finish ()
283 "Stop profiling functions. Clear all the settings."
284 (interactive)
285 (while profile-time-list
286 (profile-restore-fun (car (car profile-time-list)))
287 (setq profile-time-list (cdr profile-time-list)))
288 (setq profile-max-fun-name 0)
289 (setq profile-init-list nil))
290
291(provide 'profile)
292
293;; arch-tag: 816f97e8-efff-4da2-9a95-7bc392f58b19
294;;; profile.el ends here
diff --git a/lisp/obsolete/rsz-mini.el b/lisp/obsolete/rsz-mini.el
deleted file mode 100644
index d5c8e2e476a..00000000000
--- a/lisp/obsolete/rsz-mini.el
+++ /dev/null
@@ -1,84 +0,0 @@
1;;; rsz-mini.el --- dynamically resize minibuffer to display entire contents
2
3;; Copyright (C) 1990, 1993, 1994, 1995, 1997, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Author: Noah Friedman <friedman@splode.com>
7;; Roland McGrath <roland@gnu.org>
8;; Maintainer: Noah Friedman <friedman@splode.com>
9;; Keywords: minibuffer, window, frame, display
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27
28;; This file has been obsolete since Emacs 21.1.
29
30;; This package is obsolete. Emacs now resizes mini-windows automatically.
31
32;;; Code:
33
34
35(defgroup resize-minibuffer nil
36 "This customization group is obsolete."
37 :group 'frames)
38
39;;;###autoload
40(defcustom resize-minibuffer-mode nil
41 "*This variable is obsolete."
42 :type 'boolean
43 :group 'resize-minibuffer
44 :require 'rsz-mini)
45
46;;;###autoload
47(defcustom resize-minibuffer-window-max-height nil
48 "*This variable is obsolete."
49 :type '(choice (const nil) integer)
50 :group 'resize-minibuffer)
51
52;;;###autoload
53(defcustom resize-minibuffer-window-exactly t
54 "*This variable is obsolete."
55 :type 'boolean
56 :group 'resize-minibuffer)
57
58;;;###autoload
59(defcustom resize-minibuffer-frame nil
60 "*This variable is obsolete."
61 :type 'boolean
62 :group 'resize-minibuffer)
63
64;;;###autoload
65(defcustom resize-minibuffer-frame-max-height nil
66 "*This variable is obsolete."
67 :group 'resize-minibuffer)
68
69;;;###autoload
70(defcustom resize-minibuffer-frame-exactly t
71 "*This variable is obsolete."
72 :type 'boolean
73 :group 'resize-minibuffer)
74
75
76;;;###autoload
77(defun resize-minibuffer-mode (&optional prefix)
78 "This function is obsolete."
79 (interactive "P"))
80
81(provide 'rsz-mini)
82
83;; arch-tag: 3cb85d51-ab33-4e46-8362-dd87a5d06c99
84;;; rsz-mini.el ends here
diff --git a/lisp/obsolete/uncompress.el b/lisp/obsolete/uncompress.el
deleted file mode 100644
index 2304ee50889..00000000000
--- a/lisp/obsolete/uncompress.el
+++ /dev/null
@@ -1,115 +0,0 @@
1;;; uncompress.el --- auto-decompression hook for visiting .Z files
2
3;; Copyright (C) 1992, 1994, 2001, 2002, 2003, 2004,
4;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6;; Maintainer: FSF
7;; Keywords: files
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 3 of the License, or
14;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; This file has been obsolete since Emacs 21.1.
27
28;; This package can be used to arrange for automatic uncompress of
29;; compressed files when they are visited.
30;; All that's necessary is to load it. This can conveniently be done from
31;; your .emacs file.
32
33;; M-x auto-compression-mode is a more modern replacement for this package.
34
35;;; Code:
36
37;; When we are about to make a backup file,
38;; uncompress the file we visited
39;; so that making the backup can work properly.
40;; This is used as a write-file-hook.
41
42(defvar uncompress-program "gunzip"
43 "Program to use for uncompression.")
44
45(defun uncompress-backup-file ()
46 (and buffer-file-name make-backup-files (not buffer-backed-up)
47 (not (file-exists-p buffer-file-name))
48 (call-process uncompress-program nil nil nil buffer-file-name))
49 nil)
50
51(or (assoc "\\.Z$" auto-mode-alist)
52 (setq auto-mode-alist
53 (cons '("\\.Z$" . uncompress-while-visiting) auto-mode-alist)))
54(or (assoc "\\.gz$" auto-mode-alist)
55 (setq auto-mode-alist
56 (cons '("\\.gz$" . uncompress-while-visiting) auto-mode-alist)))
57(or (assoc "\\.tgz$" auto-mode-alist)
58 (setq auto-mode-alist
59 (cons '("\\.tgz$" . uncompress-while-visiting) auto-mode-alist)))
60
61(defun uncompress-while-visiting ()
62 "Temporary \"major mode\" used for .Z and .gz files, to uncompress them.
63It then selects a major mode from the uncompressed file name and contents."
64 (if (and (not (null buffer-file-name))
65 (string-match "\\.Z$" buffer-file-name))
66 (set-visited-file-name
67 (substring buffer-file-name 0 (match-beginning 0)))
68 (if (and (not (null buffer-file-name))
69 (string-match "\\.gz$" buffer-file-name))
70 (set-visited-file-name
71 (substring buffer-file-name 0 (match-beginning 0)))
72 (if (and (not (null buffer-file-name))
73 (string-match "\\.tgz$" buffer-file-name))
74 (set-visited-file-name
75 (concat (substring buffer-file-name 0 (match-beginning 0)) ".tar")))))
76 (message "Uncompressing...")
77 (let ((buffer-read-only nil)
78 (coding-system-for-write 'no-conversion)
79 (coding-system-for-read
80 (car (find-operation-coding-system
81 'insert-file-contents
82 buffer-file-name t))))
83 (shell-command-on-region (point-min) (point-max) uncompress-program t))
84 (goto-char (point-min))
85 (message "Uncompressing...done")
86 (set-buffer-modified-p nil)
87 (add-hook 'write-file-functions 'uncompress-backup-file nil t)
88 (normal-mode))
89
90(add-hook 'find-file-not-found-functions 'find-compressed-version)
91
92(defun find-compressed-version ()
93 "Hook to read and uncompress the compressed version of a file."
94 ;; Just pretend we had visited the compressed file,
95 ;; and uncompress-while-visiting will do the rest.
96 (let (name)
97 (if (file-exists-p (setq name (concat buffer-file-name ".Z")))
98 (setq buffer-file-name name)
99 (if (file-exists-p (setq name (concat buffer-file-name ".gz")))
100 (setq buffer-file-name name)))
101 (if (eq name buffer-file-name)
102 (progn
103 (insert-file-contents buffer-file-name t)
104 (goto-char (point-min))
105 ;; No need for this, because error won't be set to t
106 ;; if this function returns t.
107 ;; (setq error nil)
108 t))))
109
110(message "The uncompress package is obsolete; use M-x auto-compression-mode")
111
112(provide 'uncompress)
113
114;; arch-tag: 626658d4-fcce-499a-990d-d165f2ed7da3
115;;; uncompress.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-18 03:15:45 +0000