mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-15 10:30:25 -08:00
* obsolete/bg-mouse.el, obsolete/float.el, obsolete/hilit19.el,
* obsolete/lselect.el, obsolete/mlsupport.el, obsolete/ooutline.el, * obsolete/profile.el, obsolete/rsz-mini.el, obsolete/uncompress.el, * obsolete/auto-show.el, obsolete/hscroll.el: Remove packages that were obsolete in Emacs-20, or that were obsolete in Emacs-21 and do not contain any more code.
This commit is contained in:
Stefan Monnier
parent
8d27bcdf2e
commit
a87c1daf65
12 changed files with 7 additions and 4212 deletions
|
|
@ -1,5 +1,12 @@
|
|||
2008-06-03 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* obsolete/bg-mouse.el, obsolete/float.el, obsolete/hilit19.el,
|
||||
* obsolete/lselect.el, obsolete/mlsupport.el, obsolete/ooutline.el,
|
||||
* obsolete/profile.el, obsolete/rsz-mini.el, obsolete/uncompress.el,
|
||||
* obsolete/auto-show.el, obsolete/hscroll.el:
|
||||
Remove packages that were obsolete in Emacs-20, or that were obsolete
|
||||
in Emacs-21 and do not contain any more code.
|
||||
|
||||
* vc-dispatcher.el (vc-dir-menu-map-filter): Don't fail if
|
||||
vc-client-mode is not set.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue