diff options
Diffstat (limited to 'lisp/obsolete')
| -rw-r--r-- | lisp/obsolete/auto-show.el | 54 | ||||
| -rw-r--r-- | lisp/obsolete/bg-mouse.el | 308 | ||||
| -rw-r--r-- | lisp/obsolete/float.el | 460 | ||||
| -rw-r--r-- | lisp/obsolete/hilit19.el | 1527 | ||||
| -rw-r--r-- | lisp/obsolete/hscroll.el | 106 | ||||
| -rw-r--r-- | lisp/obsolete/lselect.el | 247 | ||||
| -rw-r--r-- | lisp/obsolete/mlsupport.el | 430 | ||||
| -rw-r--r-- | lisp/obsolete/ooutline.el | 587 | ||||
| -rw-r--r-- | lisp/obsolete/profile.el | 294 | ||||
| -rw-r--r-- | lisp/obsolete/rsz-mini.el | 84 | ||||
| -rw-r--r-- | lisp/obsolete/uncompress.el | 115 |
11 files changed, 0 insertions, 4212 deletions
diff --git a/lisp/obsolete/auto-show.el b/lisp/obsolete/auto-show.el deleted file mode 100644 index 2fc3d25feef..00000000000 --- a/lisp/obsolete/auto-show.el +++ /dev/null @@ -1,54 +0,0 @@ -;;; 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 153dd98e3ba..00000000000 --- 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 e86b8633f45..00000000000 --- 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 e989f4a7af1..00000000000 --- 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 98300503f86..00000000000 --- 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 bf689eb5ec7..00000000000 --- 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 04f6b8fa9e2..00000000000 --- 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 4ce90d9eb58..00000000000 --- 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 87b976de6b1..00000000000 --- 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 d5c8e2e476a..00000000000 --- 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 2304ee50889..00000000000 --- 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 |