summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorStefan Monnier <monnier@iro.umontreal.ca>2008-06-03 08:08:01 +0000
committerStefan Monnier <monnier@iro.umontreal.ca>2008-06-03 08:08:01 +0000
commita87c1daf657350ebae2cc9935d10dacde0b6f00a (patch)
tree1c59290a7291fa76725a15e5b57401adb5e5193f
parent8d27bcdf2e758dc6a4868c8fdee65b9a93101b67 (diff)
* 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.
-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 ec5be377aa..da9be57157 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,12 @@
2008-06-03 Stefan Monnier <monnier@iro.umontreal.ca>
+ * 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.
+
* vc-dispatcher.el (vc-dir-menu-map-filter): Don't fail if
vc-client-mode is not set.
diff --git a/lisp/obsolete/auto-show.el b/lisp/obsolete/auto-show.el
deleted file mode 100644
index 2fc3d25fee..0000000000
--- a/lisp/obsolete/auto-show.el
+++ /dev/null
@@ -1,54 +0,0 @@
-;;; auto-show.el --- perform automatic horizontal scrolling as point moves
-;;; This file is in the public domain.
-
-;; This file is part of GNU Emacs.
-
-;; Keywords: scroll display convenience
-;; Author: Pete Ware <ware@cis.ohio-state.edu>
-;; Maintainer: FSF
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;; This file contains dummy variables and functions only because Emacs
-;; does hscrolling automatically, now.
-
-;;; Code:
-
-(defgroup auto-show nil
- "This customization group is kept for compatibility only.
-Emacs now does hscrolling automatically. Please remove references
-to auto-show from your init file and code."
- :group 'editing)
-
-;;;###autoload
-(defcustom auto-show-mode nil
- "Obsolete."
- :version "20.4"
- :type 'boolean
- :group 'auto-show)
-
-(defcustom auto-show-shift-amount 8
- "*Obsolete."
- :type 'integer
- :group 'auto-show)
-
-(defcustom auto-show-show-left-margin-threshold 50
- "*Obsolete."
- :type 'integer
- :group 'auto-show)
-
-;;;###autoload
-(defun auto-show-mode (arg)
- "This command is obsolete."
- (interactive "P"))
-
-(defun auto-show-make-point-visible (&optional ignore-arg)
- "This command is obsolete."
- (interactive))
-
-(provide 'auto-show)
-
-;; arch-tag: 49587cbf-95cc-4061-b564-274aaec37469
-;;; auto-show.el ends here
diff --git a/lisp/obsolete/bg-mouse.el b/lisp/obsolete/bg-mouse.el
deleted file mode 100644
index 153dd98e3b..0000000000
--- a/lisp/obsolete/bg-mouse.el
+++ /dev/null
@@ -1,308 +0,0 @@
-;;; bg-mouse.el --- GNU Emacs code for BBN Bitgraph mouse
-
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Author: John Robinson <jr@bbn-unix.arpa>
-;; Stephen Gildea <gildea@bbn.com>
-;; Maintainer: FSF
-;; Keywords: hardware
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 22.1.
-
-;;; Code:
-
-;;; Original version by John Robinson (jr@bbn-unix.arpa, bbncca!jr), Oct 1985
-;;; Modularized and enhanced by gildea@bbn.com Nov 1987
-;;; Time stamp <89/03/21 14:27:08 gildea>
-
-;;; User customization option:
-
-(defvar bg-mouse-fast-select-window nil
- "*Non-nil for mouse hits to select new window, then execute; else just select.")
-
-;;; These numbers are summed to make the index into the mouse-map.
-;;; The low three bits correspond to what the mouse actually sends.
-(defconst bg-button-r 1)
-(defconst bg-button-m 2)
-(defconst bg-button-c 2)
-(defconst bg-button-l 4)
-(defconst bg-in-modeline 8)
-(defconst bg-in-scrollbar 16)
-(defconst bg-in-minibuf 24)
-
-;;; semicolon screws up indenting, so use this instead
-(defconst semicolon ?\;)
-
-(defvar bg-mouse-x)
-(defvar bg-mouse-y)
-(defvar bg-cursor-window)
-;; This variable does not exist since 1991, so it's a safe bet
-;; this package is not really used anymore. Still...
-(defvar mouse-map)
-
-;;; Defuns:
-
-(defun bg-mouse-report (prefix-arg)
- "Read, parse, and execute a BBN BitGraph mouse click.
-
-L-- move point | These apply for mouse click in a window.
---R set mark | If bg-mouse-fast-select-window is nil,
-L-R kill region | these commands on a nonselected window
--C- move point and yank | just select that window.
-LC- yank-pop |
--CR or LCR undo | \"Scroll bar\" is right-hand window column.
-
-on modeline: on \"scroll bar\": in minibuffer:
-L-- scroll-up line to top execute-extended-command
---R scroll-down line to bottom eval-expression
--C- proportional goto-char line to middle suspend-emacs
-
-To reinitialize the mouse if the terminal is reset, type ESC : RET"
- (interactive "P")
- (bg-get-tty-num semicolon)
- (let*
- ((screen-mouse-x (min (1- (frame-width)) ;don't hit column 86!
- (/ (bg-get-tty-num semicolon) 9)))
- (screen-mouse-y (- (1- (frame-height)) ;assume default font size.
- (/ (bg-get-tty-num semicolon) 16)))
- (bg-mouse-buttons (% (bg-get-tty-num ?c) 8))
- (bg-mouse-window (bg-window-from-x-y screen-mouse-x screen-mouse-y))
- (bg-cursor-window (selected-window))
- (edges (window-edges bg-mouse-window))
- (minibuf-p (= screen-mouse-y (1- (frame-height))))
- (in-modeline-p (and (not minibuf-p)
- (= screen-mouse-y (1- (nth 3 edges)))))
- (in-scrollbar-p (and (not minibuf-p) (not in-modeline-p)
- (>= screen-mouse-x (1- (nth 2 edges)))))
- (same-window-p (eq bg-mouse-window bg-cursor-window))
- (in-minibuf-p (and minibuf-p
- (not bg-mouse-window))) ;minibuf must be inactive
- (bg-mode-bits (+ (if in-minibuf-p bg-in-minibuf 0)
- (if in-modeline-p bg-in-modeline 0)
- (if in-scrollbar-p bg-in-scrollbar 0)))
- (bg-command
- (lookup-key mouse-map
- (char-to-string (+ bg-mode-bits bg-mouse-buttons))))
- (bg-mouse-x (- screen-mouse-x (nth 0 edges)))
- (bg-mouse-y (- screen-mouse-y (nth 1 edges))))
- (cond ((or in-modeline-p in-scrollbar-p)
- (select-window bg-mouse-window)
- (bg-command-execute bg-command)
- (select-window bg-cursor-window))
- ((or same-window-p in-minibuf-p)
- (bg-command-execute bg-command))
- (t ;in another window
- (select-window bg-mouse-window)
- (if bg-mouse-fast-select-window
- (bg-command-execute bg-command)))
- )))
-
-
-;;; Library of commands:
-
-(defun bg-set-point ()
- "Move point to location of BitGraph mouse."
- (interactive)
- (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
- (setq this-command 'next-line) ;make subsequent line moves work
- (setq temporary-goal-column bg-mouse-x))
-
-(defun bg-set-mark ()
- "Set mark at location of BitGraph mouse."
- (interactive)
- (push-mark)
- (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
- (exchange-point-and-mark))
-
-(defun bg-yank ()
- "Move point to location of BitGraph mouse and yank."
- (interactive "*")
- (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
- (setq this-command 'yank)
- (yank))
-
-(defun yank-pop-1 ()
- (interactive "*")
- (yank-pop 1))
-
-(defun bg-yank-or-pop ()
- "Move point to location of BitGraph mouse and yank. If last command
-was a yank, do a yank-pop."
- (interactive "*")
- (if (eq last-command 'yank)
- (yank-pop 1)
- (bg-yank)))
-
-;;; In 18.51, Emacs Lisp doesn't provide most-positive-fixnum
-(defconst bg-most-positive-fixnum 8388607)
-
-(defun bg-move-by-percentage ()
- "Go to location in buffer that is the same percentage of the way
-through the buffer as the BitGraph mouse's X position in the window."
- (interactive)
- ;; check carefully for overflow in intermediate calculations
- (goto-char
- (cond ((zerop bg-mouse-x)
- 0)
- ((< (buffer-size) (/ bg-most-positive-fixnum bg-mouse-x))
- ;; no danger of overflow: compute it exactly
- (/ (* bg-mouse-x (buffer-size))
- (1- (window-width))))
- (t
- ;; overflow possible: approximate
- (* (/ (buffer-size) (1- (window-width)))
- bg-mouse-x))))
- (beginning-of-line)
- (what-cursor-position))
-
-(defun bg-mouse-line-to-top ()
- "Scroll the line pointed to by the BitGraph mouse to the top of the window."
- (interactive)
- (scroll-up bg-mouse-y))
-
-(defun bg-mouse-line-to-center ()
- "Scroll the line pointed to by the BitGraph mouse to the center
-of the window"
- (interactive)
- (scroll-up (/ (+ 2 bg-mouse-y bg-mouse-y (- (window-height))) 2)))
-
-(defun bg-mouse-line-to-bottom ()
- "Scroll the line pointed to by the mouse to the bottom of the window."
- (interactive)
- (scroll-up (+ bg-mouse-y (- 2 (window-height)))))
-
-(defun bg-kill-region ()
- (interactive "*")
- (kill-region (region-beginning) (region-end)))
-
-(defun bg-insert-moused-sexp ()
- "Insert a copy of the word (actually sexp) that the mouse is pointing at.
-Sexp is inserted into the buffer at point (where the text cursor is)."
- (interactive)
- (let ((moused-text
- (save-excursion
- (bg-move-point-to-x-y bg-mouse-x bg-mouse-y)
- (if (looking-at "\\s)")
- (forward-char 1)
- (forward-sexp 1))
- (buffer-substring (save-excursion (backward-sexp 1) (point))
- (point)))))
- (select-window bg-cursor-window)
- (delete-horizontal-space)
- (cond
- ((bolp)
- (indent-according-to-mode))
- ;; In Lisp assume double-quote is closing; in Text assume opening.
- ;; Why? Because it does the right thing most often.
- ((save-excursion (forward-char -1)
- (and (not (looking-at "\\s\""))
- (looking-at "[`'\"\\]\\|\\s(")))
- nil)
- (t
- (insert " ")))
- (insert moused-text)
- (or (eolp)
- (looking-at "\\s.\\|\\s)")
- (and (looking-at "'") (looking-at "\\sw")) ;hack for text mode
- (save-excursion (insert " ")))))
-
-;;; Utility functions:
-
-(defun bg-get-tty-num (term-char)
- "Read from terminal until TERM-CHAR is read, and return intervening number.
-If non-numeric not matching TERM-CHAR, reprogram the mouse and signal an error."
- (let
- ((num 0)
- (char (- (read-char) 48)))
- (while (and (>= char 0)
- (<= char 9))
- (setq num (+ (* num 10) char))
- (setq char (- (read-char) 48)))
- (or (eq term-char (+ char 48))
- (progn
- (bg-program-mouse)
- (error
- "Invalid data format in bg-mouse command: mouse reinitialized.")))
- num))
-
-;;; Note that this fails in the minibuf because move-to-column doesn't
-;;; allow for the width of the prompt.
-(defun bg-move-point-to-x-y (x y)
- "Position cursor in window coordinates.
-X and Y are 0-based character positions in the window."
- (move-to-window-line y)
- ;; if not on a wrapped line, zero-column will be 0
- (let ((zero-column (current-column))
- (scroll-offset (window-hscroll)))
- ;; scrolling takes up column 0 to display the $
- (if (> scroll-offset 0)
- (setq scroll-offset (1- scroll-offset)))
- (move-to-column (+ zero-column scroll-offset x))
- ))
-
-;;; Returns the window that screen position (x, y) is in or nil if none,
-;;; meaning we are in the echo area with a non-active minibuffer.
-(defun bg-window-from-x-y (x y)
- "Find window corresponding to screen coordinates.
-X and Y are 0-based character positions on the screen."
- (get-window-with-predicate (lambda (w)
- (coordinates-in-window-p (cons x y) w))))
-
-(defun bg-command-execute (bg-command)
- (if (commandp bg-command)
- (command-execute bg-command)
- (ding)))
-
-(defun bg-program-mouse ()
- (send-string-to-terminal "\e:0;7;;;360;512;9;16;9;16c"))
-
-;;; Note that the doc string for mouse-map (as defined in subr.el)
-;;; says it is for the X-window mouse. This is wrong; that keymap
-;;; should be used for your mouse no matter what terminal you have.
-
-(or (keymapp mouse-map)
- (setq mouse-map (make-keymap)))
-
-(defun bind-bg-mouse-click (click-code function)
- "Bind bg-mouse CLICK-CODE to run FUNCTION."
- (define-key mouse-map (char-to-string click-code) function))
-
-(bind-bg-mouse-click bg-button-l 'bg-set-point)
-(bind-bg-mouse-click bg-button-m 'bg-yank)
-(bind-bg-mouse-click bg-button-r 'bg-set-mark)
-(bind-bg-mouse-click (+ bg-button-l bg-button-m) 'yank-pop-1)
-(bind-bg-mouse-click (+ bg-button-l bg-button-r) 'bg-kill-region)
-(bind-bg-mouse-click (+ bg-button-m bg-button-r) 'undo)
-(bind-bg-mouse-click (+ bg-button-l bg-button-m bg-button-r) 'undo)
-(bind-bg-mouse-click (+ bg-in-modeline bg-button-l) 'scroll-up)
-(bind-bg-mouse-click (+ bg-in-modeline bg-button-m) 'bg-move-by-percentage)
-(bind-bg-mouse-click (+ bg-in-modeline bg-button-r) 'scroll-down)
-(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-l) 'bg-mouse-line-to-top)
-(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-m) 'bg-mouse-line-to-center)
-(bind-bg-mouse-click (+ bg-in-scrollbar bg-button-r) 'bg-mouse-line-to-bottom)
-(bind-bg-mouse-click (+ bg-in-minibuf bg-button-l) 'execute-extended-command)
-(bind-bg-mouse-click (+ bg-in-minibuf bg-button-m) 'suspend-emacs)
-(bind-bg-mouse-click (+ bg-in-minibuf bg-button-r) 'eval-expression)
-
-(provide 'bg-mouse)
-
-;; arch-tag: b3d06605-2971-44b1-be2c-e49c24e1a8d3
-;;; bg-mouse.el ends here
diff --git a/lisp/obsolete/float.el b/lisp/obsolete/float.el
deleted file mode 100644
index e86b8633f4..0000000000
--- a/lisp/obsolete/float.el
+++ /dev/null
@@ -1,460 +0,0 @@
-;;; float.el --- obsolete floating point arithmetic package
-
-;; Copyright (C) 1986, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Author: Bill Rosenblatt
-;; Maintainer: FSF
-;; Keywords: extensions
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 22.1.
-
-;; Floating point numbers are represented by dot-pairs (mant . exp)
-;; where mant is the 24-bit signed integral mantissa and exp is the
-;; base 2 exponent.
-;;
-;; Emacs LISP supports a 24-bit signed integer data type, which has a
-;; range of -(2**23) to +(2**23)-1, or -8388608 to 8388607 decimal.
-;; This gives six significant decimal digit accuracy. Exponents can
-;; be anything in the range -(2**23) to +(2**23)-1.
-;;
-;; User interface:
-;; function f converts from integer to floating point
-;; function string-to-float converts from string to floating point
-;; function fint converts a floating point to integer (with truncation)
-;; function float-to-string converts from floating point to string
-;;
-;; Caveats:
-;; - Exponents outside of the range of +/-100 or so will cause certain
-;; functions (especially conversion routines) to take forever.
-;; - Very little checking is done for fixed point overflow/underflow.
-;; - No checking is done for over/underflow of the exponent
-;; (hardly necessary when exponent can be 2**23).
-;;
-;;
-;; Bill Rosenblatt
-;; June 20, 1986
-;;
-
-;;; Code:
-
-;; fundamental implementation constants
-(defconst exp-base 2
- "Base of exponent in this floating point representation.")
-
-(defconst mantissa-bits 24
- "Number of significant bits in this floating point representation.")
-
-(defconst decimal-digits 6
- "Number of decimal digits expected to be accurate.")
-
-(defconst expt-digits 2
- "Maximum permitted digits in a scientific notation exponent.")
-
-;; other constants
-(defconst maxbit (1- mantissa-bits)
- "Number of highest bit")
-
-(defconst mantissa-maxval (1- (ash 1 maxbit))
- "Maximum permissible value of mantissa")
-
-(defconst mantissa-minval (ash 1 maxbit)
- "Minimum permissible value of mantissa")
-
-(defconst floating-point-regexp
- "^[ \t]*\\(-?\\)\\([0-9]*\\)\
-\\(\\.\\([0-9]*\\)\\|\\)\
-\\(\\(\\([Ee]\\)\\(-?\\)\\([0-9][0-9]*\\)\\)\\|\\)[ \t]*$"
- "Regular expression to match floating point numbers. Extract matches:
-1 - minus sign
-2 - integer part
-4 - fractional part
-8 - minus sign for power of ten
-9 - power of ten
-")
-
-(defconst high-bit-mask (ash 1 maxbit)
- "Masks all bits except the high-order (sign) bit.")
-
-(defconst second-bit-mask (ash 1 (1- maxbit))
- "Masks all bits except the highest-order magnitude bit")
-
-;; various useful floating point constants
-(defconst _f0 '(0 . 1))
-
-(defconst _f1/2 '(4194304 . -23))
-
-(defconst _f1 '(4194304 . -22))
-
-(defconst _f10 '(5242880 . -19))
-
-;; support for decimal conversion routines
-(defvar powers-of-10 (make-vector (1+ decimal-digits) _f1))
-(aset powers-of-10 1 _f10)
-(aset powers-of-10 2 '(6553600 . -16))
-(aset powers-of-10 3 '(8192000 . -13))
-(aset powers-of-10 4 '(5120000 . -9))
-(aset powers-of-10 5 '(6400000 . -6))
-(aset powers-of-10 6 '(8000000 . -3))
-
-(defconst all-decimal-digs-minval (aref powers-of-10 (1- decimal-digits)))
-(defconst highest-power-of-10 (aref powers-of-10 decimal-digits))
-
-(defun fashl (fnum) ; floating-point arithmetic shift left
- (cons (ash (car fnum) 1) (1- (cdr fnum))))
-
-(defun fashr (fnum) ; floating point arithmetic shift right
- (cons (ash (car fnum) -1) (1+ (cdr fnum))))
-
-(defun normalize (fnum)
- (if (> (car fnum) 0) ; make sure next-to-highest bit is set
- (while (zerop (logand (car fnum) second-bit-mask))
- (setq fnum (fashl fnum)))
- (if (< (car fnum) 0) ; make sure highest bit is set
- (while (zerop (logand (car fnum) high-bit-mask))
- (setq fnum (fashl fnum)))
- (setq fnum _f0))) ; "standard 0"
- fnum)
-
-(defun abs (n) ; integer absolute value
- (if (>= n 0) n (- n)))
-
-(defun fabs (fnum) ; re-normalize after taking abs value
- (normalize (cons (abs (car fnum)) (cdr fnum))))
-
-(defun xor (a b) ; logical exclusive or
- (and (or a b) (not (and a b))))
-
-(defun same-sign (a b) ; two f-p numbers have same sign?
- (not (xor (natnump (car a)) (natnump (car b)))))
-
-(defun extract-match (str i) ; used after string-match
- (condition-case ()
- (substring str (match-beginning i) (match-end i))
- (error "")))
-
-;; support for the multiplication function
-(defconst halfword-bits (/ mantissa-bits 2)) ; bits in a halfword
-(defconst masklo (1- (ash 1 halfword-bits))) ; isolate the lower halfword
-(defconst maskhi (lognot masklo)) ; isolate the upper halfword
-(defconst round-limit (ash 1 (/ halfword-bits 2)))
-
-(defun hihalf (n) ; return high halfword, shifted down
- (ash (logand n maskhi) (- halfword-bits)))
-
-(defun lohalf (n) ; return low halfword
- (logand n masklo))
-
-;; Visible functions
-
-;; Arithmetic functions
-(defun f+ (a1 a2)
- "Returns the sum of two floating point numbers."
- (let ((f1 (fmax a1 a2))
- (f2 (fmin a1 a2)))
- (if (same-sign a1 a2)
- (setq f1 (fashr f1) ; shift right to avoid overflow
- f2 (fashr f2)))
- (normalize
- (cons (+ (car f1) (ash (car f2) (- (cdr f2) (cdr f1))))
- (cdr f1)))))
-
-(defun f- (a1 &optional a2) ; unary or binary minus
- "Returns the difference of two floating point numbers."
- (if a2
- (f+ a1 (f- a2))
- (normalize (cons (- (car a1)) (cdr a1)))))
-
-(defun f* (a1 a2) ; multiply in halfword chunks
- "Returns the product of two floating point numbers."
- (let* ((i1 (car (fabs a1)))
- (i2 (car (fabs a2)))
- (sign (not (same-sign a1 a2)))
- (prodlo (+ (hihalf (* (lohalf i1) (lohalf i2)))
- (lohalf (* (hihalf i1) (lohalf i2)))
- (lohalf (* (lohalf i1) (hihalf i2)))))
- (prodhi (+ (* (hihalf i1) (hihalf i2))
- (hihalf (* (hihalf i1) (lohalf i2)))
- (hihalf (* (lohalf i1) (hihalf i2)))
- (hihalf prodlo))))
- (if (> (lohalf prodlo) round-limit)
- (setq prodhi (1+ prodhi))) ; round off truncated bits
- (normalize
- (cons (if sign (- prodhi) prodhi)
- (+ (cdr (fabs a1)) (cdr (fabs a2)) mantissa-bits)))))
-
-(defun f/ (a1 a2) ; SLOW subtract-and-shift algorithm
- "Returns the quotient of two floating point numbers."
- (if (zerop (car a2)) ; if divide by 0
- (signal 'arith-error (list "attempt to divide by zero" a1 a2))
- (let ((bits (1- maxbit))
- (quotient 0)
- (dividend (car (fabs a1)))
- (divisor (car (fabs a2)))
- (sign (not (same-sign a1 a2))))
- (while (natnump bits)
- (if (< (- dividend divisor) 0)
- (setq quotient (ash quotient 1))
- (setq quotient (1+ (ash quotient 1))
- dividend (- dividend divisor)))
- (setq dividend (ash dividend 1)
- bits (1- bits)))
- (normalize
- (cons (if sign (- quotient) quotient)
- (- (cdr (fabs a1)) (cdr (fabs a2)) (1- maxbit)))))))
-
-(defun f% (a1 a2)
- "Returns the remainder of first floating point number divided by second."
- (f- a1 (f* (ftrunc (f/ a1 a2)) a2)))
-
-
-;; Comparison functions
-(defun f= (a1 a2)
- "Returns t if two floating point numbers are equal, nil otherwise."
- (equal a1 a2))
-
-(defun f> (a1 a2)
- "Returns t if first floating point number is greater than second,
-nil otherwise."
- (cond ((and (natnump (car a1)) (< (car a2) 0))
- t) ; a1 nonnegative, a2 negative
- ((and (> (car a1) 0) (<= (car a2) 0))
- t) ; a1 positive, a2 nonpositive
- ((and (<= (car a1) 0) (natnump (car a2)))
- nil) ; a1 nonpos, a2 nonneg
- ((/= (cdr a1) (cdr a2)) ; same signs. exponents differ
- (> (cdr a1) (cdr a2))) ; compare the mantissas.
- (t
- (> (car a1) (car a2))))) ; same exponents.
-
-(defun f>= (a1 a2)
- "Returns t if first floating point number is greater than or equal to
-second, nil otherwise."
- (or (f> a1 a2) (f= a1 a2)))
-
-(defun f< (a1 a2)
- "Returns t if first floating point number is less than second,
-nil otherwise."
- (not (f>= a1 a2)))
-
-(defun f<= (a1 a2)
- "Returns t if first floating point number is less than or equal to
-second, nil otherwise."
- (not (f> a1 a2)))
-
-(defun f/= (a1 a2)
- "Returns t if first floating point number is not equal to second,
-nil otherwise."
- (not (f= a1 a2)))
-
-(defun fmin (a1 a2)
- "Returns the minimum of two floating point numbers."
- (if (f< a1 a2) a1 a2))
-
-(defun fmax (a1 a2)
- "Returns the maximum of two floating point numbers."
- (if (f> a1 a2) a1 a2))
-
-(defun fzerop (fnum)
- "Returns t if the floating point number is zero, nil otherwise."
- (= (car fnum) 0))
-
-(defun floatp (fnum)
- "Returns t if the arg is a floating point number, nil otherwise."
- (and (consp fnum) (integerp (car fnum)) (integerp (cdr fnum))))
-
-;; Conversion routines
-(defun f (int)
- "Convert the integer argument to floating point, like a C cast operator."
- (normalize (cons int '0)))
-
-(defun int-to-hex-string (int)
- "Convert the integer argument to a C-style hexadecimal string."
- (let ((shiftval -20)
- (str "0x")
- (hex-chars "0123456789ABCDEF"))
- (while (<= shiftval 0)
- (setq str (concat str (char-to-string
- (aref hex-chars
- (logand (lsh int shiftval) 15))))
- shiftval (+ shiftval 4)))
- str))
-
-(defun ftrunc (fnum) ; truncate fractional part
- "Truncate the fractional part of a floating point number."
- (cond ((natnump (cdr fnum)) ; it's all integer, return number as is
- fnum)
- ((<= (cdr fnum) (- maxbit)) ; it's all fractional, return 0
- '(0 . 1))
- (t ; otherwise mask out fractional bits
- (let ((mant (car fnum)) (exp (cdr fnum)))
- (normalize
- (cons (if (natnump mant) ; if negative, use absolute value
- (ash (ash mant exp) (- exp))
- (- (ash (ash (- mant) exp) (- exp))))
- exp))))))
-
-(defun fint (fnum) ; truncate and convert to integer
- "Convert the floating point number to integer, with truncation,
-like a C cast operator."
- (let* ((tf (ftrunc fnum)) (tint (car tf)) (texp (cdr tf)))
- (cond ((>= texp mantissa-bits) ; too high, return "maxint"
- mantissa-maxval)
- ((<= texp (- mantissa-bits)) ; too low, return "minint"
- mantissa-minval)
- (t ; in range
- (ash tint texp))))) ; shift so that exponent is 0
-
-(defun float-to-string (fnum &optional sci)
- "Convert the floating point number to a decimal string.
-Optional second argument non-nil means use scientific notation."
- (let* ((value (fabs fnum)) (sign (< (car fnum) 0))
- (power 0) (result 0) (str "")
- (temp 0) (pow10 _f1))
-
- (if (f= fnum _f0)
- "0"
- (if (f>= value _f1) ; find largest power of 10 <= value
- (progn ; value >= 1, power is positive
- (while (f<= (setq temp (f* pow10 highest-power-of-10)) value)
- (setq pow10 temp
- power (+ power decimal-digits)))
- (while (f<= (setq temp (f* pow10 _f10)) value)
- (setq pow10 temp
- power (1+ power))))
- (progn ; value < 1, power is negative
- (while (f> (setq temp (f/ pow10 highest-power-of-10)) value)
- (setq pow10 temp
- power (- power decimal-digits)))
- (while (f> pow10 value)
- (setq pow10 (f/ pow10 _f10)
- power (1- power)))))
- ; get value in range 100000 to 999999
- (setq value (f* (f/ value pow10) all-decimal-digs-minval)
- result (ftrunc value))
- (let (int)
- (if (f> (f- value result) _f1/2) ; round up if remainder > 0.5
- (setq int (1+ (fint result)))
- (setq int (fint result)))
- (setq str (int-to-string int))
- (if (>= int 1000000)
- (setq power (1+ power))))
-
- (if sci ; scientific notation
- (setq str (concat (substring str 0 1) "." (substring str 1)
- "E" (int-to-string power)))
-
- ; regular decimal string
- (cond ((>= power (1- decimal-digits))
- ; large power, append zeroes
- (let ((zeroes (- power decimal-digits)))
- (while (natnump zeroes)
- (setq str (concat str "0")
- zeroes (1- zeroes)))))
-
- ; negative power, prepend decimal
- ((< power 0) ; point and zeroes
- (let ((zeroes (- (- power) 2)))
- (while (natnump zeroes)
- (setq str (concat "0" str)
- zeroes (1- zeroes)))
- (setq str (concat "0." str))))
-
- (t ; in range, insert decimal point
- (setq str (concat
- (substring str 0 (1+ power))
- "."
- (substring str (1+ power)))))))
-
- (if sign ; if negative, prepend minus sign
- (concat "-" str)
- str))))
-
-
-;; string to float conversion.
-;; accepts scientific notation, but ignores anything after the first two
-;; digits of the exponent.
-(defun string-to-float (str)
- "Convert the string to a floating point number.
-Accepts a decimal string in scientific notation, with exponent preceded
-by either E or e. Only the six most significant digits of the integer
-and fractional parts are used; only the first two digits of the exponent
-are used. Negative signs preceding both the decimal number and the exponent
-are recognized."
-
- (if (string-match floating-point-regexp str 0)
- (let (power)
- (f*
- ; calculate the mantissa
- (let* ((int-subst (extract-match str 2))
- (fract-subst (extract-match str 4))
- (digit-string (concat int-subst fract-subst))
- (mant-sign (equal (extract-match str 1) "-"))
- (leading-0s 0) (round-up nil))
-
- ; get rid of leading 0's
- (setq power (- (length int-subst) decimal-digits))
- (while (and (< leading-0s (length digit-string))
- (= (aref digit-string leading-0s) ?0))
- (setq leading-0s (1+ leading-0s)))
- (setq power (- power leading-0s)
- digit-string (substring digit-string leading-0s))
-
- ; if more than 6 digits, round off
- (if (> (length digit-string) decimal-digits)
- (setq round-up (>= (aref digit-string decimal-digits) ?5)
- digit-string (substring digit-string 0 decimal-digits))
- (setq power (+ power (- decimal-digits (length digit-string)))))
-
- ; round up and add minus sign, if necessary
- (f (* (+ (string-to-number digit-string)
- (if round-up 1 0))
- (if mant-sign -1 1))))
-
- ; calculate the exponent (power of ten)
- (let* ((expt-subst (extract-match str 9))
- (expt-sign (equal (extract-match str 8) "-"))
- (expt 0) (chunks 0) (tens 0) (exponent _f1)
- (func 'f*))
-
- (setq expt (+ (* (string-to-number
- (substring expt-subst 0
- (min expt-digits (length expt-subst))))
- (if expt-sign -1 1))
- power))
- (if (< expt 0) ; if power of 10 negative
- (setq expt (- expt) ; take abs val of exponent
- func 'f/)) ; and set up to divide, not multiply
-
- (setq chunks (/ expt decimal-digits)
- tens (% expt decimal-digits))
- ; divide or multiply by "chunks" of 10**6
- (while (> chunks 0)
- (setq exponent (funcall func exponent highest-power-of-10)
- chunks (1- chunks)))
- ; divide or multiply by remaining power of ten
- (funcall func exponent (aref powers-of-10 tens)))))
-
- _f0)) ; if invalid, return 0
-
-(provide 'float)
-
-;; arch-tag: cc0c89c6-5718-49af-978e-585f6b14e347
-;;; float.el ends here
diff --git a/lisp/obsolete/hilit19.el b/lisp/obsolete/hilit19.el
deleted file mode 100644
index e989f4a7af..0000000000
--- a/lisp/obsolete/hilit19.el
+++ /dev/null
@@ -1,1527 +0,0 @@
-;;; hilit19.el --- customizable highlighting for Emacs 19
-
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Author: Jonathan Stigelman <stig@hackvan.com> (broken email address. checked April 2008)
-;; Maintainer: FSF
-;; (actually no longer maintained)
-;; Keywords: faces
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;; Hilit19.el is a customizable highlighting package for Emacs 19. It supports
-;; not only source code highlighting, but also Info, RMAIL, VM, gnus...
-;; Hilit19 knows (or thinks it knows) how to highlight emacs buffers in
-;; about 25 different modes.
-;;
-;; WHERE TO GET THE LATEST VERSIONS OF HILIT19.EL (beta and release):
-;;
-;; http://hackvan.com/pub/stig/src/elisp/
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; TO SUBMIT BUG REPORTS (or feedback of any sort)...
-;;
-;; M-x hilit-submit-feedback RET
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; hilit19.el,v 2.19 1993/09/08 18:44:10 stig Release
-;;
-;; LCD Archive Entry:
-;; hilit19|Jonathan Stigelman|stig@hackvan.com|
-;; Comprehensive (and comparatively fast) regex-based highlighting for Emacs 19|
-;; 1993/09/08 18:44:10|Release 2.19|~/packages/hilit19.el.Z|
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; GENERAL OVERVIEW
-;;
-;; This package installs numerous hooks to colorfully highlight your
-;; source code buffers as well as mail and news buffers. Most
-;; programming languages have predefined highlighting patterns.
-;; Just load hilit19 and files will be automatically highlighted as
-;; they're loaded.
-;;
-;; Rehighlight a buffer by typing C-S-l (control-shift-lowercase-L).
-;;
-;; If, when you edit the buffer, the coloring gets messed up, just
-;; redraw and the coloring will be adjusted. If automatic highlighting
-;; in the current buffer has been turned off, then typing C-u C-S-l will
-;; force a rehighlight of the entire buffer.
-;;
-;; Hilit19 can build faces by examining the names that you give to them
-;; For example, green/black-bold-italic-underline would be created as
-;; a face with a green foreground, and a black background, using a
-;; bold-italic font...with underlining for good measure.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; SETUP -- In your .emacs:
-;;
-;;
-;; (cond (window-system
-;; (setq hilit-mode-enable-list '(not text-mode)
-;; hilit-background-mode 'light
-;; hilit-inhibit-hooks nil
-;; hilit-inhibit-rebinding nil)
-;;
-;; (require 'hilit19)
-;; ))
-;;
-;; If you like font-lock-mode and want to use both packages, then you can
-;; disable hilit for the modes in which you want to use font-lock by listing
-;; said modes in hilit-mode-enable-list.
-;;
-;; (hilit-translate type 'RoyalBlue ; enable highlighting in C/C++
-;; string nil) ; disable string highlighting
-;;
-;; To get 100% of the utility of hilit19, you may also have to apply the
-;; patches below for info.el and vm5.33L_19/vm-summary.el
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; SETUP -- Are you using the right font for Emacs?
-;;
-;; Emacs cannot properly find bold and italic fonts unless you specify a
-;; verbose X11 font name. If you specify a font for emacs in your
-;; .Xdefaults, it *MUST* be specified using the long form of the font name.
-;; Here's a good font menu:
-;;
-;; (setq
-;; x-fixed-font-alist
-;; '("Font Menu"
-;; ("Misc"
-;; ("6x12" "-misc-fixed-medium-r-semicondensed--12-110-75-75-c-60-*-1")
-;; ("6x13" "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-*-1")
-;; ("lucida 13"
-;; "-b&h-lucidatypewriter-medium-r-normal-sans-0-0-0-0-m-0-*-1")
-;; ("7x13" "-misc-fixed-medium-r-normal--13-120-75-75-c-70-*-1")
-;; ("7x14" "-misc-fixed-medium-r-normal--14-130-75-75-c-70-*-1")
-;; ("9x15" "-misc-fixed-medium-r-normal--15-140-*-*-c-*-*-1")
-;; ("")
-;; ("clean 8x8" "-schumacher-clean-medium-r-normal--*-80-*-*-c-*-*-1")
-;; ("clean 8x14" "-schumacher-clean-medium-r-normal--*-140-*-*-c-*-*-1")
-;; ("clean 8x10" "-schumacher-clean-medium-r-normal--*-100-*-*-c-*-*-1")
-;; ("clean 8x16" "-schumacher-clean-medium-r-normal--*-160-*-*-c-*-*-1")
-;; ("")
-;; ("sony 8x16" "-sony-fixed-medium-r-normal--16-120-100-100-c-80-*-1")
-;; ("")
-;; ("-- Courier --")
-;; ("Courier 10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-*-1")
-;; ("Courier 12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-*-1")
-;; ("Courier 14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-*-1")
-;; ("Courier 18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-*-1")
-;; ("Courier 18-b" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-*-1")
-;; )))
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; KNOWN BUGS/TO DO LIST/HELP WANTED/APPLY WITHIN
-;;
-;; * unbalanced, unescaped double quote characters can confuse hilit19.
-;; This will be fixed someday, so don't bug me about it.
-;;
-;; * ALTHOUGH HILIT19 IS FASTER THAN FONT-LOCK-MODE...
-;; For various reasons, the speed of the package could still stand to be
-;; improved. If you care to do a little profiling and make things tighter...
-;;
-;; * hilit-toggle-highlight is flaky when auto-rehighlight is neither t nor nil.
-;; Does anyone actually USE this? I think I might just remove it.
-;;
-;; PROJECTS THAT YOU CAN TAKE OVER BECAUSE I DON'T MUCH CARE ABOUT THEM...
-;;
-;; * Moved hilit-wysiwyg-replace here from my version of man.el, this is not
-;; a bug. The bug is that I don't have a reverse operation yet...just a
-;; stub Wysiwyg-anything really belongs in a package of its own.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Thanks to the following people for their input:
-;; ebert@enpc.enpc.fr (Rolf EBERT), ada, LaTeX & bibtex highlights
-;; Vivek Khera <khera@cs.duke.edu>, gnus hooks + random advice & patches
-;; brian@athe.WUstl.EDU (Brian Dunford-Shore), prolog highlights
-;; John Ladwig <jladwig@soils.umn.edu>, 1st pass nroff highlights
-;; campo@sunthpi3.difi.unipi.it (Massimo Campostrini), fortran highlights
-;; jayb@laplace.MATH.ColoState.EDU (Jay Bourland), 1st pass dired
-;; Yoshio Turner <yoshio@CS.UCLA.EDU>, modula 2 highlights
-;; Fritz Knabe <knabe@ecrc.de>, advice & patches
-;; Alon Albert <alon@milcse.rtsg.mot.com>, advice & patches
-;; dana@thumper.bellcore.com (Dana A. Chee), working on the multi-frame bug
-;; derway@ndc.com (Don Erway), for breaking it...
-;; moss_r@summer.chem.su.oz.au (Richard Moss), first pass at add-pattern
-;; Olivier Lecarme <ol@aiguemarine.unice.fr>, Pascal & Icon patterns
-;;
-;; With suggestions and minor regex patches from numerous others...
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; hilit19.el,v
-;; Revision 2.19 1993/09/08 18:44:10 stig
-;; installed patch for elusive bug in hilit-rehighlight-region that caused
-;; hilit-unhighlight-region to hang in an infinite loop.
-;;
-;; Revision 2.18 1993/08/27 03:51:00 stig
-;; minor mods to lisp-mode and c/c++ mode patterns
-;;
-;; Revision 2.17 1993/08/25 02:19:17 stig
-;; work-around for bug in next-overlay-change that caused dired and jargon-mode
-;; to hang in an endless loop. Perhaps other modes were doing this too.
-;;
-;; Revision 2.16 1993/08/22 19:46:00 stig
-;; bug fix for next-overlay-change and accompanying change to
-;; hilit-unhighlight-region
-;;
-;; Revision 2.15 1993/08/20 12:16:22 stig
-;; minor change to fortran patterns
-;;
-;; Revision 2.14 1993/08/17 14:12:10 stig
-;; added default face mapping for 'formula' which is needed for new latex
-;; patterns.
-;;
-;; twiddled the calendar-mode patterns a bit.
-;;
-;; Revision 2.13 1993/08/16 04:33:54 stig
-;; hilit-set-mode-patterns was screwing up two part patterns. it doesn't now.
-;;
-;; Revision 2.12 1993/08/16 00:16:41 stig
-;; changed references to default-bold-italic to just bold-italic because the
-;; font for that face is maintained by emacs.
-;;
-;; the pattern matcher now starts its searches from the end of the most
-;; recently highlighted region (which is not necessarily the end of the most
-;; recently matched regex).
-;;
-;; multiple errors in pattern matcher now just give an error instead of lots of
-;; annoying messages and dings.
-;;
-;; no longer use vm-summary-mode-hooks.
-;;
-;; some code moved from hilit-highlight-region to hilit-set-mode-patterns.
-;; This will affect you if you pass your patterns directly to
-;; hilit-highlight-region....use a pseudo-mode instead.
-;;
-;; pattern changes to C/C++, latex, texinfo, fortran, nroff, etc.
-;;
-;; Revision 2.11 1993/08/13 12:12:37 stig
-;; removed some crufty commented-out code
-;;
-;; diverged lisp-mode and emacs-lisp-mode...also added lisp keywords.
-;;
-;; Revision 2.10 1993/08/13 09:47:06 stig
-;; added calendar-mode, icon-mode and pascal-mode patterns
-;;
-;; commented out hilit-toggle-highlight because I want to phase it out entirely
-;;
-;; Revision 2.9 1993/08/13 08:44:22 stig
-;; added optional case-fold argument to hilit-set-mode-patterns, this case-fold
-;; parameter is now stored in hilit-patterns-alist.
-;;
-;; Revision 2.8 1993/08/12 22:05:03 stig
-;; fixed some typos in documentation
-;;
-;; twiddled some of the color defaults for dark backgrounds
-;;
-;; always get 'mono color defaults if (not (x-display-color-p))
-;;
-;; added hilit-rehighlight-buffer-quietly to dired-after-readin-hook
-;;
-;; fixed bug in hilit-string-find that mishandled strings of the form: "\\"
-;;
-;; NEW FUNCTION: hilit-add-mode-pattern... kinda like add-hook for patterns
-;;
-;; fixed minor pattern bugs for latex-mode and emacs-lisp-mode
-;;
-;; Revision 2.7 1993/07/30 02:43:01 stig
-;; added const to the list of modifiers for C/C++ types
-;;
-;; Revision 2.6 1993/07/30 00:30:54 stig
-;; now permit selection of arbitrary subexpressions for highlighting...
-;; fixed keyword patterns for C/C++ using this technique.
-;;
-;; Revision 2.5 1993/07/28 05:02:56 stig
-;; improvements to makefile regular expressions
-;; removed about 130 lines just by compacting the big defconst for
-;; hilit-face-translation-table into a mapcar and defining a separate table
-;; of default faces.
-;;
-;; Revision 2.4 1993/07/27 14:09:05 stig
-;; documented another "known problem" to "head off gripe mail at the pass."
-;;
-;; Revision 2.3 1993/07/27 02:15:49 stig
-;; (hilit-lookup-face-create) incorporated patch which improves its behavior
-;; with more than one frame... Still can't have bold on the same face in two
-;; different fonts sizes at the same time...
-;;
-;; Revision 2.2 1993/07/27 02:02:59 stig
-;; vastly improved the makefile patterns
-;; added hook for mh-show-mode
-;;
-;; Revision 2.1 1993/07/24 17:46:21 stig
-;; Phasing out Info-select-hook... Version 19.18 will use Info-selection-hook.
-;;
-;; Revision 2.0 1993/07/24 13:50:10 stig
-;; better documentation and added the function hilit-submit-feedback.
-;; C-S-l (control shift l) repaints the buffer. Other bindings are optional.
-;; multi-line highlights no longer cause problems when
-;; hilit-auto-rehighlight is 'visible
-;; added hilit-predefined-face-list...
-;; changed name of hilit-mode-alist to hilit-patterns-alist
-;; added hilit-message-quietly to mail-setup-hook
-;; added hilit-parser-alist which can be used to apply different patterns to
-;; different parts of a buffer. This could be integrated in a far more
-;; elegant manner, but it presently serves the purpose of not applying
-;; message header patterns to message bodies in mail-mode and its kin.
-;; hilit-set-mode-patterns now takes a list of modes and an optional parse-fn
-;;
-
-;;;;;; AND THIS CAN BE APPLIED TO VM 5.33L_19
-;;
-;; *** ../site/vm5.33L_19/vm-summary.el Fri Jun 4 22:17:11 1993
-;; --- ./vm-summary.el Tue Jun 22 16:39:30 1993
-;; ***************
-;; *** 152,158 ****
-;; (insert "->")
-;; (delete-char 2)
-;; (forward-char -2)
-;; ! (and w vm-auto-center-summary (vm-auto-center-summary))))
-;; (and old-window (select-window old-window)))))))
-;;
-;; (defun vm-mark-for-display-update (message)
-;; --- 152,159 ----
-;; (insert "->")
-;; (delete-char 2)
-;; (forward-char -2)
-;; ! (and w vm-auto-center-summary (vm-auto-center-summary))
-;; ! (run-hooks 'vm-summary-pointer-hook)))
-;; (and old-window (select-window old-window)))))))
-;;
-;; (defun vm-mark-for-display-update (message)
-;;
-;;;;;;
-
-;;; Code:
-
-;; User Options:
-
-(defvar hilit-quietly nil
- "* If non-nil, this inhibits progress indicators during highlighting")
-
-(defvar hilit-auto-highlight t
- "* t if we should highlight all buffers as we find 'em, nil to disable
- automatic highlighting by the find-file hook.")
-
-(defvar hilit-auto-highlight-maxout 60000 ; hilit19 keeps getting bigger...
- "* auto-highlight is disabled in buffers larger than this")
-
-(defvar hilit-auto-rehighlight t
- "* If this is non-nil, then hilit-redraw and hilit-recenter will also
- rehighlight part or all of the current buffer. t will rehighlight the
- whole buffer, a NUMBER will rehighlight that many lines before and after
- the cursor, and the symbol 'visible' will rehighlight only the visible
- portion of the current buffer. This variable is buffer-local.")
-
-(make-variable-buffer-local 'hilit-auto-rehighlight)
-
-(defvar hilit-auto-rehighlight-fallback '(20000 . 100)
- "* Cons of the form (THRESHOLD . FALLBACK), where FALLBACK is assigned to
- hilit-auto-rehighlight if the size of a newly opened buffer is larger than
- THRESHOLD.")
-
-(defvar hilit-face-check t
- "* t slows down highlighting but permits the user to change fonts without
- losing bold and italic faces... t causes hilit-lookup-face-create to dig
- through the frame parameters for the current window every time it's called.
- If you never change fonts in emacs, set this to nil.")
-
-;; Variables which must be set before loading hilit19.
-
-(defvar hilit-inhibit-rebinding nil
- "If non-nil, this inhibits replacement of recenter, yank, and yank-pop.")
-
-(defvar hilit-inhibit-hooks nil
- "If non-nil, this inhibits installation of hooks for Info, gnus, & vm.")
-
-(defvar hilit-background-mode 'light
- "'mono inhibits color, 'dark or 'light indicate the background brightness.")
-
-(defvar hilit-mode-enable-list nil
- "If a list of modes to exclusively enable or specifically disable.
-The sense of the list is negated if it begins with the symbol 'not'.
-Set this variable before you load hilit19.
-
-Ex: (perl-mode jargon-mode c-mode) ; just perl, C, and jargon modes
- (not text-mode) ; all modes except text mode")
-
-;; Variables that are not generally modified directly
-
-(defvar hilit-parser-alist nil
- "alist of major-mode values and parsers called by hilit-rehighlight-buffer.
-
-Parsers for a given mode are IGNORED for partial rehighlights...maybe you'd
-like to make this more universal?")
-
-(defvar hilit-patterns-alist nil
- "alist of major-mode values and default highlighting patterns
-
-A highlighting pattern is a list of the form (start end face), where
-start is a regex, end is either a regex or a match number for start, and face
-is the name of an entry in hilit-face-translation-table, the name of a face,
-or nil (which disables the pattern).
-
-Each entry in the alist is of the form:
- (mode . (case-fold pattern [pattern ...]))
-
-See the hilit-lookup-face-create documentation for valid face names.")
-
-(defvar hilit-predefined-face-list (face-list)
- "List of faces with which hilit-lookup-face-create will NOT tamper.
-
-If hilit19 is dumped into emacs at your site, you may have to set this in
-your init file.")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Use this to report bugs:
-
-(eval-when-compile (require 'reporter)) ; no compilation gripes
-
-(defun hilit-submit-feedback ()
- "Submit feedback on hilit19 to hilit@hackvan.com"
- (interactive)
- (require 'reporter)
- (and (y-or-n-p "Do you really want to submit a report on hilit19? ")
- (reporter-submit-bug-report
- "bug-gnu-emacs@gnu.org"
- "hilit19.el (Release 2.19)"
- (and (y-or-n-p "Do you need to include a dump hilit variables? ")
- (append
- '(
- hilit-quietly hilit-inhibit-hooks
- hilit-background-mode hilit-mode-enable-list
- hilit-auto-highlight hilit-auto-highlight-maxout
- hilit-auto-rehighlight hilit-auto-rehighlight-fallback
- hilit-face-check
- )
- (and (y-or-n-p "Have you modified the standard patterns? ")
- (yes-or-no-p "Are your patterns *REALLY* relevant? ")
- '(hilit-parser-alist
- hilit-patterns-alist
- hilit-predefined-face-list
- ))))
- (function
- (lambda ()
- (and (y-or-n-p "Is this a problem with font display? ")
- (insert "\nFrame Configuration:\n====================\n"
- (prin1-to-string (frame-configuration-to-register ?F))
- "\n"
- ))))
- nil
- (concat
- "This is (check all that apply, and delete what's irrelevant):\n"
- " [ ] a _MASSIVE_THANK_YOU_ for writing hilit19.el\n"
- " [ ] An invitation to attend the next Hackers Conference\n"
- " [ ] You're a RIGHTEOUS HACKER, what are your rates?\n"
- " [ ] I've used the force and read the source, but I'M CONFUSED\n"
- " [ ] a PATCH. (output of 'diff -uw old.el new.el' or 'diff -cw')\n"
- " [ ] a SERIOUS AND REPRODUCIBLE BUG that is not an EMACS bug\n"
- " - I *swear* that it's not already mentioned in the KNOWN BUGS\n"
- " - I HAVE CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hilit19.el.gz\n"
- " for a newer release that fixes the problem.\n"
- " >> I HAVE ALSO CHECKED ftp.hackvan.com:/pub/stig/src/elisp/hl319.el.gz\n"
- " This is the alpha version...what will become hilit19 (Beta 3.0).\n"
- "\n"
- "Hey Stig, I *know* you're busy but...\n"))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; These faces are either a valid face name, or nil
-;; if you want to change them, you must do so AFTER hilit19 is loaded
-
-(defconst hilit-default-face-table
- '(
- ;; used for C/C++ and Emacs Lisp and perl
- (comment firebrick-italic moccasin italic)
- (include purple Plum1 bold-italic)
- (define ForestGreen-bold green bold)
- (defun blue-bold cyan-bold bold-italic)
- (decl RoyalBlue cyan bold)
- (type nil yellow nil)
- (keyword RoyalBlue cyan bold-italic)
- (label red-underline orange-underlined underline)
- (string grey40 orange underline)
-
- ;; some further faces for Ada
- (struct black-bold white-bold bold)
- (glob-struct magenta Plum1 default-bold-underline)
- (named-param DarkGoldenrod Goldenrod underline)
-
- ;; and another one for LaTeX
- (crossref DarkGoldenrod Goldenrod underline)
- (formula Goldenrod DarkGoldenrod underline)
-
- ;; compilation buffers
- (active-error default/pink-bold default/DeepPink-bold default-underline)
- (error red-bold yellow bold)
- (warning blue-italic green italic)
-
- ;; Makefiles (some faces borrowed from C/C++ too)
- (rule blue-bold-underline cyan-underline default-bold-underline)
-
- ;; VM, GNUS and Text mode
- (msg-subject blue-bold yellow bold)
- (msg-from purple-bold green bold)
- (msg-header firebrick-bold cyan italic)
- (msg-separator black/tan-bold black/lightblue nil)
- (msg-quote ForestGreen pink italic)
-
- (summary-seen grey40 white nil)
- (summary-killed grey50 white nil)
- (summary-Xed OliveDrab2 green nil)
- (summary-deleted firebrick white italic)
- (summary-unread RoyalBlue yellow bold)
- (summary-new blue-bold yellow-bold bold-italic)
- (summary-current default/skyblue-bold green/dimgrey-bold reverse-default)
-
- (gnus-group-unsubscribed grey50 white nil)
- (gnus-group-empty nil nil nil)
- (gnus-group-full ForestGreen green italic)
- (gnus-group-overflowing firebrick red bold-italic)
-
- ;; dired mode
- (dired-directory blue-bold cyan bold)
- (dired-link firebrick-italic green italic)
- (dired-ignored ForestGreen moccasin nil)
- (dired-deleted red-bold-italic orange bold-italic)
- (dired-marked purple Plum1 nil)
-
- ;; Info-mode, and jargon-mode.el and prep.ai.mit.edu:/pub/gnu/jargon*
- (jargon-entry blue-bold cyan bold)
- (jargon-xref purple-bold Plum1 italic)
- (jargon-keyword firebrick-underline yellow underline)
- )
- "alist of default faces (face . (light-default dark-default mono-default))
-
-There is no way for the user to modify this table such that it will have any
-effect upon the translations used by hilit19. Instead, use the function
-hilit-translate AFTER hilit19 has been loaded.
-
-See also the documentation for hilit-lookup-face-create.")
-
-(defconst hilit-face-translation-table
- (let ((index (or (and (x-display-color-p)
- (cdr (assq hilit-background-mode
- '((light . 1) (dark . 2)))))
- 3)))
- (mapcar (function (lambda (x) (cons (car x) (nth index x))))
- hilit-default-face-table))
- "alist that maps symbolic face-names to real face names")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; To translate one face to another...
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro hilit-translate (&rest args)
- "(hilit-translate FROM TO FROM TO ...): translate each face FROM to the
-value of its TO face. This is like setq for faces.
-
-The function hilit-lookup-face-create will repeatedly translate until no more
-translations for the face exist in the translation table.
-
-See the documentation for hilit-lookup-face-create for names of valid faces."
- (or (zerop (% (length args) 2))
- (error "wrong number of args"))
- (let (cmdl from to)
- (while args
- (setq from (car args) to (nth 1 args) args (nthcdr 2 args)
- cmdl (cons (list 'hilit-associate ''hilit-face-translation-table
- (list 'quote from) to)
- cmdl)))
- (cons 'progn cmdl)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; This function actually translates and then creates the faces...
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun hilit-lookup-face-create (face &optional force)
- "Get a FACE, or create it if it doesn't exist. In order for it to
-properly create the face, the following naming convention must be used:
- [reverse-](fgcolor[/bgcolor])[-bold][-italic][-underline]
-Example: (hilit-lookup-face-create 'comment-face) might create and return 'red
-
-Each color is either the name of an X color (see .../X11/lib/X11/rgb.txt),
-a hexadecimal specification of the form \"hex-[0-9A-Fa-f]+\", or \"default\".
-
-An optional argument, FORCE, will cause the face to be recopied from the
-default...which is probably of use only if you've changed fonts.
-
-See the documentation for hilit-translate and hilit-face-translation-table."
-
-;; translate the face ...
- (let ((trec t) visited)
- (while trec
- (cond ((memq face visited) (error "face translation loop: %S" visited))
- (t (setq visited (cons face visited)
- trec (assq face hilit-face-translation-table))
- (and trec (setq face (cdr trec)))))))
-
- ;; make the face if we need to...
- (let* ((fn (symbol-name face))
- (frame (selected-frame))
- (basefont (cdr (assq 'font (frame-parameters frame))))
- error fgcolor bgcolor)
- (cond
- ((or (null face)
- (memq face hilit-predefined-face-list))
- ;; do nothing if the face is nil or if it's predefined.
- )
- ((or force
- (not (memq face (face-list)))
- (and hilit-face-check
- (not (string= (get face 'basefont) basefont))))
- (copy-face 'default 'scratch-face)
- (if (string-match "^reverse-?" fn)
- (progn (invert-face 'scratch-face)
- (setq fn (substring fn (match-end 0)))))
-
- ;; parse foreground color
- (if (string-match "^\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn)
- (setq fgcolor (concat
- (if (match-beginning 1) "#")
- (substring fn (match-beginning 2) (match-end 2)))
- fn (substring fn (match-end 0)))
- (error "bad face name %S" face))
-
- ;; parse background color
- (if (string-match "^/\\(hex-\\)?\\([A-Za-z0-9]+\\)" fn)
- (setq bgcolor (concat
- (and (match-beginning 1) "#")
- (substring fn (match-beginning 2) (match-end 2)))
- fn (substring fn (match-end 0))))
-
- (and (string= "default" fgcolor) (setq fgcolor nil))
- (and (string= "default" bgcolor) (setq bgcolor nil))
-
- ;; catch errors if we can't allocate the color(s)
- (condition-case nil
- (progn (and fgcolor (set-face-foreground 'scratch-face fgcolor))
- (and bgcolor (set-face-background 'scratch-face bgcolor))
- (copy-face 'scratch-face face)
- (put face 'basefont basefont))
- (error (message "couldn't allocate color for '%s'"
- (symbol-name face))
- (setq face 'default)
- (setq error t)))
- (or error
- ;; don't bother w/ bold or italic if we didn't get the color
- ;; we wanted, but ignore errors making the face bold or italic
- ;; if the font isn't available, there's nothing to do about it...
- (progn
- (when (display-graphic-p frame)
- (set-face-font face basefont frame))
- (set-face-underline-p face (string-match "underline" fn))
- (if (string-match ".*bold" fn)
- ;; make face bold in all frames
- (make-face-bold face nil 'noerr))
- (if (string-match ".*italic" fn)
- ;; make face italic in all frames
- (make-face-italic face nil 'noerr))
- ))
- )))
- face)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Region Highlight/Unhighlight code (Both overlay and text-property versions)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defsubst hilit-region-set-face (start end face-name &optional prio prop)
- "Highlight region from START to END using FACE and, optionally, PRIO.
-The optional 5th arg, PROP is a property to set instead of 'hilit."
- (let ((overlay (make-overlay start end)))
- (overlay-put overlay 'face face-name)
- (overlay-put overlay (or prop 'hilit) t)
- (and prio (overlay-put overlay 'priority prio))))
-
-(defun hilit-unhighlight-region (start end &optional quietly)
- "Unhighlights the region from START to END, optionally in a QUIET way"
- (interactive "r")
- (or quietly hilit-quietly (message "Unhighlighting"))
- (let ((lstart 0))
- (while (and start (> start lstart) (< start end))
- (mapc (function (lambda (ovr)
- (and (overlay-get ovr 'hilit) (delete-overlay ovr))))
- (overlays-at start))
- (setq lstart start start (next-overlay-change start))))
- (or quietly hilit-quietly (message "Done unhighlighting")))
-
-;;;; These functions use text properties instead of overlays. Text properties
-;;;; are copied through kill and yank...which might be convenient, but is not
-;;;; terribly efficient as of 19.12, ERGO it's been disabled
-;;
-;;(defsubst hilit-region-set-face (start end face-name &optional prio prop)
-;; "Highlight region from START to END using FACE and, optionally, PRIO.
-;;The optional 5th arg, PROP is a property to set instead of 'hilit."
-;; (put-text-property start end 'face face-name)
-;; )
-;;
-;;(defun hilit-unhighlight-region (start end &optional quietly)
-;; "Unhighlights the region from START to END, optionally in a QUIET way"
-;; (interactive "r")
-;; (let ((buffer-read-only nil)
-;; (bm (buffer-modified-p)))
-;; (remove-text-properties start end '(face))
-;; (set-buffer-modified-p bm)))
-;;;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Pattern Application code and user functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun hilit-highlight-region (start end &optional patterns quietly)
- "Highlights the area of the buffer between START and END (the region when
-interactive). Without the optional PATTERNS argument, the pattern for
-major-mode is used. If PATTERNS is a symbol, then the patterns associated
-with that symbol are used. QUIETLY suppresses progress messages if
-non-nil."
- (interactive "r")
- (cond ((null patterns)
- (setq patterns (cdr (assq major-mode hilit-patterns-alist))))
- ((symbolp patterns)
- (setq patterns (cdr (assq patterns hilit-patterns-alist)))))
- ;; txt prop: (setq patterns (reverse patterns))
- (let ((case-fold-search (car patterns))
- (prio (1- (length patterns)))
- ;; txt prop: (buffer-read-only nil)
- ;; txt prop: (bm (buffer-modified-p))
- p pstart pend face mstart (puke-count 0))
- ;; txt prop: (unwind-protect
- (setq patterns (cdr patterns)) ; remove case-fold from head of pattern
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (while patterns
- (setq p (car patterns))
- (setq pstart (car p)
- pend (nth 1 p)
- face (hilit-lookup-face-create (nth 2 p)))
- (if (not face) ; skipped if nil
- nil
- (or quietly hilit-quietly
- (message "highlighting %d: %s%s" prio pstart
- (if (stringp pend) (concat " ... " pend) "")))
- (goto-char (point-min))
- (condition-case msg
- (cond
- ((symbolp pstart)
- ;; inner loop -- special function to find pattern
- (let (region)
- (while (setq region (funcall pstart pend))
- (hilit-region-set-face (car region) (cdr region)
- face prio))))
- ((stringp pend)
- ;; inner loop -- regex-start ... regex-end
- (while (re-search-forward pstart nil t nil)
- (goto-char (setq mstart (match-beginning 0)))
- (if (re-search-forward pend nil t nil)
- (hilit-region-set-face mstart (match-end 0)
- face prio)
- (forward-char 1))))
- ((numberp pend)
- ;; inner loop -- just one regex to match whole pattern
- (while (re-search-forward pstart nil t nil)
- (goto-char (match-end pend))
- (hilit-region-set-face (match-beginning pend)
- (match-end pend) face prio)))
- (t (error "malformed pattern")))
- (error (if (> (setq puke-count (1+ puke-count)) 1)
- (error msg)
- (message "Error: '%s'" msg)
- (ding) (sit-for 4)))))
- (setq prio (1- prio)
- patterns (cdr patterns)))
- ))
- (or quietly hilit-quietly (message "")) ; "Done highlighting"
- ;; txt prop: (set-buffer-modified-p bm)) ; unwind protection
- ))
-
-(defun hilit-rehighlight-region (start end &optional quietly)
- "Re-highlights the region, optionally in a QUIET way"
- (interactive "r")
- (save-restriction
- (widen)
- (setq start (apply 'min start (mapcar 'overlay-start (overlays-at start)))
- end (apply 'max end (mapcar 'overlay-end (overlays-at end))))
- (hilit-unhighlight-region start end quietly)
- (hilit-highlight-region start end nil quietly)))
-
-(defun hilit-rehighlight-buffer (&optional quietly)
- "Re-highlights the buffer, optionally in a QUIET way"
- (interactive "")
- (let ((parse-fn (cdr (assq major-mode hilit-parser-alist))))
- (if parse-fn
- (funcall parse-fn quietly)
- (hilit-rehighlight-region (point-min) (point-max) quietly)))
- nil)
-
-(defun hilit-rehighlight-buffer-quietly ()
- (hilit-rehighlight-buffer t))
-
-(defun hilit-rehighlight-message (quietly)
- "Highlight a buffer containing a news article or mail message."
- (save-excursion
- (goto-char (point-min))
- ;; find separation between headers and body (either a blank line or
- ;; the message separator line in mail-mode)
- (re-search-forward "^\\(\\|--text follows this line--\\)$" nil 'noerr)
- (hilit-unhighlight-region (point-min) (point-max) quietly)
- (hilit-highlight-region (point-min) (point) 'msg-header quietly)
- (hilit-highlight-region (point) (point-max) 'msg-body quietly)))
-
-(defalias 'hilit-highlight-buffer 'hilit-rehighlight-buffer)
-
-;; Well, I want to remove this function...there's one sure way to find out if
-;; anyone uses it or not...and that's to comment it out.
-;;
-;; (defun hilit-toggle-highlight (arg)
-;; "Locally toggle highlighting. With arg, forces highlighting off."
-;; (interactive "P")
-;; ;; FIXME -- this loses numeric information in hilit-auto-rehighlight
-;; (setq hilit-auto-rehighlight
-;; (and (not arg) (not hilit-auto-rehighlight)))
-;; (if hilit-auto-rehighlight
-;; (hilit-rehighlight-buffer)
-;; (hilit-unhighlight-region (point-min) (point-max)))
-;; (message "Rehighlighting is set to %s" hilit-auto-rehighlight))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; HOOKS
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun hilit-find-file-hook ()
- "Find-file hook for hilit package. See the variable hilit-auto-highlight."
- (cond ((and hilit-auto-highlight
- (assq major-mode hilit-patterns-alist))
- (if (> buffer-saved-size (car hilit-auto-rehighlight-fallback))
- (setq hilit-auto-rehighlight
- (cdr hilit-auto-rehighlight-fallback)))
- (if (> buffer-saved-size hilit-auto-highlight-maxout)
- nil
- (let ((bm (buffer-modified-p)))
- (hilit-rehighlight-buffer)
- (set-buffer-modified-p bm))))))
-
-(defun hilit-repaint-command (arg)
- "Rehighlights according to the value of hilit-auto-rehighlight, or the
-prefix argument if that is specified.
-\t\\[hilit-repaint-command]\t\trepaint according to hilit-auto-rehighlight
-\t^U \\[hilit-repaint-command]\trepaint entire buffer
-\t^U - \\[hilit-repaint-command]\trepaint visible portion of buffer
-\t^U n \\[hilit-repaint-command]\trepaint n lines to either side of point"
- (interactive "P")
- (let (st en quietly)
- (or arg (setq arg hilit-auto-rehighlight))
- (cond ((or (eq arg 'visible) (eq arg '-))
- (setq st (window-start) en (window-end) quietly t))
- ((numberp arg)
- (setq st (save-excursion (forward-line (- arg)) (point))
- en (save-excursion (forward-line arg) (point))))
- (arg
- (hilit-rehighlight-buffer)))
- (if st
- (hilit-rehighlight-region st en quietly))))
-
-(defun hilit-recenter (arg)
- "Recenter, then rehighlight according to hilit-auto-rehighlight. If called
-with an unspecified prefix argument (^U but no number), then a rehighlight of
-the entire buffer is forced."
- (interactive "P")
- (recenter arg)
- ;; force display update
- (sit-for 0)
- (hilit-repaint-command (consp arg)))
-
-(defun hilit-yank (arg)
- "Yank with rehighlighting"
- (interactive "*P")
- (let ((transient-mark-mode nil))
- (yank arg)
- (and hilit-auto-rehighlight
- (hilit-rehighlight-region (region-beginning) (region-end) t))
- (setq this-command 'yank)))
-
-(defun hilit-yank-pop (arg)
- "Yank-pop with rehighlighting"
- (interactive "*p")
- (let ((transient-mark-mode nil))
- (yank-pop arg)
- (and hilit-auto-rehighlight
- (hilit-rehighlight-region (region-beginning) (region-end) t))
- (setq this-command 'yank)))
-
-;;; this line highlighting stuff is untested. play with it only if you feel
-;;; adventurous...don't ask me to fix it...though you're welcome to. -- Stig
-;;
-;; (defun hilit-rehighlight-line-quietly (&rest args)
-;; "Quietly rehighlight just this line.
-;; Useful as an after change hook in VM/gnus summary buffers and dired buffers.
-;; If only there were an after-change-function, that is..."
-;; (save-excursion
-;; (push-mark nil t)
-;; (hilit-rehighlight-yank-region)
-;; (and orig-achange-function (apply orig-achange-function args))))
-;;
-;; (defun hilit-install-line-hooks ()
-;; (make-variable-buffer-local 'after-change-function)
-;; (make-local-variable 'orig-achange-function)
-;; (setq orig-achange-function after-change-function)
-;; (setq after-change-function 'hilit-rehighlight-line-quietly))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Wysiwyg Stuff... take it away and build a whole package around it!
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; ; For the Jargon-impaired, WYSIWYG === What You See Is What You Get
-;; ; Sure, it sucks to type. Oh, well.
-;; (defun hilit-wysiwyg-replace ()
-;; "Replace overstruck text with normal text that's been overlaid with the
-;; appropriate text attribute. Suitable for a find-file hook."
-;; (save-excursion
-;; (goto-char (point-min))
-;; (let ((wysb (hilit-lookup-face-create 'wysiwyg-bold))
-;; (wysu (hilit-lookup-face-create 'wysiwyg-underline))
-;; (bmod (buffer-modified-p)))
-;; (while (re-search-forward "\\(.\b.\\)+" nil t)
-;; (let ((st (match-beginning 0)) (en (match-end 0)))
-;; (goto-char st)
-;; (if (looking-at "_")
-;; (hilit-region-set-face st en wysu 100 'wysiwyg)
-;; (hilit-region-set-face st en wysb 100 'wysiwyg))
-;; (while (and (< (point) en) (looking-at ".\b"))
-;; (replace-match "") (forward-char))
-;; ))
-;; (set-buffer-modified-p bmod))))
-;;
-;; ; is this more appropriate as a write-file-hook or a write-contents-hook?
-;; (defun hilit-wysiwyg-write-repair ()
-;; "Replace wysiwyg overlays with overstrike text."
-;; (message "*sigh* hilit-wysiwyg-write-repair not implemented yet")
-;;
-;; For efficiency, this hook should copy the current buffer to a scratch
-;; buffer and do its overstriking there. Overlays are not copied, so it'll
-;; be necessary to hop back and forth. This is OK since you're not fiddling
-;; with--making or deleting--any overlays. THEN write the new buffer,
-;; delete it, and RETURN T. << important
-;;
-;; Just so you know...there is already an emacs function called
-;; underline-region that does underlining. I think that the thing to do is
-;; extend that to do overstriking as well.
-;;
-;; (while (< start end)
-;; (mapcar (function (lambda (ovr)
-;; (and (overlay-get ovr 'hilit) (delete-overlay ovr))))
-;; (overlays-at start))
-;; (setq start (next-overlay-change start)))
-;; nil)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Initialization.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-minor-mode hilit-mode
- "Obsolete minor mode. Use `global-font-lock-mode' instead."
- :global t
-
- (unless (and hilit-inhibit-rebinding hilit-mode)
- (substitute-key-definition
- (if hilit-mode 'yank 'hilit-yank)
- (if hilit-mode 'hilit-yank 'yank)
- (current-global-map))
- (substitute-key-definition
- (if hilit-mode 'yank-pop 'hilit-yank-pop)
- (if hilit-mode 'hilit-yank-pop 'yank-pop)
- (current-global-map))
- (substitute-key-definition
- (if hilit-mode 'recenter 'hilit-recenter)
- (if hilit-mode 'hilit-recenter 'recenter)
- (current-global-map)))
-
- (if hilit-mode
- (global-set-key [?\C-\S-l] 'hilit-repaint-command)
- (global-unset-key [?\C-\S-l]))
-
- (if hilit-mode
- (add-hook 'find-file-hook 'hilit-find-file-hook t)
- (remove-hook 'find-file-hook 'hilit-find-file-hook))
-
- (unless (and hilit-inhibit-hooks hilit-mode)
- (condition-case c
- (progn
-
- ;; BUFFER highlights...
- (mapc (lambda (hook)
- (if hilit-mode
- (add-hook hook 'hilit-rehighlight-buffer-quietly)
- (remove-hook hook 'hilit-rehighlight-buffer-quietly)))
- '(
- Info-selection-hook
-
- ;; runs too early vm-summary-mode-hooks
- vm-summary-pointer-hook
- vm-preview-message-hook
- vm-show-message-hook
-
- rmail-show-message-hook
- mail-setup-hook
- mh-show-mode-hook
-
- dired-after-readin-hook
- ))
- )
- (error (message "Error loading highlight hooks: %s" c)
- (ding) (sit-for 1)))))
-
-(eval-when-compile (require 'gnus)) ; no compilation gripes
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Default patterns for various modes.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; do I need this? I changed the defconst to a defvar because defconst is
-;;; inappropriate, but I don't know why I wanted hilit-patterns-alist to be
-;;; reset on every reload...
-
-(setq hilit-patterns-alist nil)
-
-(defun hilit-associate (alist key val)
- "creates, or destructively replaces, the pair (key . val) in alist"
- (let ((oldentry (assq key (eval alist))))
- (if oldentry
- (setcdr oldentry val)
- (set alist (cons (cons key val) (eval alist))))))
-
-(defun hilit-set-mode-patterns (modelist patterns
- &optional parse-fn case-fold)
- "Sets the default highlighting patterns for MODE to PATTERNS.
-See the variable hilit-mode-enable-list.
-
-Takes optional arguments PARSE-FN and CASE-FOLD."
- ;; change pattern
- (mapc (function (lambda (p)
- (and (stringp (car p))
- (null (nth 1 p))
- (setcar (cdr p) 0))))
- patterns)
- (setq patterns (cons case-fold patterns))
-
- (or (consp modelist) (setq modelist (list modelist)))
- (let (ok (flip (eq (car hilit-mode-enable-list) 'not)))
- (mapcar (function
- (lambda (m)
- (setq ok (or (null hilit-mode-enable-list)
- (memq m hilit-mode-enable-list)))
- (and flip (setq ok (not ok)))
- (and ok
- (progn
- (and parse-fn
- (hilit-associate 'hilit-parser-alist m parse-fn))
- (hilit-associate 'hilit-patterns-alist m patterns)))))
- modelist)))
-
-(defun hilit-add-pattern (pstart pend face &optional mode first)
- "Highlight pstart with face for the current major-mode.
-Optionally, place the new pattern first in the pattern list"
- (interactive "sPattern start regex: \nsPattern end regex (default none): \nxFace: ")
-
- (and (equal pstart "") (error "Must specify starting regex"))
- (cond ((equal pend "") (setq pend 0))
- ((string-match "^[0-9]+$" pend) (setq pend (string-to-number pend))))
- (or mode (setq mode major-mode))
- (let ((old-patterns (cdr (assq mode hilit-patterns-alist)))
- (new-pat (list pstart pend face)))
- (cond ((not old-patterns)
- (hilit-set-mode-patterns mode (list new-pat)))
- (first
- (setcdr old-patterns (cons new-pat (cdr old-patterns))))
- (t
- (nconc old-patterns (list new-pat)))))
- (and (interactive-p) (hilit-rehighlight-buffer)))
-
-(defun hilit-string-find (qchar)
- "Looks for a string and returns (start . end) or nil. The argument QCHAR
-is the character that would precede a character constant double quote.
-Finds strings delimited by double quotes. The first double quote may not be
-preceded by QCHAR and the closing double quote may not be preceded by an odd
-number of backslashes."
- (let (st en)
- (while (and (search-forward "\"" nil t)
- (eq qchar (char-after (1- (setq st (match-beginning 0)))))))
- (while (and (search-forward "\"" nil t)
- (save-excursion
- (setq en (point))
- (forward-char -1)
- (skip-chars-backward "\\\\")
- (forward-char 1)
- (not (zerop (% (- en (point)) 2))))))
- (and en (cons st en))))
-
-;; return types on same line...
-;; ("^[a-zA-z].*\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
-
-;; On another note, a working pattern for grabbing function definitions for C is
-;;
-;; ("^[a-zA-Z_]+.*[;{]$" nil ForestGreen) ; global defns ( start at col 1 )
-;; ("^[a-zA-Z_]+.*(" ")" defun)
-;; ; defuns assumed to start at col 1, not with # or {
-;;
-;; this will make external declarations/definitions green, and function
-;; definitions the defun face. Hmmm - seems to work for me anyway.
-
-(let ((comments '(("/\\*" "\\*/" comment)))
- (c++-comments '(("//.*$" nil comment)
- ("^/.*$" nil comment)))
- (strings '((hilit-string-find ?' string)))
- (preprocessor '(("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define)
- ("^#.*$" nil include))))
-
- (hilit-set-mode-patterns
- '(c-mode c++-c-mode elec-c-mode)
- (append
- comments strings preprocessor
- '(
- ;; function decls are expected to have types on the previous line
- ("^\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
- ("^\\(typedef\\|struct\\|union\\|enum\\).*$" nil decl)
- ;; datatype -- black magic regular expression
- ("[ \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)
- ;; key words
- ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\)\\>[^_]" 1 keyword)
- )))
-
- (hilit-set-mode-patterns
- 'c++-mode
- (append
- comments c++-comments strings preprocessor
- '(
- ;; function decls are expected to have types on the previous line
- ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
- ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
- ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl)
- ;; datatype -- black magic regular expression
- ("[ \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)
- ;; key words
- ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|delete\\|new\\)\\>[^_]"
- 1 keyword))))
-
- (hilit-set-mode-patterns
- '(objc-mode objective-C-mode)
- (append
- comments c++-comments strings preprocessor
- '(
- ;; function decls are expected to have types on the previous line
- ("^\\(\\(\\w\\|[$_]\\)+::\\)?\\(\\w\\|[$_]\\)+\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
- ("^\\(\\(\\w\\|[$_]\\)+[ \t]*::[ \t]*\\)?\\(\\(\\w\\|[$_]\\)+\\|operator.*\\)\\s *\\(\\(\\w\\|[$_]\\)+\\s *((\\|(\\)[^)]*)+" nil defun)
-
- ("^\\(template\\|typedef\\|struct\\|union\\|class\\|enum\\|public\\|private\\|protected\\).*$" nil decl)
- ;; datatype -- black magic regular expression
- ("[ \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)
- ;; key words
- ("[^_]\\<\\(return\\|goto\\|if\\|else\\|case\\|default\\|switch\\|break\\|continue\\|while\\|do\\|for\\|public\\|protected\\|private\\|interface\\|implementation\\|end\\|super\\|self\\)\\>[^_]"
- 1 keyword))))
- )
-
-(hilit-set-mode-patterns
- 'perl-mode
- '(("\\s #.*$" nil comment)
- ("^#.*$" nil comment)
- ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string)
- ("^\\(__....?__\\|\\s *\\sw+:\\)" nil label)
- ("^require.*$" nil include)
- ("^package.*$" nil decl)
- ("^\\s *sub\\s +\\(\\w\\|[_']\\)+" nil defun)
- ("\\b\\(do\\|if\\|unless\\|while\\|until\\|else\\|elsif\\|for\\|foreach\\|continue\\|next\\|redo\\|last\\|goto\\|return\\|die\\|exit\\)\\b" nil keyword)))
-
-(hilit-set-mode-patterns
- 'ada-mode
- '(;; comments
- ("--.*$" nil comment)
- ;; main structure
- ("[ \t\n]procedure[ \t]" "\\([ \t]\\(is\\|renames\\)\\|);\\)" glob-struct)
- ("[ \t\n]task[ \t]" "[ \t]is" glob-struct)
- ("[ \t\n]function[ \t]" "return[ \t]+[A-Za-z_0-9]+[ \t]*\\(is\\|;\\|renames\\)" glob-struct)
- ("[ \t\n]package[ \t]" "[ \t]\\(is\\|renames\\)" glob-struct)
- ;; if there is nothing before "private", it is part of the structure
- ("^[ \t]*private[ \t\n]" nil glob-struct)
- ;; if there is no indentation before the "end", then it is most
- ;; probably the end of the package
- ("^end.*$" ";" glob-struct)
- ;; program structure -- "null", "delay" and "terminate" omitted
- ("[ \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)
- ;; block structure
- ("[ \n\t]\\(begin\\|end\\|declare\\|exception\\|generic\\|raise\\|return\\|package\\|body\\)[ \n\t;]" nil struct)
- ;; type declaration
- ("^[ \t]*\\(type\\|subtype\\).*$" ";" decl)
- ("[ \t]+is record.*$" "end record;" decl)
- ;; "pragma", "with", and "use" are close to C cpp directives
- ("^[ \t]*\\(with\\|pragma\\|use\\)" ";" include)
- ;; nice for named parameters, but not so beautiful in case statements
- ("[A-Za-z_0-9.]+[ \t]*=>" nil named-param)
- ;; string constants probably not everybody likes this one
- ("\"" ".*\"" string)))
-
-(hilit-set-mode-patterns
- 'fortran-mode
- '(("^[*Cc].*$" nil comment)
- ("'[^'\n]*'" nil string)
- ("\\(^[ \t]*[0-9]+\\|[ \t]continue[ \t\n]\\|format\\)" nil define)
- ("[ \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)
- ("[ \t]\\(call\\|program\\|subroutine\\|function\\|stop\\|return\\|end\\|include\\)[ \t\n]" nil include)
- ("[ \t]\\(parameter[\t\n ]*([^)]*)\\|data\\|save\\|common[ \t\n]*/[^/]*/\\)"
- nil decl)
- ("^ ." nil type)
- ("implicit[ \t]*none" nil decl)
- ("\\([ \t]\\|implicit[ \t]*\\)\\(dimension\\|integer\\|real\\|double[ \t]*precision\\|character\\|logical\\|complex\\|double[ \t]*complex\\)\\([*][0-9]*\\|[ \t\n]\\)" nil keyword)
- )
- nil 'case-insensitive)
-
-(hilit-set-mode-patterns
- '(m2-mode modula-2-mode)
- '(("(\\*" "\\*)" comment)
- (hilit-string-find ?\\ string)
- ("^[ \t]*PROCEDURE[ \t]+\\w+[^ \t(;]*" nil defun)
- ("\\<\\(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)
- )
- nil 'case-insensitive)
-
-(hilit-set-mode-patterns 'prolog-mode
- '(("/\\*" "\\*/" comment)
- ("%.*$" nil comment)
- (":-" nil defun)
- ("!" nil label)
- ("\"[^\\\"]*\\(\\\\\\(.\\|\n\\)[^\\\"]*\\)*\"" nil string)
- ("\\b\\(is\\|mod\\)\\b" nil keyword)
- ("\\(->\\|-->\\|;\\|==\\|\\\\==\\|=<\\|>=\\|<\\|>\\|=\\|\\\\=\\|=:=\\|=\\\.\\\.\\|\\\\\\\+\\)" nil decl)
- ("\\(\\\[\\||\\|\\\]\\)" nil include)))
-
-(hilit-set-mode-patterns
- '(
- LaTeX-mode japanese-LaTeX-mode SliTeX-mode
- japanese-SliTeX-mode FoilTeX-mode latex-mode
- )
- '(
- ;; comments
- ("[^\\]%.*$" nil comment)
-
- ;; the following two match \foo[xx]{xx} or \foo*{xx} or \foo{xx}
- ("\\\\\\(sub\\)*\\(paragraph\\|section\\)\\(\*\\|\\[.*\\]\\)?{" "}"
- keyword)
- ("\\\\\\(chapter\\|part\\)\\(\*\\|\\[.*\\]\\)?{" "}" keyword)
- ("\\\\footnote\\(mark\\|text\\)?{" "}" keyword)
- ("\\\\[a-z]+box" nil keyword)
- ("\\\\\\(v\\|h\\)space\\(\*\\)?{" "}" keyword)
-
- ;; (re-)define new commands/environments/counters
- ("\\\\\\(re\\)?new\\(environment\\|command\\){" "}" defun)
- ("\\\\new\\(length\\|theorem\\|counter\\){" "}" defun)
-
- ;; various declarations/definitions
- ("\\\\\\(setlength\\|settowidth\\|addtolength\\|setcounter\\|addtocounter\\)" nil define)
- ("\\\\\\(title\\|author\\|date\\|thanks\\){" "}" define)
-
- ("\\\\documentstyle\\(\\[.*\\]\\)?{" "}" decl)
- ("\\\\\\(begin\\|end\\|nofiles\\|includeonly\\){" "}" decl)
- ("\\\\\\(raggedright\\|makeindex\\|makeglossary\\|maketitle\\)\\b" nil
- decl)
- ("\\\\\\(pagestyle\\|thispagestyle\\|pagenumbering\\){" "}" decl)
- ("\\\\\\(normalsize\\|small\\|footnotesize\\|scriptsize\\|tiny\\|large\\|Large\\|LARGE\\|huge\\|Huge\\)\\b" nil decl)
- ("\\\\\\(appendix\\|tableofcontents\\|listoffigures\\|listoftables\\)\\b"
- nil decl)
- ("\\\\\\(bf\\|em\\|it\\|rm\\|sf\\|sl\\|ss\\|tt\\)\\b" nil decl)
-
- ;; label-like things
- ("\\\\item\\(\\[[^]]*\\]\\)?" nil label)
- ("\\\\caption\\(\\[[^]]*\\]\\)?{" "}" label)
-
- ;; formulas
- ("[^\\]\\\\(" "\\\\)" formula) ; \( \)
- ("[^\\]\\\\\\[" "\\\\\\]" formula) ; \[ \]
- ("[^\\$]\\(\\$\\(\\$[^$]*\\$\\|[^$]*\\)\\$\\)" 1 formula) ; '$...$' or '$$...$$'
-
- ;; things that bring in external files
- ("\\\\\\(include\\|input\\|bibliography\\){" "}" include)
-
- ;; "wysiwyg" emphasis -- these don't work with nested expressions
- ;; ("{\\\\\\(em\\|it\\|sl\\)" "}" italic)
- ;; ("{\\\\bf" "}" bold)
-
- ("``" "''" string)
-
- ;; things that do some sort of cross-reference
- ("\\\\\\(\\(no\\)?cite\\|\\(page\\)?ref\\|label\\|index\\|glossary\\){" "}" crossref)
- ))
-
-(hilit-set-mode-patterns
- 'bibtex-mode
- '(;;(";.*$" nil comment)
- ("%.*$" nil comment)
- ("@[a-zA-Z]+" nil keyword)
- ("{[ \t]*[-a-z:_A-Z0-9]+," nil label) ; is wrong sometimes
- ("^[ \t]*[a-zA-Z]+[ \t]*=" nil define)))
-
-(hilit-set-mode-patterns
- 'compilation-mode
- '(
- ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+: warning:.*$" nil warning)
- ("^[-_.\"A-Za-z0-9]+\\(:\\|, line \\)[0-9]+:.*$" nil error)
- ))
-
-(hilit-set-mode-patterns
- 'makefile-mode
- '(("^#.*$" nil comment)
- ("[^$]#.*$" nil comment)
- ;; rules
- ("^[^ \t\n]*%[^ \t\n]*[ \t]*::?[ \t]*[^ \t\n]*[ \t]*\\(#.*\\)?$" nil rule)
- ("^[.][A-Za-z][A-Za-z]?\..*$" nil rule)
- ;; variable definition
- ("^[_A-Za-z0-9]+[ \t]*\+?=" nil define)
- ("\\( \\|:=\\)[_A-Za-z0-9]+[ \t]*\\+=" nil define)
- ;; variable references
- ("\\$\\([^ \t\n{(]\\|[{(]@?[_A-Za-z0-9:.,%/=]+[)}]\\)" nil keyword)
- ("^[A-Za-z0-9.,/_-]+[ \t]*:.*$" nil defun)
- ("^include " nil include)))
-
-(let* ((header-patterns '(("^Subject:.*$" nil msg-subject)
- ("^From:.*$" nil msg-from)
- ("^--text follows this line--$" nil msg-separator)
- ("^[A-Za-z][A-Za-z0-9-]+:" nil msg-header)))
- (body-patterns '(("^\\(In article\\|[ \t]*\\w*[]<>}|]\\).*$"
- nil msg-quote)))
- (message-patterns (append header-patterns body-patterns)))
- (hilit-set-mode-patterns 'msg-header header-patterns)
- (hilit-set-mode-patterns 'msg-body body-patterns)
- (hilit-set-mode-patterns '(vm-mode text-mode mail-mode rmail-mode
- gnus-article-mode news-reply-mode mh-show-mode)
- message-patterns
- 'hilit-rehighlight-message))
-
-(hilit-set-mode-patterns
- 'gnus-group-mode
- '(("^ U.*$" nil gnus-group-unsubscribed)
- ("^\\*? +[01]?[0-9]:.*$" nil gnus-group-empty)
- ("^ +[2-9][0-9]:.*$" nil gnus-group-full)
- ("^ +[0-9][0-9][0-9]+:.*$" nil gnus-group-overflowing)))
-
-(hilit-set-mode-patterns
- 'vm-summary-mode
- '(("^ .*$" nil summary-seen)
- ("^->.*$" nil summary-current)
- ("^ D.*$" nil summary-deleted)
- ("^ U.*$" nil summary-unread)
- ("^ N.*$" nil summary-new)))
-
-
-;;; this will match only comments w/ an even (zero is even) number of quotes...
-;;; which is still inadequate because it matches comments in multi-line strings
-;;; how anal do you want to get about never highlighting comments in strings?
-;;; I could twiddle with this forever and still it wouldn't be perfect.
-;;; (";\\([^\"\n]*\"[^\"\n]*\"\\)*[^\"\n]*$" nil comment)
-
-(hilit-set-mode-patterns
- '(emacs-lisp-mode lisp-interaction-mode)
- '(
- (";.*" nil comment)
-
-;;; This almost works...but I think I'll stick with the parser function
-;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string)
- (hilit-string-find ?\\ string)
-
- ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|subst\\)[ \t\n]"
- "\\()\\|nil\\)" defun)
- ("^\\s *(defvar\\s +\\S +" nil decl)
- ("^\\s *(defconst\\s +\\S +" nil define)
- ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include)
- ("\\s *\\&\\(rest\\|optional\\)\\s *" nil keyword)
- ("(\\(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)
- ))
-
-(hilit-set-mode-patterns
- '(lisp-mode ilisp-mode)
- '(
- (";.*" nil comment)
- ("#|" "|#" comment)
-;;; This almost works...but I think I'll stick with the parser function
-;;;("[^?]\\(\"\\(\"\\||\\([^\"]+\\|[\\]\\([\\][\\]\\)*\"\\)*\"\\)\\)" 1 string)
- (hilit-string-find ?\\ string)
-
- ;; this is waaaaaaaay too slow
- ;; ("^\\s *(def\\(un\\|macro\\|advice\\|alias\\|method\\|subst\\)\\s \\S +[ \t\n]+\\(nil\\|(\\(([^()]*)\\|[^()]+\\)*)\\)" nil defun)
- ("^\\s *(def\\(un\\|macro\\|advice\\|subst\\|method\\)\\s " "\\()\\|nil\\)" defun)
-
- ("^\\s *(\\(def\\(var\\|type\\|parameter\\)\\|declare\\)\\s +\\S +" nil decl)
- ("^\\s *(def\\(const\\(ant\\)?\\|class\\|struct\\)\\s \\S +[ \t\n]+" nil define)
- ("^\\s *(\\(provide\\|require\\|\\(auto\\)?load\\).*$" nil include)
- ("[ \t]\\&\\(key\\|rest\\|optional\\|aux\\)\\s *" nil keyword)
- ("(\\(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)
- ))
-
-
-(hilit-set-mode-patterns
- 'plain-tex-mode
- '(("^%%.*$" nil comment)
- ("{\\\\em\\([^}]+\\)}" nil comment)
- ("\\(\\\\\\w+\\)" nil keyword)
- ("{\\\\bf\\([^}]+\\)}" nil keyword)
- ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" nil defun)
- ("\\\\\\(begin\\|end\\){\\([A-Za-z0-9\\*]+\\)}" nil defun)
- ;; ("[^\\\\]\\$\\([^$]*\\)\\$" nil string)
- ("\\$\\([^$]*\\)\\$" nil string)
- ))
-
-;; Reasonable extensions would include smarter parameter handling for such
-;; things as the .IX and .I macros, which alternate the handling of following
-;; arguments.
-
-(hilit-set-mode-patterns
- 'nroff-mode
- '(("^\\.[\\\][\\\"].*$" nil comment)
- ("^\\.so .*$" nil include)
- ("^\\.[ST]H.*$" nil defun)
-;; ("^[^\\.].*\"[^\\\"]*\\(\\\\\\(.\\)[^\\\"]*\\)*\"" nil string)
- ("\"" "[^\\]\"" string)
- ("^\\.[A-Z12\\\\].*$" nil define)
- ("\\([\\\][^ ]*\\)" nil keyword)
- ("^\\.[A-Z].*$" nil keyword))
- nil 'case-insensitive)
-
-(hilit-set-mode-patterns
- 'texinfo-mode
- '(("^\\(@c\\|@comment\\)\\>.*$" nil comment)
- ("@\\(emph\\|strong\\|b\\|i\\){[^}]+}" nil comment)
-;; seems broken
-;; ("\\$[^$]*\\$" nil string)
- ("@\\(file\\|kbd\\|key\\){[^}]+}" nil string)
- ("^\\*.*$" nil defun)
- ("@\\(if\\w+\\|format\\|item\\)\\b.*$" nil defun)
- ("@end +[A-Za-z0-9]+[ \t]*$" nil defun)
- ("@\\(samp\\|code\\|var\\){[^}]+}" nil defun)
- ("@\\w+\\({[^}]+}\\)?" nil keyword)
- ))
-
-(hilit-set-mode-patterns
- 'dired-mode
- (append
- '(("^D.*$" nil dired-deleted)
- ("^\\*.*$" nil dired-marked)
- ("^ d.*$" nil dired-directory)
- ("^ l.*$" nil dired-link)
- ("^ -.*#.*#$" nil dired-ignored))
- (list (cons
- (concat "^ .*\\("
- (mapconcat 'regexp-quote completion-ignored-extensions "\\|")
- "\\)$")
- '(nil dired-ignored)))))
-
-(hilit-set-mode-patterns
- 'jargon-mode
- '(("^:[^:]*:" nil jargon-entry)
- ("{[^}]*}+" nil jargon-xref)))
-
-(hilit-set-mode-patterns
- 'Info-mode
- '(("^\\* [^:]+:+" nil jargon-entry)
- ("\\*[Nn]ote\\b[^:]+:+" nil jargon-xref)
- (" \\(Next\\|Prev\\|Up\\):" nil jargon-xref)
- ("- \\(Variable\\|Function\\|Macro\\|Command\\|Special Form\\|User Option\\):.*$"
- nil jargon-keyword))) ; lisp manual
-
-(hilit-set-mode-patterns
- 'calendar-mode
- '(("[A-Z][a-z]+ [0-9]+" nil define) ; month and year
- ("S M Tu W Th F S" nil label))) ; week days
-
-(hilit-set-mode-patterns
- 'asm-mode
- '(("/\\*" "\\*/" comment)
- ("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define)
- ("^#.*$" nil include)
- ;; labels
- ("^.+:" nil defun)
- ;; assembler directives
- ("^[ \t]*\\..*$" nil decl)
- ;; register names
- ("\\$[a-z0-9]+" nil string)
- ;; mnemonics
- ("^[ \t]*[a-z]+" nil struct)))
-
-(hilit-set-mode-patterns
- 'pascal-mode
- '(("(\\*" "\\*)" comment)
- ("{" "}" comment)
- ;; Doesn't work when there are strings in comments....
- ;; ("'[^']*'" nil string)
- ("^#.*$" nil include)
- ("^[ \t]*\\(procedure\\|function\\)[ \t]+\\w+[^ \t(;]*" nil defun)
- ("\\<\\(program\\|begin\\|end\\)\\>" nil defun)
- ("\\<\\(external\\|forward\\)\\>" nil include)
- ("\\<\\(label\\|const\\|type\\|var\\)\\>" nil define)
- ("\\<\\(record\\|array\\|file\\)\\>" nil type)
- ("\\<\\(of\\|to\\|for\\|if\\|then\\|else\\|case\\|while\\|do\\|until\\|and\\|or\\|not\\|with\\|repeat\\)\\>" nil keyword)
- )
- nil 'case-insensitive)
-
-(hilit-set-mode-patterns
- 'icon-mode
- '(("#.*$" nil comment)
- ("\"[^\\\"]*\\(\\\\.[^\\\"]*\\)*\"" nil string)
- ;; charsets: these do not work because of a conflict with strings
- ;; ("'[^\\']*\\(\\\\.[^\\']*\\)*'" nil string)
- ("^[ \t]*procedure[ \t]+\\w+[ \t]*(" ")" defun)
- ("^[ \t]*record.*(" ")" include)
- ("^[ \t]*\\(global\\|link\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil include)
- ("^[ \t]*\\(local\\|static\\)[ \t\n]+[A-Za-z_0-9]+\\([ \t\n]*,[ \t\n]*[A-Za-z_0-9]+\\)*" nil decl)
- ("\\<\\(initial\\|end\\)\\>" nil glob-struct)
- ("\\<\\(while\\|until\\|return\\|every\\|if\\|then\\|else\\|to\\|case\\|of\\|suspend\\|create\\|do\\|repeat\\|break\\)\\>" nil keyword)
- ))
-
-;; as you can see, I had two similar problems for Pascal and Icon. In
-;; Pascal, strings are delimited with ' and an embedded quote is doubled,
-;; thus string syntax would be extremely simple. However, if a string
-;; occurs within a comment, the following text is considered a string.
-;;
-;; In Icon, strings are similar to C ones, but there are also charsets,
-;; delimited with simple quotes. I could not manage to use both regexps at
-;; the same time.
-
-;; The problem I have with my patterns for Icon is that this language has a
-;; string similar constant to the C one (but a string can be cut on several
-;; lines, if terminated by a dash and continued with initial blanks, like
-;; this:
-;; "This is a somewhat long -
-;; string, written on three -
-;; successive lines"
-;; in order to insert a double quote in a string, you have to escape it
-;; with a \), bu also a character set constant (named a charset), which
-;; uses single quotes instead of double ones. It would seem intuitive to
-;; highlight both constants in the same way.
-
-
-(provide 'hilit19)
-
-;; arch-tag: db99739a-4837-41ee-ad02-3baced8ae71d
-;;; hilit19.el ends here
diff --git a/lisp/obsolete/hscroll.el b/lisp/obsolete/hscroll.el
deleted file mode 100644
index 98300503f8..0000000000
--- a/lisp/obsolete/hscroll.el
+++ /dev/null
@@ -1,106 +0,0 @@
-;;; hscroll.el --- automatically scroll truncated lines horizontally
-
-;; Copyright (C) 1992, 1993, 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Author: Wayne Mesard <wmesard@esd.sgi.com>
-;; Keywords: display
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;; This file contains dummy variables and functions only because Emacs
-;; does hscrolling automatically, now.
-
-;;; Code:
-
-;;;
-;;; PUBLIC VARIABLES
-;;;
-
-(defvar hscroll-version "0.0")
-
-(defgroup hscroll nil
- "This customization group is kept for compatibility only.
-Emacs now does hscrolling automatically. Please remove references
-to hscroll from your init file and code."
- :group 'editing)
-
-
-(defcustom hscroll-global-mode nil
- "*Obsolete."
- :group 'hscroll
- :type 'boolean
- :require 'hscroll
- :version "20.3")
-
-(defcustom hscroll-margin 5
- "*Obsolete."
- :group 'hscroll
- :type 'integer)
-
-(defcustom hscroll-snap-threshold 30
- "*Obsolete."
- :group 'hscroll
- :type 'integer)
-
-(defcustom hscroll-step-percent 25
- "*Obsolete."
- :group 'hscroll
- :type 'integer)
-
-(defcustom hscroll-mode-name " Hscr"
- "*Obsolete."
- :group 'hscroll
- :type 'string)
-
-;;;
-;;; PUBLIC COMMANDS
-;;;
-
-;;;###autoload
-(defun turn-on-hscroll ()
- "This function is obsolete.
-Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
-Also see `automatic-hscrolling'.")
-
-;;;###autoload
-(defun hscroll-mode (&optional arg)
- "This function is obsolete.
-Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
-Also see `automatic-hscrolling'."
- (interactive "P"))
-
-;;;###autoload
-(defun hscroll-global-mode (&optional arg)
- "This function is obsolete.
-Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
-Also see `automatic-hscrolling'."
- (interactive "P"))
-
-(defun hscroll-window-maybe ()
- "This function is obsolete.
-Emacs now does hscrolling automatically, if `truncate-lines' is non-nil.
-Also see `automatic-hscrolling'."
- (interactive))
-
-(provide 'hscroll)
-
-;; arch-tag: 48377520-e5ca-401d-b360-3881b2d5a05a
-;;; hscroll.el ends here
diff --git a/lisp/obsolete/lselect.el b/lisp/obsolete/lselect.el
deleted file mode 100644
index bf689eb5ec..0000000000
--- a/lisp/obsolete/lselect.el
+++ /dev/null
@@ -1,247 +0,0 @@
-;;; lselect.el --- Lucid interface to X Selections
-
-;; Copyright (C) 1990, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: emulations
-
-;; This won't completely work until we support or emulate Lucid-style extents.
-;; Based on Lucid's selection code.
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 23.1.
-
-;;; Code:
-
-;; The selection code requires us to use certain symbols whose names are
-;; all upper-case; this may seem tasteless, but it makes there be a 1:1
-;; correspondence between these symbols and X Atoms (which are upcased.)
-
-;; This is Lucid/XEmacs stuff
-(defvar mouse-highlight-priority)
-(defvar x-lost-selection-functions)
-(defvar zmacs-regions)
-
-(defalias 'x-get-cutbuffer 'x-get-cut-buffer)
-(defalias 'x-store-cutbuffer 'x-set-cut-buffer)
-
-(or (facep 'primary-selection)
- (make-face 'primary-selection))
-
-(or (facep 'secondary-selection)
- (make-face 'secondary-selection))
-
-(defun x-get-secondary-selection ()
- "Return text selected from some X window."
- (x-get-selection-internal 'SECONDARY 'STRING))
-
-(defvar primary-selection-extent nil
- "The extent of the primary selection; don't use this.")
-
-(defvar secondary-selection-extent nil
- "The extent of the secondary selection; don't use this.")
-
-
-(defun x-select-make-extent-for-selection (selection previous-extent face)
- ;; Given a selection, this makes an extent in the buffer which holds that
- ;; selection, for highlighting purposes. If the selection isn't associated
- ;; with a buffer, this does nothing.
- (let ((buffer nil)
- (valid (and (extentp previous-extent)
- (extent-buffer previous-extent)
- (buffer-name (extent-buffer previous-extent))))
- start end)
- (cond ((stringp selection)
- ;; if we're selecting a string, lose the previous extent used
- ;; to highlight the selection.
- (setq valid nil))
- ((consp selection)
- (setq start (min (car selection) (cdr selection))
- end (max (car selection) (cdr selection))
- valid (and valid
- (eq (marker-buffer (car selection))
- (extent-buffer previous-extent)))
- buffer (marker-buffer (car selection))))
- ((extentp selection)
- (setq start (extent-start-position selection)
- end (extent-end-position selection)
- valid (and valid
- (eq (extent-buffer selection)
- (extent-buffer previous-extent)))
- buffer (extent-buffer selection)))
- )
- (if (and (not valid)
- (extentp previous-extent)
- (extent-buffer previous-extent)
- (buffer-name (extent-buffer previous-extent)))
- (delete-extent previous-extent))
- (if (not buffer)
- ;; string case
- nil
- ;; normal case
- (if valid
- (set-extent-endpoints previous-extent start end)
- (setq previous-extent (make-extent start end buffer))
- ;; use same priority as mouse-highlighting so that conflicts between
- ;; the selection extent and a mouse-highlighted extent are resolved
- ;; by the usual size-and-endpoint-comparison method.
- (set-extent-priority previous-extent mouse-highlight-priority)
- (set-extent-face previous-extent face)))))
-
-
-(defun x-own-selection (selection &optional type)
- "Make a primary X Selection of the given argument.
-The argument may be a string, a cons of two markers, or an extent.
-In the latter cases the selection is considered to be the text
-between the markers, or the between extents endpoints."
- (interactive (if (not current-prefix-arg)
- (list (read-string "Store text for pasting: "))
- (list (cons ;; these need not be ordered.
- (copy-marker (point-marker))
- (copy-marker (mark-marker))))))
- (or type (setq type 'PRIMARY))
- (x-set-selection selection type)
- (cond ((eq type 'PRIMARY)
- (setq primary-selection-extent
- (x-select-make-extent-for-selection
- selection primary-selection-extent 'primary-selection)))
- ((eq type 'SECONDARY)
- (setq secondary-selection-extent
- (x-select-make-extent-for-selection
- selection secondary-selection-extent 'secondary-selection))))
- selection)
-
-
-(defun x-own-secondary-selection (selection &optional type)
- "Make a secondary X Selection of the given argument. The argument may be a
-string or a cons of two markers (in which case the selection is considered to
-be the text between those markers.)"
- (interactive (if (not current-prefix-arg)
- (list (read-string "Store text for pasting: "))
- (list (cons ;; these need not be ordered.
- (copy-marker (point-marker))
- (copy-marker (mark-marker))))))
- (x-own-selection selection 'SECONDARY))
-
-
-(defun x-own-clipboard (string)
- "Paste the given string to the X Clipboard."
- (x-own-selection string 'CLIPBOARD))
-
-
-(defun x-disown-selection (&optional secondary-p)
- "Assuming we own the selection, disown it. With an argument, discard the
-secondary selection instead of the primary selection."
- (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
-
-(defun x-dehilight-selection (selection)
- "for use as a value of `x-lost-selection-functions'."
- (cond ((eq selection 'PRIMARY)
- (if primary-selection-extent
- (let ((inhibit-quit t))
- (delete-extent primary-selection-extent)
- (setq primary-selection-extent nil)))
- (if zmacs-regions (zmacs-deactivate-region)))
- ((eq selection 'SECONDARY)
- (if secondary-selection-extent
- (let ((inhibit-quit t))
- (delete-extent secondary-selection-extent)
- (setq secondary-selection-extent nil)))))
- nil)
-
-(setq x-lost-selection-functions 'x-dehilight-selection)
-
-(defun x-notice-selection-requests (selection type successful)
- "for possible use as the value of `x-sent-selection-functions'."
- (if (not successful)
- (message "Selection request failed to convert %s to %s"
- selection type)
- (message "Sent selection %s as %s" selection type)))
-
-(defun x-notice-selection-failures (selection type successful)
- "for possible use as the value of `x-sent-selection-functions'."
- (or successful
- (message "Selection request failed to convert %s to %s"
- selection type)))
-
-;(setq x-sent-selection-functions 'x-notice-selection-requests)
-;(setq x-sent-selection-functions 'x-notice-selection-failures)
-
-
-;; Random utility functions
-
-(defun x-kill-primary-selection ()
- "If there is a selection, delete the text it covers, and copy it to
-both the kill ring and the Clipboard."
- (interactive)
- (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
- (setq last-command nil)
- (or primary-selection-extent
- (error "the primary selection is not an extent?"))
- (save-excursion
- (set-buffer (extent-buffer primary-selection-extent))
- (kill-region (extent-start-position primary-selection-extent)
- (extent-end-position primary-selection-extent)))
- (x-disown-selection nil))
-
-(defun x-delete-primary-selection ()
- "If there is a selection, delete the text it covers *without* copying it to
-the kill ring or the Clipboard."
- (interactive)
- (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
- (setq last-command nil)
- (or primary-selection-extent
- (error "the primary selection is not an extent?"))
- (save-excursion
- (set-buffer (extent-buffer primary-selection-extent))
- (delete-region (extent-start-position primary-selection-extent)
- (extent-end-position primary-selection-extent)))
- (x-disown-selection nil))
-
-(defun x-copy-primary-selection ()
- "If there is a selection, copy it to both the kill ring and the Clipboard."
- (interactive)
- (setq last-command nil)
- (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
- (or primary-selection-extent
- (error "the primary selection is not an extent?"))
- (save-excursion
- (set-buffer (extent-buffer primary-selection-extent))
- (copy-region-as-kill (extent-start-position primary-selection-extent)
- (extent-end-position primary-selection-extent))))
-
-(defun x-yank-clipboard-selection ()
- "If someone owns a Clipboard selection, insert it at point."
- (interactive)
- (setq last-command nil)
- (let ((clip (x-get-clipboard)))
- (or clip (error "there is no clipboard selection"))
- (push-mark)
- (insert clip)))
-
-(provide 'lselect)
-
-
-;; Local variables:
-;; byte-compile-warnings: (not unresolved)
-;; End:
-
-;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556
-;;; lselect.el ends here
diff --git a/lisp/obsolete/mlsupport.el b/lisp/obsolete/mlsupport.el
deleted file mode 100644
index 04f6b8fa9e..0000000000
--- a/lisp/obsolete/mlsupport.el
+++ /dev/null
@@ -1,430 +0,0 @@
-;;; mlsupport.el --- run-time support for mocklisp code
-
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: extensions
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 22.1.
-
-;; This package provides equivalents of certain primitives from Gosling
-;; Emacs (including the commercial UniPress versions). These have an
-;; ml- prefix to distinguish them from native GNU Emacs functions with
-;; similar names. The package mlconvert.el translates Mocklisp code
-;; to use these names.
-
-;;; Code:
-
-(defmacro ml-defun (&rest defs)
- (list 'ml-defun-1 (list 'quote defs)))
-
-(defun ml-defun-1 (args)
- (while args
- (fset (car (car args)) (cons 'mocklisp (cdr (car args))))
- (setq args (cdr args))))
-
-(defmacro declare-buffer-specific (&rest vars)
- (cons 'progn (mapcar (function (lambda (var) (list 'make-variable-buffer-local (list 'quote var)))) vars)))
-
-(defun ml-set-default (varname value)
- (set-default (intern varname) value))
-
-; Lossage: must make various things default missing args to the prefix arg
-; Alternatively, must make provide-prefix-argument do something hairy.
-
-(defun >> (val count) (lsh val (- count)))
-(defun novalue () nil)
-
-(defun ml-not (arg) (if (zerop arg) 1 0))
-
-(defun provide-prefix-arg (arg form)
- (funcall (car form) arg))
-
-(defun define-keymap (name)
- (fset (intern name) (make-keymap)))
-
-;; Make it work to use ml-use-...-map on "esc" and such.
-(fset 'esc-map esc-map)
-(fset 'ctl-x-map ctl-x-map)
-
-(defun ml-use-local-map (name)
- (use-local-map (intern (concat name "-map"))))
-
-(defun ml-use-global-map (name)
- (use-global-map (intern (concat name "-map"))))
-
-(defun local-bind-to-key (name key)
- (or (current-local-map)
- (use-local-map (make-keymap)))
- (define-key (current-local-map)
- (if (integerp key)
- (if (>= key 128)
- (concat (char-to-string meta-prefix-char)
- (char-to-string (- key 128)))
- (char-to-string key))
- key)
- (intern name)))
-
-(defun bind-to-key (name key)
- (define-key global-map (if (integerp key) (char-to-string key) key)
- (intern name)))
-
-(defun ml-autoload (name file)
- (autoload (intern name) file))
-
-(defun ml-define-string-macro (name defn)
- (fset (intern name) defn))
-
-(defun push-back-character (char)
- (setq unread-command-events (list char)))
-
-(defun to-col (column)
- (indent-to column 0))
-
-(defmacro is-bound (&rest syms)
- (cons 'and (mapcar (function (lambda (sym) (list 'boundp (list 'quote sym)))) syms)))
-
-(defmacro declare-global (&rest syms)
- (cons 'progn (mapcar (function (lambda (sym) (list 'defvar sym nil))) syms)))
-
-(defmacro error-occurred (&rest body)
- (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
-
-(defun return-prefix-argument (value)
- (setq prefix-arg value))
-
-(defun ml-prefix-argument ()
- (if (null current-prefix-arg) 1
- (if (listp current-prefix-arg) (car current-prefix-arg)
- (if (eq current-prefix-arg '-) -1
- current-prefix-arg))))
-
-(defun ml-print (varname)
- (interactive "vPrint variable: ")
- (if (boundp varname)
- (message "%s => %s" (symbol-name varname) (symbol-value varname))
- (message "%s has no value" (symbol-name varname))))
-
-(defun ml-set (str val) (set (intern str) val))
-
-(defun ml-message (&rest args) (message "%s" (apply 'concat args)))
-
-(defun set-auto-fill-hook (arg)
- (setq auto-fill-function (intern arg)))
-
-(defun auto-execute (function pattern)
- (if (/= (aref pattern 0) ?*)
- (error "Only patterns starting with * supported in auto-execute"))
- (setq auto-mode-alist (cons (cons (concat "\\." (substring pattern 1)
- "\\'")
- function)
- auto-mode-alist)))
-
-(defun move-to-comment-column ()
- (indent-to comment-column))
-
-(defun erase-region ()
- (delete-region (point) (mark)))
-
-(defun delete-region-to-buffer (bufname)
- (copy-to-buffer bufname (point) (mark))
- (delete-region (point) (mark)))
-
-(defun copy-region-to-buffer (bufname)
- (copy-to-buffer bufname (point) (mark)))
-
-(defun append-region-to-buffer (bufname)
- (append-to-buffer bufname (point) (mark)))
-
-(defun prepend-region-to-buffer (bufname)
- (prepend-to-buffer bufname (point) (mark)))
-
-(defun delete-next-character ()
- (delete-char (ml-prefix-argument)))
-
-(defun delete-next-word ()
- (delete-region (point) (progn (forward-word (ml-prefix-argument)) (point))))
-
-(defun delete-previous-word ()
- (delete-region (point) (progn (backward-word (ml-prefix-argument)) (point))))
-
-(defun delete-previous-character ()
- (delete-backward-char (ml-prefix-argument)))
-
-(defun forward-character ()
- (forward-char (ml-prefix-argument)))
-
-(defun backward-character ()
- (backward-char (ml-prefix-argument)))
-
-(defun ml-newline ()
- (newline (ml-prefix-argument)))
-
-(defun ml-next-line ()
- (forward-line (ml-prefix-argument)))
-
-(defun ml-previous-line ()
- (forward-line (- (ml-prefix-argument))))
-
-(defun delete-to-kill-buffer ()
- (kill-region (point) (mark)))
-
-(defun narrow-region ()
- (narrow-to-region (point) (mark)))
-
-(defun ml-newline-and-indent ()
- (let ((column (current-indentation)))
- (newline (ml-prefix-argument))
- (indent-to column)))
-
-(defun newline-and-backup ()
- (open-line (ml-prefix-argument)))
-
-(defun quote-char ()
- (quoted-insert (ml-prefix-argument)))
-
-(defun ml-current-column ()
- (1+ (current-column)))
-
-(defun ml-current-indent ()
- (1+ (current-indentation)))
-
-(defun region-around-match (&optional n)
- (set-mark (match-beginning n))
- (goto-char (match-end n)))
-
-(defun region-to-string ()
- (buffer-substring (min (point) (mark)) (max (point) (mark))))
-
-(defun use-abbrev-table (name)
- (let ((symbol (intern (concat name "-abbrev-table"))))
- (or (boundp symbol)
- (define-abbrev-table symbol nil))
- (symbol-value symbol)))
-
-(defun define-hooked-local-abbrev (name exp hook)
- (define-abbrev local-abbrev-table name exp (intern hook)))
-
-(defun define-hooked-global-abbrev (name exp hook)
- (define-abbrev global-abbrev-table name exp (intern hook)))
-
-(defun case-word-lower ()
- (ml-casify-word 'downcase-region))
-
-(defun case-word-upper ()
- (ml-casify-word 'upcase-region))
-
-(defun case-word-capitalize ()
- (ml-casify-word 'capitalize-region))
-
-(defun ml-casify-word (fun)
- (save-excursion
- (forward-char 1)
- (forward-word -1)
- (funcall fun (point)
- (progn (forward-word (ml-prefix-argument))
- (point)))))
-
-(defun case-region-lower ()
- (downcase-region (point) (mark)))
-
-(defun case-region-upper ()
- (upcase-region (point) (mark)))
-
-(defun case-region-capitalize ()
- (capitalize-region (point) (mark)))
-
-(defvar saved-command-line-args nil)
-
-(defun argc ()
- (or saved-command-line-args
- (setq saved-command-line-args command-line-args
- command-line-args ()))
- (length command-line-args))
-
-(defun argv (i)
- (or saved-command-line-args
- (setq saved-command-line-args command-line-args
- command-line-args ()))
- (nth i saved-command-line-args))
-
-(defun invisible-argc ()
- (length (or saved-command-line-args
- command-line-args)))
-
-(defun invisible-argv (i)
- (nth i (or saved-command-line-args
- command-line-args)))
-
-(defun exit-emacs ()
- (interactive)
- (condition-case ()
- (exit-recursive-edit)
- (error (kill-emacs))))
-
-;; Lisp function buffer-size returns total including invisible;
-;; mocklisp wants just visible.
-(defun ml-buffer-size ()
- (- (point-max) (point-min)))
-
-(defun previous-command ()
- last-command)
-
-(defun beginning-of-window ()
- (goto-char (window-start)))
-
-(defun end-of-window ()
- (goto-char (window-start))
- (vertical-motion (- (window-height) 2)))
-
-(defun ml-search-forward (string)
- (search-forward string nil nil (ml-prefix-argument)))
-
-(defun ml-re-search-forward (string)
- (re-search-forward string nil nil (ml-prefix-argument)))
-
-(defun ml-search-backward (string)
- (search-backward string nil nil (ml-prefix-argument)))
-
-(defun ml-re-search-backward (string)
- (re-search-backward string nil nil (ml-prefix-argument)))
-
-(defvar use-users-shell 1
- "Mocklisp compatibility variable; 1 means use shell from SHELL env var.
-0 means use /bin/sh.")
-
-(defvar use-csh-option-f 1
- "Mocklisp compatibility variable; 1 means pass -f when calling csh.")
-
-(defun filter-region (command)
- (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
- (csh (equal (file-name-nondirectory shell) "csh")))
- (call-process-region (point) (mark) shell t t nil
- (if (and csh use-csh-option-f) "-cf" "-c")
- (concat "exec " command))))
-
-(defun execute-monitor-command (command)
- (let* ((shell (if (/= use-users-shell 0) shell-file-name "/bin/sh"))
- (csh (equal (file-name-nondirectory shell) "csh")))
- (call-process shell nil t t
- (if (and csh use-csh-option-f) "-cf" "-c")
- (concat "exec " command))))
-
-(defun use-syntax-table (name)
- (set-syntax-table (symbol-value (intern (concat name "-syntax-table")))))
-
-(defun line-to-top-of-window ()
- (recenter (1- (ml-prefix-argument))))
-
-(defun ml-previous-page (&optional arg)
- (let ((count (or arg (ml-prefix-argument))))
- (while (> count 0)
- (scroll-down nil)
- (setq count (1- count)))
- (while (< count 0)
- (scroll-up nil)
- (setq count (1+ count)))))
-
-(defun ml-next-page ()
- (ml-previous-page (- (ml-prefix-argument))))
-
-(defun page-next-window (&optional arg)
- (let ((count (or arg (ml-prefix-argument))))
- (while (> count 0)
- (scroll-other-window nil)
- (setq count (1- count)))
- (while (< count 0)
- (scroll-other-window '-)
- (setq count (1+ count)))))
-
-(defun ml-next-window ()
- (select-window (next-window)))
-
-(defun ml-previous-window ()
- (select-window (previous-window)))
-
-(defun scroll-one-line-up ()
- (scroll-up (ml-prefix-argument)))
-
-(defun scroll-one-line-down ()
- (scroll-down (ml-prefix-argument)))
-
-(defun split-current-window ()
- (split-window (selected-window)))
-
-(defun last-key-struck () last-command-char)
-
-(defun execute-mlisp-line (string)
- (eval (read string)))
-
-(defun move-dot-to-x-y (x y)
- (goto-char (window-start (selected-window)))
- (vertical-motion (1- y))
- (move-to-column (1- x)))
-
-(defun ml-modify-syntax-entry (string)
- (let ((i 5)
- (len (length string))
- (datastring (substring string 0 2)))
- (if (= (aref string 0) ?\-)
- (aset datastring 0 ?\ ))
- (if (= (aref string 2) ?\{)
- (if (= (aref string 4) ?\ )
- (aset datastring 0 ?\<)
- (error "Two-char comment delimiter: use modify-syntax-entry directly")))
- (if (= (aref string 3) ?\})
- (if (= (aref string 4) ?\ )
- (aset datastring 0 ?\>)
- (error "Two-char comment delimiter: use modify-syntax-entry directly")))
- (while (< i len)
- (modify-syntax-entry (aref string i) datastring)
- (setq i (1+ i))
- (if (and (< i len)
- (= (aref string i) ?\-))
- (let ((c (aref string (1- i)))
- (lim (aref string (1+ i))))
- (while (<= c lim)
- (modify-syntax-entry c datastring)
- (setq c (1+ c)))
- (setq i (+ 2 i)))))))
-
-
-
-(defun ml-substr (string from to)
- (let ((length (length string)))
- (if (< from 0) (setq from (+ from length)))
- (if (< to 0) (setq to (+ to length)))
- (substring string from (+ from to))))
-
-(defun ml-concat (&rest args)
- (let ((newargs nil) this)
- (while args
- (setq this (car args))
- (if (numberp this)
- (setq this (number-to-string this)))
- (setq newargs (cons this newargs)
- args (cdr args)))
- (apply 'concat (nreverse newargs))))
-
-(provide 'mlsupport)
-
-;; arch-tag: b0ad09bc-8cb2-4be0-8888-2e874839bcbc
-;;; mlsupport.el ends here
diff --git a/lisp/obsolete/ooutline.el b/lisp/obsolete/ooutline.el
deleted file mode 100644
index 4ce90d9eb5..0000000000
--- a/lisp/obsolete/ooutline.el
+++ /dev/null
@@ -1,587 +0,0 @@
-;;; ooutline.el --- outline mode commands for Emacs
-
-;; Copyright (C) 1986, 1993, 1994, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: outlines
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;; This package is a major mode for editing outline-format documents.
-;; An outline can be `abstracted' to show headers at any given level,
-;; with all stuff below hidden. See the Emacs manual for details.
-
-;;; Code:
-
-;; Jan '86, Some new features added by Peter Desnoyers and rewritten by RMS.
-
-(defgroup outlines nil
- "Support for hierarchical outlining."
- :prefix "outline-"
- :group 'editing)
-
-
-(defcustom outline-regexp nil
- "*Regular expression to match the beginning of a heading.
-Any line whose beginning matches this regexp is considered to start a heading.
-The recommended way to set this is with a Local Variables: list
-in the file it applies to. See also outline-heading-end-regexp."
- :type '(choice regexp (const nil))
- :group 'outlines)
-
-;; Can't initialize this in the defvar above -- some major modes have
-;; already assigned a local value to it.
-(or (default-value 'outline-regexp)
- (setq-default outline-regexp "[*\^L]+"))
-
-(defcustom outline-heading-end-regexp "[\n\^M]"
- "*Regular expression to match the end of a heading line.
-You can assume that point is at the beginning of a heading when this
-regexp is searched for. The heading ends at the end of the match.
-The recommended way to set this is with a \"Local Variables:\" list
-in the file it applies to."
- :type 'regexp
- :group 'outlines)
-
-(defvar outline-mode-prefix-map nil)
-
-(if outline-mode-prefix-map
- nil
- (setq outline-mode-prefix-map (make-sparse-keymap))
- (define-key outline-mode-prefix-map "\C-n" 'outline-next-visible-heading)
- (define-key outline-mode-prefix-map "\C-p" 'outline-previous-visible-heading)
- (define-key outline-mode-prefix-map "\C-i" 'show-children)
- (define-key outline-mode-prefix-map "\C-s" 'show-subtree)
- (define-key outline-mode-prefix-map "\C-d" 'hide-subtree)
- (define-key outline-mode-prefix-map "\C-u" 'outline-up-heading)
- (define-key outline-mode-prefix-map "\C-f" 'outline-forward-same-level)
- (define-key outline-mode-prefix-map "\C-b" 'outline-backward-same-level)
- (define-key outline-mode-prefix-map "\C-t" 'hide-body)
- (define-key outline-mode-prefix-map "\C-a" 'show-all)
- (define-key outline-mode-prefix-map "\C-c" 'hide-entry)
- (define-key outline-mode-prefix-map "\C-e" 'show-entry)
- (define-key outline-mode-prefix-map "\C-l" 'hide-leaves)
- (define-key outline-mode-prefix-map "\C-k" 'show-branches)
- (define-key outline-mode-prefix-map "\C-q" 'hide-sublevels)
- (define-key outline-mode-prefix-map "\C-o" 'hide-other))
-
-(defvar outline-mode-menu-bar-map nil)
-(if outline-mode-menu-bar-map
- nil
- (setq outline-mode-menu-bar-map (make-sparse-keymap))
-
- (define-key outline-mode-menu-bar-map [hide]
- (cons "Hide" (make-sparse-keymap "Hide")))
-
- (define-key outline-mode-menu-bar-map [hide hide-other]
- '("Hide Other" . hide-other))
- (define-key outline-mode-menu-bar-map [hide hide-sublevels]
- '("Hide Sublevels" . hide-sublevels))
- (define-key outline-mode-menu-bar-map [hide hide-subtree]
- '("Hide Subtree" . hide-subtree))
- (define-key outline-mode-menu-bar-map [hide hide-entry]
- '("Hide Entry" . hide-entry))
- (define-key outline-mode-menu-bar-map [hide hide-body]
- '("Hide Body" . hide-body))
- (define-key outline-mode-menu-bar-map [hide hide-leaves]
- '("Hide Leaves" . hide-leaves))
-
- (define-key outline-mode-menu-bar-map [show]
- (cons "Show" (make-sparse-keymap "Show")))
-
- (define-key outline-mode-menu-bar-map [show show-subtree]
- '("Show Subtree" . show-subtree))
- (define-key outline-mode-menu-bar-map [show show-children]
- '("Show Children" . show-children))
- (define-key outline-mode-menu-bar-map [show show-branches]
- '("Show Branches" . show-branches))
- (define-key outline-mode-menu-bar-map [show show-entry]
- '("Show Entry" . show-entry))
- (define-key outline-mode-menu-bar-map [show show-all]
- '("Show All" . show-all))
-
- (define-key outline-mode-menu-bar-map [headings]
- (cons "Headings" (make-sparse-keymap "Headings")))
-
- (define-key outline-mode-menu-bar-map [headings outline-backward-same-level]
- '("Previous Same Level" . outline-backward-same-level))
- (define-key outline-mode-menu-bar-map [headings outline-forward-same-level]
- '("Next Same Level" . outline-forward-same-level))
- (define-key outline-mode-menu-bar-map [headings outline-previous-visible-heading]
- '("Previous" . outline-previous-visible-heading))
- (define-key outline-mode-menu-bar-map [headings outline-next-visible-heading]
- '("Next" . outline-next-visible-heading))
- (define-key outline-mode-menu-bar-map [headings outline-up-heading]
- '("Up" . outline-up-heading)))
-
-(defvar outline-mode-map nil "")
-
-(if outline-mode-map
- nil
- (setq outline-mode-map (nconc (make-sparse-keymap) text-mode-map))
- (define-key outline-mode-map "\C-c" outline-mode-prefix-map)
- (define-key outline-mode-map [menu-bar] outline-mode-menu-bar-map))
-
-(defcustom outline-minor-mode nil
- "Non-nil if using Outline mode as a minor mode of some other mode."
- :type 'boolean
- :group 'outlines)
-(make-variable-buffer-local 'outline-minor-mode)
-(put 'outline-minor-mode 'permanent-local t)
-(or (assq 'outline-minor-mode minor-mode-alist)
- (setq minor-mode-alist (append minor-mode-alist
- (list '(outline-minor-mode " Outl")))))
-
-(defvar outline-font-lock-keywords
- '(;; Highlight headings according to the level.
- ("^\\([*]+\\)[ \t]*\\([^\n\r]+\\)?[ \t]*[\n\r]"
- (1 font-lock-string-face)
- (2 (let ((len (- (match-end 1) (match-beginning 1))))
- (or (cdr (assq len '((1 . font-lock-function-name-face)
- (2 . font-lock-keyword-face)
- (3 . font-lock-comment-face))))
- font-lock-variable-name-face))
- nil t))
- ;; Highlight citations of the form [1] and [Mar94].
- ("\\[\\([[:upper:]][[:alpha:]]+\\)*[0-9]+\\]" . font-lock-type-face))
- "Additional expressions to highlight in Outline mode.")
-
-(defun outline-mode ()
- "Set major mode for editing outlines with selective display.
-Headings are lines which start with asterisks: one for major headings,
-two for subheadings, etc. Lines not starting with asterisks are body lines.
-
-Body text or subheadings under a heading can be made temporarily
-invisible, or visible again. Invisible lines are attached to the end
-of the heading, so they move with it, if the line is killed and yanked
-back. A heading with text hidden under it is marked with an ellipsis (...).
-
-Commands:\\<outline-mode-map>
-\\[outline-next-visible-heading] outline-next-visible-heading move by visible headings
-\\[outline-previous-visible-heading] outline-previous-visible-heading
-\\[outline-forward-same-level] outline-forward-same-level similar but skip subheadings
-\\[outline-backward-same-level] outline-backward-same-level
-\\[outline-up-heading] outline-up-heading move from subheading to heading
-
-\\[hide-body] make all text invisible (not headings).
-\\[show-all] make everything in buffer visible.
-
-The remaining commands are used when point is on a heading line.
-They apply to some of the body or subheadings of that heading.
-\\[hide-subtree] hide-subtree make body and subheadings invisible.
-\\[show-subtree] show-subtree make body and subheadings visible.
-\\[show-children] show-children make direct subheadings visible.
- No effect on body, or subheadings 2 or more levels down.
- With arg N, affects subheadings N levels down.
-\\[hide-entry] make immediately following body invisible.
-\\[show-entry] make it visible.
-\\[hide-leaves] make body under heading and under its subheadings invisible.
- The subheadings remain visible.
-\\[show-branches] make all subheadings at all levels visible.
-
-The variable `outline-regexp' can be changed to control what is a heading.
-A line is a heading if `outline-regexp' matches something at the
-beginning of the line. The longer the match, the deeper the level.
-
-Turning on outline mode calls the value of `text-mode-hook' and then of
-`outline-mode-hook', if they are non-nil."
- (interactive)
- (kill-all-local-variables)
- (setq selective-display t)
- (use-local-map outline-mode-map)
- (setq mode-name "Outline")
- (setq major-mode 'outline-mode)
- (define-abbrev-table 'text-mode-abbrev-table ())
- (setq local-abbrev-table text-mode-abbrev-table)
- (set-syntax-table text-mode-syntax-table)
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat paragraph-start "\\|\\("
- outline-regexp "\\)"))
- ;; Inhibit auto-filling of header lines.
- (make-local-variable 'auto-fill-inhibit-regexp)
- (setq auto-fill-inhibit-regexp outline-regexp)
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate (concat paragraph-separate "\\|\\("
- outline-regexp "\\)"))
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(outline-font-lock-keywords t))
- (make-local-variable 'change-major-mode-hook)
- (add-hook 'change-major-mode-hook 'show-all)
- (run-mode-hooks 'text-mode-hook 'outline-mode-hook))
-
-(defcustom outline-minor-mode-prefix "\C-c@"
- "*Prefix key to use for Outline commands in Outline minor mode.
-The value of this variable is checked as part of loading Outline mode.
-After that, changing the prefix key requires manipulating keymaps."
- :type 'string
- :group 'outlines)
-
-(defvar outline-minor-mode-map nil)
-(if outline-minor-mode-map
- nil
- (setq outline-minor-mode-map (make-sparse-keymap))
- (define-key outline-minor-mode-map [menu-bar]
- outline-mode-menu-bar-map)
- (define-key outline-minor-mode-map outline-minor-mode-prefix
- outline-mode-prefix-map))
-
-(or (assq 'outline-minor-mode minor-mode-map-alist)
- (setq minor-mode-map-alist
- (cons (cons 'outline-minor-mode outline-minor-mode-map)
- minor-mode-map-alist)))
-
-(defun outline-minor-mode (&optional arg)
- "Toggle Outline minor mode.
-With arg, turn Outline minor mode on if arg is positive, off otherwise.
-See the command `outline-mode' for more information on this mode."
- (interactive "P")
- (setq outline-minor-mode
- (if (null arg) (not outline-minor-mode)
- (> (prefix-numeric-value arg) 0)))
- (if outline-minor-mode
- (progn
- (setq selective-display t)
- (run-hooks 'outline-minor-mode-hook))
- (setq selective-display nil))
- ;; When turning off outline mode, get rid of any ^M's.
- (or outline-minor-mode
- (outline-flag-region (point-min) (point-max) ?\n))
- (force-mode-line-update))
-
-(defvar outline-level 'outline-level
- "Function of no args to compute a header's nesting level in an outline.
-It can assume point is at the beginning of a header line.")
-
-;; This used to count columns rather than characters, but that made ^L
-;; appear to be at level 2 instead of 1. Columns would be better for
-;; tab handling, but the default regexp doesn't use tabs, and anyone
-;; who changes the regexp can also redefine the outline-level variable
-;; as appropriate.
-(defun outline-level ()
- "Return the depth to which a statement is nested in the outline.
-Point must be at the beginning of a header line. This is actually
-the number of characters that `outline-regexp' matches."
- (save-excursion
- (looking-at outline-regexp)
- (- (match-end 0) (match-beginning 0))))
-
-(defun outline-next-preface ()
- "Skip forward to just before the next heading line.
-If there's no following heading line, stop before the newline
-at the end of the buffer."
- (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
- nil 'move)
- (goto-char (match-beginning 0)))
- (if (memq (preceding-char) '(?\n ?\^M))
- (forward-char -1)))
-
-(defun outline-next-heading ()
- "Move to the next (possibly invisible) heading line."
- (interactive)
- (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
- nil 'move)
- (goto-char (1+ (match-beginning 0)))))
-
-(defun outline-back-to-heading ()
- "Move to previous heading line, or beg of this line if it's a heading.
-Only visible heading lines are considered."
- (beginning-of-line)
- (or (outline-on-heading-p)
- (re-search-backward (concat "^\\(" outline-regexp "\\)") nil t)
- (error "before first heading")))
-
-(defun outline-on-heading-p ()
- "Return t if point is on a (visible) heading line."
- (save-excursion
- (beginning-of-line)
- (and (bolp)
- (looking-at outline-regexp))))
-
-(defun outline-end-of-heading ()
- (if (re-search-forward outline-heading-end-regexp nil 'move)
- (forward-char -1)))
-
-(defun outline-next-visible-heading (arg)
- "Move to the next visible heading line.
-With argument, repeats or can move backward if negative.
-A heading line is one that starts with a `*' (or that
-`outline-regexp' matches)."
- (interactive "p")
- (if (< arg 0)
- (beginning-of-line)
- (end-of-line))
- (or (re-search-forward (concat "^\\(" outline-regexp "\\)") nil t arg)
- (error ""))
- (beginning-of-line))
-
-(defun outline-previous-visible-heading (arg)
- "Move to the previous heading line.
-With argument, repeats or can move forward if negative.
-A heading line is one that starts with a `*' (or that
-`outline-regexp' matches)."
- (interactive "p")
- (outline-next-visible-heading (- arg)))
-
-(defun outline-flag-region (from to flag)
- "Hides or shows lines from FROM to TO, according to FLAG.
-If FLAG is `\\n' (newline character) then text is shown,
-while if FLAG is `\\^M' (control-M) the text is hidden."
- (let (buffer-read-only)
- (subst-char-in-region from to
- (if (= flag ?\n) ?\^M ?\n)
- flag t)))
-
-(defun hide-entry ()
- "Hide the body directly following this heading."
- (interactive)
- (outline-back-to-heading)
- (outline-end-of-heading)
- (save-excursion
- (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\^M)))
-
-(defun show-entry ()
- "Show the body directly following this heading."
- (interactive)
- (save-excursion
- (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\n)))
-
-(defun hide-body ()
- "Hide all of buffer except headings."
- (interactive)
- (hide-region-body (point-min) (point-max)))
-
-(defun hide-region-body (start end)
- "Hide all body lines in the region, but not headings."
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char (point-min))
- (if (outline-on-heading-p)
- (outline-end-of-heading))
- (while (not (eobp))
- (outline-flag-region (point)
- (progn (outline-next-preface) (point)) ?\^M)
- (if (not (eobp))
- (progn
- (forward-char
- (if (looking-at "[\n\^M][\n\^M]")
- 2 1))
- (outline-end-of-heading)))))))
-
-(defun show-all ()
- "Show all of the text in the buffer."
- (interactive)
- (outline-flag-region (point-min) (point-max) ?\n))
-
-(defun hide-subtree ()
- "Hide everything after this heading at deeper levels."
- (interactive)
- (outline-flag-subtree ?\^M))
-
-(defun hide-leaves ()
- "Hide all body after this heading at deeper levels."
- (interactive)
- (outline-back-to-heading)
- (outline-end-of-heading)
- (hide-region-body (point) (progn (outline-end-of-subtree) (point))))
-
-(defun show-subtree ()
- "Show everything after this heading at deeper levels."
- (interactive)
- (outline-flag-subtree ?\n))
-
-(defun hide-sublevels (levels)
- "Hide everything but the top LEVELS levels of headers, in whole buffer."
- (interactive "p")
- (if (< levels 1)
- (error "Must keep at least one level of headers"))
- (setq levels (1- levels))
- (save-excursion
- (goto-char (point-min))
- ;; Keep advancing to the next top-level heading.
- (while (or (and (bobp) (outline-on-heading-p))
- (outline-next-heading))
- (let ((end (save-excursion (outline-end-of-subtree) (point))))
- ;; Hide everything under that.
- (outline-flag-region (point) end ?\^M)
- ;; Show the first LEVELS levels under that.
- (if (> levels 0)
- (show-children levels))
- ;; Move to the next, since we already found it.
- (goto-char end)))))
-
-(defun hide-other ()
- "Hide everything except for the current body and the parent headings."
- (interactive)
- (hide-sublevels 1)
- (let ((last (point))
- (pos (point)))
- (while (save-excursion
- (and (re-search-backward "[\n\r]" nil t)
- (eq (following-char) ?\r)))
- (save-excursion
- (beginning-of-line)
- (if (eq last (point))
- (progn
- (outline-next-heading)
- (outline-flag-region last (point) ?\n))
- (show-children)
- (setq last (point)))))))
-
-(defun outline-flag-subtree (flag)
- (save-excursion
- (outline-back-to-heading)
- (outline-end-of-heading)
- (outline-flag-region (point)
- (progn (outline-end-of-subtree) (point))
- flag)))
-
-(defun outline-end-of-subtree ()
- (outline-back-to-heading)
- (let ((opoint (point))
- (first t)
- (level (funcall outline-level)))
- (while (and (not (eobp))
- (or first (> (funcall outline-level) level)))
- (setq first nil)
- (outline-next-heading))
- (if (memq (preceding-char) '(?\n ?\^M))
- (progn
- ;; Go to end of line before heading
- (forward-char -1)
- (if (memq (preceding-char) '(?\n ?\^M))
- ;; leave blank line before heading
- (forward-char -1))))))
-
-(defun show-branches ()
- "Show all subheadings of this heading, but not their bodies."
- (interactive)
- (show-children 1000))
-
-(defun show-children (&optional level)
- "Show all direct subheadings of this heading.
-Prefix arg LEVEL is how many levels below the current level should be shown.
-Default is enough to cause the following heading to appear."
- (interactive "P")
- (setq level
- (if level (prefix-numeric-value level)
- (save-excursion
- (outline-back-to-heading)
- (let ((start-level (funcall outline-level)))
- (outline-next-heading)
- (if (eobp)
- 1
- (max 1 (- (funcall outline-level) start-level)))))))
- (save-excursion
- (save-restriction
- (outline-back-to-heading)
- (setq level (+ level (funcall outline-level)))
- (narrow-to-region (point)
- (progn (outline-end-of-subtree)
- (if (eobp) (point-max) (1+ (point)))))
- (goto-char (point-min))
- (while (and (not (eobp))
- (progn
- (outline-next-heading)
- (not (eobp))))
- (if (<= (funcall outline-level) level)
- (save-excursion
- (outline-flag-region (save-excursion
- (forward-char -1)
- (if (memq (preceding-char) '(?\n ?\^M))
- (forward-char -1))
- (point))
- (progn (outline-end-of-heading) (point))
- ?\n)))))))
-
-(defun outline-up-heading (arg)
- "Move to the heading line of which the present line is a subheading.
-With argument, move up ARG levels."
- (interactive "p")
- (outline-back-to-heading)
- (if (eq (funcall outline-level) 1)
- (error ""))
- (while (and (> (funcall outline-level) 1)
- (> arg 0)
- (not (bobp)))
- (let ((present-level (funcall outline-level)))
- (while (not (< (funcall outline-level) present-level))
- (outline-previous-visible-heading 1))
- (setq arg (- arg 1)))))
-
-(defun outline-forward-same-level (arg)
- "Move forward to the ARG'th subheading at same level as this one.
-Stop at the first and last subheadings of a superior heading."
- (interactive "p")
- (outline-back-to-heading)
- (while (> arg 0)
- (let ((point-to-move-to (save-excursion
- (outline-get-next-sibling))))
- (if point-to-move-to
- (progn
- (goto-char point-to-move-to)
- (setq arg (1- arg)))
- (progn
- (setq arg 0)
- (error ""))))))
-
-(defun outline-get-next-sibling ()
- "Move to next heading of the same level, and return point or nil if none."
- (let ((level (funcall outline-level)))
- (outline-next-visible-heading 1)
- (while (and (> (funcall outline-level) level)
- (not (eobp)))
- (outline-next-visible-heading 1))
- (if (< (funcall outline-level) level)
- nil
- (point))))
-
-(defun outline-backward-same-level (arg)
- "Move backward to the ARG'th subheading at same level as this one.
-Stop at the first and last subheadings of a superior heading."
- (interactive "p")
- (outline-back-to-heading)
- (while (> arg 0)
- (let ((point-to-move-to (save-excursion
- (outline-get-last-sibling))))
- (if point-to-move-to
- (progn
- (goto-char point-to-move-to)
- (setq arg (1- arg)))
- (progn
- (setq arg 0)
- (error ""))))))
-
-(defun outline-get-last-sibling ()
- "Move to next heading of the same level, and return point or nil if none."
- (let ((level (funcall outline-level)))
- (outline-previous-visible-heading 1)
- (while (and (> (funcall outline-level) level)
- (not (bobp)))
- (outline-previous-visible-heading 1))
- (if (< (funcall outline-level) level)
- nil
- (point))))
-
-(provide 'outline)
-
-;; arch-tag: 14ed00e1-bd40-4db8-86e5-3b82ce326e45
-;;; ooutline.el ends here
diff --git a/lisp/obsolete/profile.el b/lisp/obsolete/profile.el
deleted file mode 100644
index 87b976de6b..0000000000
--- a/lisp/obsolete/profile.el
+++ /dev/null
@@ -1,294 +0,0 @@
-;;; profile.el --- Emacs profiler (OBSOLETE; use elp.el instead)
-
-;; Copyright (C) 1992, 1994, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Author: Boaz Ben-Zvi <boaz@lcs.mit.edu>
-;; Created: 07 Feb 1992
-;; Version: 1.0
-;; Adapted-By: ESR
-;; Keywords: lisp, tools
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;; DESCRIPTION:
-;; ------------
-;; This program can be used to monitor running time performance of Emacs Lisp
-;; functions. It takes a list of functions and report the real time spent
-;; inside these functions. (Actually, for each function it reports the amount
-;; of time spent while at least one instance of that function is on the call
-;; stack. So if profiled function FOO calls profiled function BAR, the time
-;; spent inside BAR is credited to both functions.)
-
-;; HOW TO USE:
-;; -----------
-;; Set the variable profile-functions-list to the list of functions
-;; (as symbols) You want to profile. Call M-x profile-functions to set
-;; this list on and start using your program. Note that profile-functions
-;; MUST be called AFTER all the functions in profile-functions-list have
-;; been loaded !! (This call modifies the code of the profiled functions.
-;; Hence if you reload these functions, you need to call profile-functions
-;; again! ).
-;; To display the results do M-x profile-results . For example:
-;;-------------------------------------------------------------------
-;; (setq profile-functions-list '(sokoban-set-mode-line sokoban-load-game
-;; sokoban-move-vertical sokoban-move))
-;; (load "sokoban")
-;; M-x profile-functions
-;; ... I play the sokoban game ..........
-;; M-x profile-results
-;;
-;; Function Time (Seconds.Useconds)
-;; ======== =======================
-;; sokoban-move 0.539088
-;; sokoban-move-vertical 0.410130
-;; sokoban-load-game 0.453235
-;; sokoban-set-mode-line 1.949203
-;;-----------------------------------------------------
-;; To clear all the settings to profile use profile-finish.
-;; To set one function at a time (instead of or in addition to setting the
-;; above list and M-x profile-functions) use M-x profile-a-function.
-
-;;; Code:
-
-;;;
-;;; User modifiable VARIABLES
-;;;
-
-(defvar profile-functions-list nil "*List of functions to profile.")
-(defvar profile-buffer "*profile*"
- "Name of profile buffer.")
-(defvar profile-distinct nil
- "If non-nil, each time slice gets credited to at most one function.
-\(Namely, the most recent one in the call stack.) If nil, then the
-time reported for a function includes the entire time from beginning
-to end, even if it called some other function that was also profiled.")
-
-;;;
-;;; V A R I A B L E S
-;;;
-
-(defvar profile-time-list nil
- "List of cumulative calls and time for each profiled function.
-Each element looks like (FUN NCALLS SEC . USEC).")
-(defvar profile-init-list nil
- "List of entry time for each function.
-Both how many times invoked and real time of start.
-Each element looks like (FUN DEPTH HISEC LOSEC USEC), where DEPTH is
-the current recursion depth, and HISEC, LOSEC, and USEC represent the
-starting time of the call (or of the outermost recursion).")
-(defvar profile-max-fun-name 0
- "Max length of name of any function profiled.")
-(defvar profile-call-stack nil
- "A list of the profiled functions currently executing.
-Used only when profile-distinct is non-nil.")
-(defvar profile-last-time nil
- "The start time of the current time slice.
-Used only when profile-distinct is non-nil.")
-
-(defconst profile-million 1000000)
-
-;;;
-;;; F U N C T I O N S
-;;;
-
-(defun profile-functions (&optional flist)
- "Profile all the functions listed in `profile-functions-list'.
-With argument FLIST, use the list FLIST instead."
- (interactive "P")
- (mapcar 'profile-a-function (or flist profile-functions-list)))
-
-(defun profile-print (entry)
- "Print one ENTRY (from `profile-time-list')."
- (let* ((calls (car (cdr entry)))
- (timec (cdr (cdr entry)))
- (avgtime (and (not (zerop calls))
- (/ (+ (car timec)
- (/ (cdr timec) (float profile-million)))
- calls))))
- (insert (format (concat "%-"
- (int-to-string profile-max-fun-name)
- "s %7d %10d.%06d")
- (car entry) calls (car timec) (cdr timec))
- (if (null avgtime)
- "\n"
- (format " %18.6f\n" avgtime)))))
-
-(defun profile-results ()
- "Display profiling results in the buffer `*profile*'.
-\(The buffer name comes from `profile-buffer'.)"
- (interactive)
- (switch-to-buffer profile-buffer)
- (erase-buffer)
- (insert "Function" (make-string (- profile-max-fun-name 6) ? ))
- (insert " Calls Total time (sec) Avg time per call\n")
- (insert (make-string profile-max-fun-name ?=) " ")
- (insert "====== ================ =================\n")
- (mapcar 'profile-print profile-time-list))
-
-(defun profile-add-time (dest now prev)
- "Add to DEST the difference between timestamps NOW and PREV.
-DEST is a pair (SEC . USEC) which is modified in place.
-NOW and PREV are triples as returned by `current-time'."
- (let ((sec (+ (car dest)
- (* 65536 (- (car now) (car prev)))
- (- (cadr now) (cadr prev))))
- (usec (+ (cdr dest)
- (- (car (cddr now)) (car (cddr prev))))))
- (if (< usec 0)
- (setq sec (1- sec)
- usec (+ usec profile-million))
- (if (>= usec profile-million)
- (setq sec (1+ sec)
- usec (- usec profile-million))))
- (setcar dest sec)
- (setcdr dest usec)))
-
-(defun profile-function-prolog (fun)
- "Mark the beginning of a call to function FUN."
- (if profile-distinct
- (let ((profile-time (current-time)))
- (if profile-call-stack
- (profile-add-time (cdr (cdr (assq (car profile-call-stack)
- profile-time-list)))
- profile-time profile-last-time))
- (setq profile-call-stack (cons fun profile-call-stack)
- profile-last-time profile-time))
- (let ((profile-time (current-time))
- (init-time (cdr (assq fun profile-init-list))))
- (if (null init-time) (error "Function %s missing from list" fun))
- (if (not (zerop (car init-time)));; is it a recursive call ?
- (setcar init-time (1+ (car init-time)))
- (setcar init-time 1) ; mark first entry
- (setcdr init-time profile-time)))))
-
-(defun profile-function-epilog (fun)
- "Mark the end of a call to function FUN."
- (if profile-distinct
- (let ((profile-time (current-time))
- (accum (cdr (assq fun profile-time-list))))
- (setcar accum (1+ (car accum)))
- (profile-add-time (cdr accum) profile-time profile-last-time)
- (setq profile-call-stack (cdr profile-call-stack)
- profile-last-time profile-time))
- (let ((profile-time (current-time))
- (init-time (cdr (assq fun profile-init-list)))
- (accum (cdr (assq fun profile-time-list))))
- (if (or (null init-time)
- (null accum))
- (error "Function %s missing from list" fun))
- (setcar init-time (1- (car init-time))) ; pop one level in recursion
- ;; Update only if we've finished the outermost recursive call
- (when (zerop (car init-time))
- (setcar accum (1+ (car accum)))
- (profile-add-time (cdr accum) profile-time (cdr init-time))))))
-
-(defun profile-convert-byte-code (function)
- (let ((defn (symbol-function function)))
- (if (byte-code-function-p defn)
- ;; It is a compiled code object.
- (let* ((contents (append defn nil))
- (body
- (list (list 'byte-code (nth 1 contents)
- (nth 2 contents) (nth 3 contents)))))
- (if (nthcdr 5 contents)
- (setq body (cons (list 'interactive (nth 5 contents)) body)))
- (if (nth 4 contents)
- ;; Use `documentation' here, to get the actual string,
- ;; in case the compiled function has a reference
- ;; to the .elc file.
- (setq body (cons (documentation function) body)))
- (fset function (cons 'lambda (cons (car contents) body)))))))
-
-(defun profile-a-function (fun)
- "Profile the function FUN."
- (interactive "aFunction to profile: ")
- (let ((def (symbol-function fun)))
- (when (eq (car-safe def) 'autoload)
- (load (car (cdr def)))
- (setq def (symbol-function fun)))
- (fetch-bytecode def))
- (profile-convert-byte-code fun)
- (let ((def (symbol-function fun)) (funlen (length (symbol-name fun))))
- (or (eq (car def) 'lambda)
- (error "To profile: %s must be a user-defined function" fun))
- (setq profile-time-list ; add a new entry
- (cons (cons fun (cons 0 (cons 0 0))) profile-time-list))
- (setq profile-init-list ; add a new entry
- (cons (cons fun (cons 0 nil)) profile-init-list))
- (if (< profile-max-fun-name funlen) (setq profile-max-fun-name funlen))
- (fset fun (profile-fix-fun fun def))))
-
-(defun profile-fix-fun (fun def)
- "Take function FUN and return it fixed for profiling.
-DEF is (symbol-function FUN)."
- (if (< (length def) 3)
- def ; nothing to change
- (let ((prefix (list (car def) (car (cdr def))))
- (suffix (cdr (cdr def))))
- ;; Skip the doc string, if there is a string
- ;; which serves only as a doc string,
- ;; and put it in PREFIX.
- (if (and (stringp (car suffix)) (cdr suffix))
- (setq prefix (nconc prefix (list (car suffix)))
- suffix (cdr suffix)))
- ;; Check for an interactive spec.
- ;; If found, put it into PREFIX and skip it.
- (if (and (listp (car suffix))
- (eq (car (car suffix)) 'interactive))
- (setq prefix (nconc prefix (list (car suffix)))
- suffix (cdr suffix)))
- (if (eq (car-safe (car suffix)) 'profile-function-prolog)
- def ; already profiled
- ;; Prepare new function definition.
- ;; If you change this structure, also change profile-restore-fun.
- (nconc prefix
- (list (list 'profile-function-prolog
- (list 'quote fun))
- (list 'unwind-protect
- (cons 'progn suffix)
- (list 'profile-function-epilog
- (list 'quote fun)))))))))
-
-(defun profile-restore-fun (fun)
- "Restore profiled function FUN to its original state."
- (let ((def (symbol-function fun)) body index)
- ;; move index beyond header
- (setq index (cdr-safe def))
- (if (stringp (car (cdr index)))
- (setq index (cdr index)))
- (if (eq (car-safe (car (cdr index))) 'interactive)
- (setq index (cdr index)))
- (if (eq (car-safe (car (cdr index))) 'profile-function-prolog)
- (setcdr index (cdr (car (cdr (car (cdr (cdr index))))))))))
-
-(defun profile-finish ()
- "Stop profiling functions. Clear all the settings."
- (interactive)
- (while profile-time-list
- (profile-restore-fun (car (car profile-time-list)))
- (setq profile-time-list (cdr profile-time-list)))
- (setq profile-max-fun-name 0)
- (setq profile-init-list nil))
-
-(provide 'profile)
-
-;; arch-tag: 816f97e8-efff-4da2-9a95-7bc392f58b19
-;;; profile.el ends here
diff --git a/lisp/obsolete/rsz-mini.el b/lisp/obsolete/rsz-mini.el
deleted file mode 100644
index d5c8e2e476..0000000000
--- a/lisp/obsolete/rsz-mini.el
+++ /dev/null
@@ -1,84 +0,0 @@
-;;; rsz-mini.el --- dynamically resize minibuffer to display entire contents
-
-;; Copyright (C) 1990, 1993, 1994, 1995, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Author: Noah Friedman <friedman@splode.com>
-;; Roland McGrath <roland@gnu.org>
-;; Maintainer: Noah Friedman <friedman@splode.com>
-;; Keywords: minibuffer, window, frame, display
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;; This package is obsolete. Emacs now resizes mini-windows automatically.
-
-;;; Code:
-
-
-(defgroup resize-minibuffer nil
- "This customization group is obsolete."
- :group 'frames)
-
-;;;###autoload
-(defcustom resize-minibuffer-mode nil
- "*This variable is obsolete."
- :type 'boolean
- :group 'resize-minibuffer
- :require 'rsz-mini)
-
-;;;###autoload
-(defcustom resize-minibuffer-window-max-height nil
- "*This variable is obsolete."
- :type '(choice (const nil) integer)
- :group 'resize-minibuffer)
-
-;;;###autoload
-(defcustom resize-minibuffer-window-exactly t
- "*This variable is obsolete."
- :type 'boolean
- :group 'resize-minibuffer)
-
-;;;###autoload
-(defcustom resize-minibuffer-frame nil
- "*This variable is obsolete."
- :type 'boolean
- :group 'resize-minibuffer)
-
-;;;###autoload
-(defcustom resize-minibuffer-frame-max-height nil
- "*This variable is obsolete."
- :group 'resize-minibuffer)
-
-;;;###autoload
-(defcustom resize-minibuffer-frame-exactly t
- "*This variable is obsolete."
- :type 'boolean
- :group 'resize-minibuffer)
-
-
-;;;###autoload
-(defun resize-minibuffer-mode (&optional prefix)
- "This function is obsolete."
- (interactive "P"))
-
-(provide 'rsz-mini)
-
-;; arch-tag: 3cb85d51-ab33-4e46-8362-dd87a5d06c99
-;;; rsz-mini.el ends here
diff --git a/lisp/obsolete/uncompress.el b/lisp/obsolete/uncompress.el
deleted file mode 100644
index 2304ee5088..0000000000
--- a/lisp/obsolete/uncompress.el
+++ /dev/null
@@ -1,115 +0,0 @@
-;;; uncompress.el --- auto-decompression hook for visiting .Z files
-
-;; Copyright (C) 1992, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: files
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;; This package can be used to arrange for automatic uncompress of
-;; compressed files when they are visited.
-;; All that's necessary is to load it. This can conveniently be done from
-;; your .emacs file.
-
-;; M-x auto-compression-mode is a more modern replacement for this package.
-
-;;; Code:
-
-;; When we are about to make a backup file,
-;; uncompress the file we visited
-;; so that making the backup can work properly.
-;; This is used as a write-file-hook.
-
-(defvar uncompress-program "gunzip"
- "Program to use for uncompression.")
-
-(defun uncompress-backup-file ()
- (and buffer-file-name make-backup-files (not buffer-backed-up)
- (not (file-exists-p buffer-file-name))
- (call-process uncompress-program nil nil nil buffer-file-name))
- nil)
-
-(or (assoc "\\.Z$" auto-mode-alist)
- (setq auto-mode-alist
- (cons '("\\.Z$" . uncompress-while-visiting) auto-mode-alist)))
-(or (assoc "\\.gz$" auto-mode-alist)
- (setq auto-mode-alist
- (cons '("\\.gz$" . uncompress-while-visiting) auto-mode-alist)))
-(or (assoc "\\.tgz$" auto-mode-alist)
- (setq auto-mode-alist
- (cons '("\\.tgz$" . uncompress-while-visiting) auto-mode-alist)))
-
-(defun uncompress-while-visiting ()
- "Temporary \"major mode\" used for .Z and .gz files, to uncompress them.
-It then selects a major mode from the uncompressed file name and contents."
- (if (and (not (null buffer-file-name))
- (string-match "\\.Z$" buffer-file-name))
- (set-visited-file-name
- (substring buffer-file-name 0 (match-beginning 0)))
- (if (and (not (null buffer-file-name))
- (string-match "\\.gz$" buffer-file-name))
- (set-visited-file-name
- (substring buffer-file-name 0 (match-beginning 0)))
- (if (and (not (null buffer-file-name))
- (string-match "\\.tgz$" buffer-file-name))
- (set-visited-file-name
- (concat (substring buffer-file-name 0 (match-beginning 0)) ".tar")))))
- (message "Uncompressing...")
- (let ((buffer-read-only nil)
- (coding-system-for-write 'no-conversion)
- (coding-system-for-read
- (car (find-operation-coding-system
- 'insert-file-contents
- buffer-file-name t))))
- (shell-command-on-region (point-min) (point-max) uncompress-program t))
- (goto-char (point-min))
- (message "Uncompressing...done")
- (set-buffer-modified-p nil)
- (add-hook 'write-file-functions 'uncompress-backup-file nil t)
- (normal-mode))
-
-(add-hook 'find-file-not-found-functions 'find-compressed-version)
-
-(defun find-compressed-version ()
- "Hook to read and uncompress the compressed version of a file."
- ;; Just pretend we had visited the compressed file,
- ;; and uncompress-while-visiting will do the rest.
- (let (name)
- (if (file-exists-p (setq name (concat buffer-file-name ".Z")))
- (setq buffer-file-name name)
- (if (file-exists-p (setq name (concat buffer-file-name ".gz")))
- (setq buffer-file-name name)))
- (if (eq name buffer-file-name)
- (progn
- (insert-file-contents buffer-file-name t)
- (goto-char (point-min))
- ;; No need for this, because error won't be set to t
- ;; if this function returns t.
- ;; (setq error nil)
- t))))
-
-(message "The uncompress package is obsolete; use M-x auto-compression-mode")
-
-(provide 'uncompress)
-
-;; arch-tag: 626658d4-fcce-499a-990d-d165f2ed7da3
-;;; uncompress.el ends here