procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Moved from lisp/.

Browse source
This commit is contained in:
Juanma Barranquero 2003-05-30 23:31:15 +00:00
parent 9d7aa1b1b6
commit 5e046f6d57
9 changed files with 2713 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

172
lisp/emacs-lisp/byte-run.el Normal file
View file

@ -0,0 +1,172 @@
;;; byte-run.el --- byte-compiler support for inlining
;; Copyright (C) 1992 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; Maintainer: FSF
;; Keywords: internal
;; 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; interface to selectively inlining functions.
;; This only happens when source-code optimization is turned on.
;;; Code:
;; Redefined in byte-optimize.el.
;; This is not documented--it's not clear that we should promote it.
(fset 'inline 'progn)
(put 'inline 'lisp-indent-hook 0)
;;; Interface to inline functions.
;; (defmacro proclaim-inline (&rest fns)
;; "Cause the named functions to be open-coded when called from compiled code.
;; They will only be compiled open-coded when byte-compile-optimize is true."
;; (cons 'eval-and-compile
;; (mapcar '(lambda (x)
;; (or (memq (get x 'byte-optimizer)
;; '(nil byte-compile-inline-expand))
;; (error
;; "%s already has a byte-optimizer, can't make it inline"
;; x))
;; (list 'put (list 'quote x)
;; ''byte-optimizer ''byte-compile-inline-expand))
;; fns)))
;; (defmacro proclaim-notinline (&rest fns)
;; "Cause the named functions to no longer be open-coded."
;; (cons 'eval-and-compile
;; (mapcar '(lambda (x)
;; (if (eq (get x 'byte-optimizer) 'byte-compile-inline-expand)
;; (put x 'byte-optimizer nil))
;; (list 'if (list 'eq (list 'get (list 'quote x) ''byte-optimizer)
;; ''byte-compile-inline-expand)
;; (list 'put x ''byte-optimizer nil)))
;; fns)))
;; This has a special byte-hunk-handler in bytecomp.el.
(defmacro defsubst (name arglist &rest body)
"Define an inline function. The syntax is just like that of `defun'."
(or (memq (get name 'byte-optimizer)
'(nil byte-compile-inline-expand))
(error "`%s' is a primitive" name))
(list 'prog1
(cons 'defun (cons name (cons arglist body)))
(list 'eval-and-compile
(list 'put (list 'quote name)
''byte-optimizer ''byte-compile-inline-expand))))
(defun make-obsolete (fn new &optional when)
"Make the byte-compiler warn that FUNCTION is obsolete.
The warning will say that NEW should be used instead.
If NEW is a string, that is the `use instead' message.
If provided, WHEN should be a string indicating when the function
was first made obsolete, for example a date or a release number."
(interactive "aMake function obsolete: \nxObsoletion replacement: ")
(let ((handler (get fn 'byte-compile)))
(if (eq 'byte-compile-obsolete handler)
(setq handler (nth 1 (get fn 'byte-obsolete-info)))
(put fn 'byte-compile 'byte-compile-obsolete))
(put fn 'byte-obsolete-info (list new handler when)))
fn)
(defun make-obsolete-variable (var new &optional when)
"Make the byte-compiler warn that VARIABLE is obsolete,
and NEW should be used instead. If NEW is a string, then that is the
`use instead' message.
If provided, WHEN should be a string indicating when the variable
was first made obsolete, for example a date or a release number."
(interactive
(list
(let ((str (completing-read "Make variable obsolete: " obarray 'boundp t)))
(if (equal str "") (error ""))
(intern str))
(car (read-from-string (read-string "Obsoletion replacement: ")))))
(put var 'byte-obsolete-variable (cons new when))
var)
(put 'dont-compile 'lisp-indent-hook 0)
(defmacro dont-compile (&rest body)
"Like `progn', but the body always runs interpreted (not compiled).
If you think you need this, you're probably making a mistake somewhere."
(list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
;;; interface to evaluating things at compile time and/or load time
;;; these macro must come after any uses of them in this file, as their
;;; definition in the file overrides the magic definitions on the
;;; byte-compile-macro-environment.
(put 'eval-when-compile 'lisp-indent-hook 0)
(defmacro eval-when-compile (&rest body)
"Like `progn', but evaluates the body at compile time.
The result of the body appears to the compiler as a quoted constant."
;; Not necessary because we have it in b-c-initial-macro-environment
;; (list 'quote (eval (cons 'progn body)))
(cons 'progn body))
(put 'eval-and-compile 'lisp-indent-hook 0)
(defmacro eval-and-compile (&rest body)
"Like `progn', but evaluates the body at compile time and at load time."
;; Remember, it's magic.
(cons 'progn body))
(defun with-no-warnings (&optional first &rest body)
"Like `progn', but prevents compiler warnings in the body."
;; The implementation for the interpreter is basically trivial.
(if body (car (last body))
first))
;;; I nuked this because it's not a good idea for users to think of using it.
;;; These options are a matter of installation preference, and have nothing to
;;; with particular source files; it's a mistake to suggest to users
;;; they should associate these with particular source files.
;;; There is hardly any reason to change these parameters, anyway.
;;; --rms.
;; (put 'byte-compiler-options 'lisp-indent-hook 0)
;; (defmacro byte-compiler-options (&rest args)
;; "Set some compilation-parameters for this file. This will affect only the
;; file in which it appears; this does nothing when evaluated, and when loaded
;; from a .el file.
;;
;; Each argument to this macro must be a list of a key and a value.
;;
;; Keys: Values: Corresponding variable:
;;
;; verbose t, nil byte-compile-verbose
;; optimize t, nil, source, byte byte-compile-optimize
;; warnings list of warnings byte-compile-warnings
;; Legal elements: (callargs redefine free-vars unresolved)
;; file-format emacs18, emacs19 byte-compile-compatibility
;;
;; For example, this might appear at the top of a source file:
;;
;; (byte-compiler-options
;; (optimize t)
;; (warnings (- free-vars)) ; Don't warn about free variables
;; (file-format emacs19))"
;; nil)
;;; byte-run.el ends here

436
lisp/emacs-lisp/derived.el Normal file
View file

@ -0,0 +1,436 @@
;;; derived.el --- allow inheritance of major modes
;;; (formerly mode-clone.el)
;; Copyright (C) 1993, 1994, 1999, 2003 Free Software Foundation, Inc.
;; Author: David Megginson (dmeggins@aix1.uottawa.ca)
;; 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; GNU Emacs is already, in a sense, object oriented -- each object
;; (buffer) belongs to a class (major mode), and that class defines
;; the relationship between messages (input events) and methods
;; (commands) by means of a keymap.
;;
;; The only thing missing is a good scheme of inheritance. It is
;; possible to simulate a single level of inheritance with generous
;; use of hooks and a bit of work -- sgml-mode, for example, also runs
;; the hooks for text-mode, and keymaps can inherit from other keymaps
;; -- but generally, each major mode ends up reinventing the wheel.
;; Ideally, someone should redesign all of Emacs's major modes to
;; follow a more conventional object-oriented system: when defining a
;; new major mode, the user should need only to name the existing mode
;; it is most similar to, then list the (few) differences.
;;
;; In the mean time, this package offers most of the advantages of
;; full inheritance with the existing major modes. The macro
;; `define-derived-mode' allows the user to make a variant of an existing
;; major mode, with its own keymap. The new mode will inherit the key
;; bindings of its parent, and will, in fact, run its parent first
;; every time it is called. For example, the commands
;;
;; (define-derived-mode hypertext-mode text-mode "Hypertext"
;; "Major mode for hypertext.\n\n\\{hypertext-mode-map}"
;; (setq case-fold-search nil))
;;
;; (define-key hypertext-mode-map [down-mouse-3] 'do-hyper-link)
;;
;; will create a function `hypertext-mode' with its own (sparse)
;; keymap `hypertext-mode-map.' The command M-x hypertext-mode will
;; perform the following actions:
;;
;; - run the command (text-mode) to get its default setup
;; - replace the current keymap with 'hypertext-mode-map,' which will
;; inherit from 'text-mode-map'.
;; - replace the current syntax table with
;; 'hypertext-mode-syntax-table', which will borrow its defaults
;; from the current text-mode-syntax-table.
;; - replace the current abbrev table with
;; 'hypertext-mode-abbrev-table', which will borrow its defaults
;; from the current text-mode-abbrev table
;; - change the mode line to read "Hypertext"
;; - assign the value 'hypertext-mode' to the 'major-mode' variable
;; - run the body of commands provided in the macro -- in this case,
;; set the local variable `case-fold-search' to nil.
;;
;; The advantages of this system are threefold. First, text mode is
;; untouched -- if you had added the new keystroke to `text-mode-map,'
;; possibly using hooks, you would have added it to all text buffers
;; -- here, it appears only in hypertext buffers, where it makes
;; sense. Second, it is possible to build even further, and make
;; a derived mode from a derived mode. The commands
;;
;; (define-derived-mode html-mode hypertext-mode "HTML")
;; [various key definitions]
;;
;; will add a new major mode for HTML with very little fuss.
;;
;; Note also the function `derived-mode-p' which can tell if the current
;; mode derives from another. In a hypertext-mode, buffer, for example,
;; (derived-mode-p 'text-mode) would return non-nil. This should always
;; be used in place of (eq major-mode 'text-mode).
;;; Code:
(eval-when-compile (require 'cl))
;;; PRIVATE: defsubst must be defined before they are first used
(defsubst derived-mode-hook-name (mode)
"Construct the mode hook name based on mode name MODE."
(intern (concat (symbol-name mode) "-hook")))
(defsubst derived-mode-map-name (mode)
"Construct a map name based on a MODE name."
(intern (concat (symbol-name mode) "-map")))
(defsubst derived-mode-syntax-table-name (mode)
"Construct a syntax-table name based on a MODE name."
(intern (concat (symbol-name mode) "-syntax-table")))
(defsubst derived-mode-abbrev-table-name (mode)
"Construct an abbrev-table name based on a MODE name."
(intern (concat (symbol-name mode) "-abbrev-table")))
;; PUBLIC: define a new major mode which inherits from an existing one.
;;;###autoload
(defmacro define-derived-mode (child parent name &optional docstring &rest body)
"Create a new mode as a variant of an existing mode.
The arguments to this command are as follow:
CHILD: the name of the command for the derived mode.
PARENT: the name of the command for the parent mode (e.g. `text-mode')
or nil if there is no parent.
NAME: a string which will appear in the status line (e.g. \"Hypertext\")
DOCSTRING: an optional documentation string--if you do not supply one,
the function will attempt to invent something useful.
BODY: forms to execute just before running the
hooks for the new mode. Do not use `interactive' here.
BODY can start with a bunch of keyword arguments. The following keyword
arguments are currently understood:
:group GROUP
Declare the customization group that corresponds to this mode.
:syntax-table TABLE
Use TABLE instead of the default.
A nil value means to simply use the same syntax-table as the parent.
:abbrev-table TABLE
Use TABLE instead of the default.
A nil value means to simply use the same abbrev-table as the parent.
Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode:
(define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\")
You could then make new key bindings for `LaTeX-thesis-mode-map'
without changing regular LaTeX mode. In this example, BODY is empty,
and DOCSTRING is generated by default.
On a more complicated level, the following command uses `sgml-mode' as
the parent, and then sets the variable `case-fold-search' to nil:
(define-derived-mode article-mode sgml-mode \"Article\"
\"Major mode for editing technical articles.\"
(setq case-fold-search nil))
Note that if the documentation string had been left out, it would have
been generated automatically, with a reference to the keymap."
(declare (debug (&define name symbolp sexp [&optional stringp]
[&rest keywordp sexp] def-body)))
(when (and docstring (not (stringp docstring)))
;; Some trickiness, since what appears to be the docstring may really be
;; the first element of the body.
(push docstring body)
(setq docstring nil))
(when (eq parent 'fundamental-mode) (setq parent nil))
(let ((map (derived-mode-map-name child))
(syntax (derived-mode-syntax-table-name child))
(abbrev (derived-mode-abbrev-table-name child))
(declare-abbrev t)
(declare-syntax t)
(hook (derived-mode-hook-name child))
(group nil))
;; Process the keyword args.
(while (keywordp (car body))
(case (pop body)
(:group (setq group (pop body)))
(:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
(:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
(t (pop body))))
(setq docstring (derived-mode-make-docstring
parent child docstring syntax abbrev))
`(progn
(defvar ,map (make-sparse-keymap))
,(if declare-syntax
`(defvar ,syntax (make-syntax-table)))
,(if declare-abbrev
`(defvar ,abbrev
(progn (define-abbrev-table ',abbrev nil) ,abbrev)))
(put ',child 'derived-mode-parent ',parent)
,(if group `(put ',child 'custom-mode-group ,group))
(defun ,child ()
,docstring
(interactive)
; Run the parent.
(delay-mode-hooks
(,(or parent 'kill-all-local-variables))
; Identify the child mode.
(setq major-mode (quote ,child))
(setq mode-name ,name)
; Identify special modes.
,(when parent
`(progn
(if (get (quote ,parent) 'mode-class)
(put (quote ,child) 'mode-class
(get (quote ,parent) 'mode-class)))
; Set up maps and tables.
(unless (keymap-parent ,map)
(set-keymap-parent ,map (current-local-map)))
,(when declare-syntax
`(let ((parent (char-table-parent ,syntax)))
(unless (and parent
(not (eq parent (standard-syntax-table))))
(set-char-table-parent ,syntax (syntax-table)))))))
(use-local-map ,map)
,(when syntax `(set-syntax-table ,syntax))
,(when abbrev `(setq local-abbrev-table ,abbrev))
; Splice in the body (if any).
,@body
)
;; Run the hooks, if any.
;; Make the generated code work in older Emacs versions
;; that do not yet have run-mode-hooks.
(if (fboundp 'run-mode-hooks)
(run-mode-hooks ',hook)
(run-hooks ',hook))))))
;; PUBLIC: find the ultimate class of a derived mode.
(defun derived-mode-class (mode)
"Find the class of a major MODE.
A mode's class is the first ancestor which is NOT a derived mode.
Use the `derived-mode-parent' property of the symbol to trace backwards.
Since major-modes might all derive from `fundamental-mode', this function
is not very useful."
(while (get mode 'derived-mode-parent)
(setq mode (get mode 'derived-mode-parent)))
mode)
(make-obsolete 'derived-mode-class 'derived-mode-p "21.4")
;;; PRIVATE
(defun derived-mode-make-docstring (parent child &optional
docstring syntax abbrev)
"Construct a docstring for a new mode if none is provided."
(let ((map (derived-mode-map-name child))
(hook (derived-mode-hook-name child)))
(unless (stringp docstring)
;; Use a default docstring.
(setq docstring
(if (null parent)
(format "Major-mode.
Uses keymap `%s', abbrev table `%s' and syntax-table `%s'." map abbrev syntax)
(format "Major mode derived from `%s' by `define-derived-mode'.
It inherits all of the parent's attributes, but has its own keymap,
abbrev table and syntax table:
`%s', `%s' and `%s'
which more-or-less shadow %s's corresponding tables."
parent map abbrev syntax parent))))
(unless (string-match (regexp-quote (symbol-name hook)) docstring)
;; Make sure the docstring mentions the mode's hook.
(setq docstring
(concat docstring
(if (null parent)
"\n\nThis mode "
(concat
"\n\nIn addition to any hooks its parent mode "
(if (string-match (regexp-quote (format "`%s'" parent))
docstring) nil
(format "`%s' " parent))
"might have run,\nthis mode "))
(format "runs the hook `%s'" hook)
", as the final step\nduring initialization.")))
(unless (string-match "\\\\[{[]" docstring)
;; And don't forget to put the mode's keymap.
(setq docstring (concat docstring "\n\n\\{" (symbol-name map) "}")))
docstring))
;;; OBSOLETE
;; The functions below are only provided for backward compatibility with
;; code byte-compiled with versions of derived.el prior to Emacs-21.
(defsubst derived-mode-setup-function-name (mode)
"Construct a setup-function name based on a MODE name."
(intern (concat (symbol-name mode) "-setup")))
;; Utility functions for defining a derived mode.
;;;###autoload
(defun derived-mode-init-mode-variables (mode)
"Initialise variables for a new MODE.
Right now, if they don't already exist, set up a blank keymap, an
empty syntax table, and an empty abbrev table -- these will be merged
the first time the mode is used."
(if (boundp (derived-mode-map-name mode))
t
(eval `(defvar ,(derived-mode-map-name mode)
(make-sparse-keymap)
,(format "Keymap for %s." mode)))
(put (derived-mode-map-name mode) 'derived-mode-unmerged t))
(if (boundp (derived-mode-syntax-table-name mode))
t
(eval `(defvar ,(derived-mode-syntax-table-name mode)
;; Make a syntax table which doesn't specify anything
;; for any char. Valid data will be merged in by
;; derived-mode-merge-syntax-tables.
(make-char-table 'syntax-table nil)
,(format "Syntax table for %s." mode)))
(put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t))
(if (boundp (derived-mode-abbrev-table-name mode))
t
(eval `(defvar ,(derived-mode-abbrev-table-name mode)
(progn
(define-abbrev-table (derived-mode-abbrev-table-name mode) nil)
(make-abbrev-table))
,(format "Abbrev table for %s." mode)))))
;; Utility functions for running a derived mode.
(defun derived-mode-set-keymap (mode)
"Set the keymap of the new MODE, maybe merging with the parent."
(let* ((map-name (derived-mode-map-name mode))
(new-map (eval map-name))
(old-map (current-local-map)))
(and old-map
(get map-name 'derived-mode-unmerged)
(derived-mode-merge-keymaps old-map new-map))
(put map-name 'derived-mode-unmerged nil)
(use-local-map new-map)))
(defun derived-mode-set-syntax-table (mode)
"Set the syntax table of the new MODE, maybe merging with the parent."
(let* ((table-name (derived-mode-syntax-table-name mode))
(old-table (syntax-table))
(new-table (eval table-name)))
(if (get table-name 'derived-mode-unmerged)
(derived-mode-merge-syntax-tables old-table new-table))
(put table-name 'derived-mode-unmerged nil)
(set-syntax-table new-table)))
(defun derived-mode-set-abbrev-table (mode)
"Set the abbrev table for MODE if it exists.
Always merge its parent into it, since the merge is non-destructive."
(let* ((table-name (derived-mode-abbrev-table-name mode))
(old-table local-abbrev-table)
(new-table (eval table-name)))
(derived-mode-merge-abbrev-tables old-table new-table)
(setq local-abbrev-table new-table)))
;;;(defun derived-mode-run-setup-function (mode)
;;; "Run the setup function if it exists."
;;; (let ((fname (derived-mode-setup-function-name mode)))
;;; (if (fboundp fname)
;;; (funcall fname))))
(defun derived-mode-run-hooks (mode)
"Run the mode hook for MODE."
(let ((hooks-name (derived-mode-hook-name mode)))
(if (boundp hooks-name)
(run-hooks hooks-name))))
;; Functions to merge maps and tables.
(defun derived-mode-merge-keymaps (old new)
"Merge an OLD keymap into a NEW one.
The old keymap is set to be the last cdr of the new one, so that there will
be automatic inheritance."
;; ?? Can this just use `set-keymap-parent'?
(let ((tail new))
;; Scan the NEW map for prefix keys.
(while (consp tail)
(and (consp (car tail))
(let* ((key (vector (car (car tail))))
(subnew (lookup-key new key))
(subold (lookup-key old key)))
;; If KEY is a prefix key in both OLD and NEW, merge them.
(and (keymapp subnew) (keymapp subold)
(derived-mode-merge-keymaps subold subnew))))
(and (vectorp (car tail))
;; Search a vector of ASCII char bindings for prefix keys.
(let ((i (1- (length (car tail)))))
(while (>= i 0)
(let* ((key (vector i))
(subnew (lookup-key new key))
(subold (lookup-key old key)))
;; If KEY is a prefix key in both OLD and NEW, merge them.
(and (keymapp subnew) (keymapp subold)
(derived-mode-merge-keymaps subold subnew)))
(setq i (1- i)))))
(setq tail (cdr tail))))
(setcdr (nthcdr (1- (length new)) new) old))
(defun derived-mode-merge-syntax-tables (old new)
"Merge an OLD syntax table into a NEW one.
Where the new table already has an entry, nothing is copied from the old one."
(set-char-table-parent new old))
;; Merge an old abbrev table into a new one.
;; This function requires internal knowledge of how abbrev tables work,
;; presuming that they are obarrays with the abbrev as the symbol, the expansion
;; as the value of the symbol, and the hook as the function definition.
(defun derived-mode-merge-abbrev-tables (old new)
(if old
(mapatoms
(lambda (symbol)
(or (intern-soft (symbol-name symbol) new)
(define-abbrev new (symbol-name symbol)
(symbol-value symbol) (symbol-function symbol))))
old)))
(provide 'derived)
;;; derived.el ends here

63
lisp/emacs-lisp/float-sup.el Normal file
View file

@ -0,0 +1,63 @@
;;; float-sup.el --- define some constants useful for floating point numbers.
;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
;; Provide a meaningful error message if we are running on
;; bare (non-float) emacs.
(if (fboundp 'atan)
nil
(error "Floating point was disabled at compile time"))
;; provide an easy hook to tell if we are running with floats or not.
;; define pi and e via math-lib calls. (much less prone to killer typos.)
(defconst pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
;; It's too inconvenient to make `e' a constant because it's used as
;; a temporary variable all the time.
(defvar e (exp 1) "The value of e (2.7182818...).")
;; Careful when editing this file ... typos here will be hard to spot.
;; (defconst pi 3.14159265358979323846264338327
;; "The value of Pi (3.14159265358979323846264338327...)")
(defconst degrees-to-radians (/ pi 180.0)
"Degrees to radian conversion constant.")
(defconst radians-to-degrees (/ 180.0 pi)
"Radian to degree conversion constant.")
;; these expand to a single multiply by a float when byte compiled
(defmacro degrees-to-radians (x)
"Convert ARG from degrees to radians."
(list '* (/ pi 180.0) x))
(defmacro radians-to-degrees (x)
"Convert ARG from radians to degrees."
(list '* (/ 180.0 pi) x))
(provide 'lisp-float-type)
;;; float-sup.el ends here

264
lisp/emacs-lisp/map-ynp.el Normal file
View file

@ -0,0 +1,264 @@
;;; map-ynp.el --- general-purpose boolean question-asker
;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Maintainer: FSF
;; Keywords: lisp, 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; map-y-or-n-p is a general-purpose question-asking function.
;; It asks a series of y/n questions (a la y-or-n-p), and decides to
;; apply an action to each element of a list based on the answer.
;; The nice thing is that you also get some other possible answers
;; to use, reminiscent of query-replace: ! to answer y to all remaining
;; questions; ESC or q to answer n to all remaining questions; . to answer
;; y once and then n for the remainder; and you can get help with C-h.
;;; Code:
(defun map-y-or-n-p (prompter actor list &optional help action-alist
no-cursor-in-echo-area)
"Ask a series of boolean questions.
Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST.
LIST is a list of objects, or a function of no arguments to return the next
object or nil.
If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\). If not
a string, PROMPTER is a function of one arg (an object from LIST), which
returns a string to be used as the prompt for that object. If the return
value is not a string, it may be nil to ignore the object or non-nil to act
on the object without asking the user.
ACTOR is a function of one arg (an object from LIST),
which gets called with each object that the user answers `yes' for.
If HELP is given, it is a list (OBJECT OBJECTS ACTION),
where OBJECT is a string giving the singular noun for an elt of LIST;
OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive
verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\).
At the prompts, the user may enter y, Y, or SPC to act on that object;
n, N, or DEL to skip that object; ! to act on all following objects;
ESC or q to exit (skip all following objects); . (period) to act on the
current object and then exit; or \\[help-command] to get help.
If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys
that will be accepted. KEY is a character; FUNCTION is a function of one
arg (an object from LIST); HELP is a string. When the user hits KEY,
FUNCTION is called. If it returns non-nil, the object is considered
\"acted upon\", and the next object from LIST is processed. If it returns
nil, the prompt is repeated for the same object.
Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set
`cursor-in-echo-area' while prompting.
This function uses `query-replace-map' to define the standard responses,
but not all of the responses which `query-replace' understands
are meaningful here.
Returns the number of actions taken."
(let* ((actions 0)
user-keys mouse-event map prompt char elt tail def
;; Non-nil means we should use mouse menus to ask.
use-menus
delayed-switch-frame
(next (if (or (and list (symbolp list))
(subrp list)
(byte-code-function-p list)
(and (consp list)
(eq (car list) 'lambda)))
(function (lambda ()
(setq elt (funcall list))))
(function (lambda ()
(if list
(progn
(setq elt (car list)
list (cdr list))
t)
nil))))))
(if (and (listp last-nonmenu-event)
use-dialog-box)
;; Make a list describing a dialog box.
(let ((object (if help (capitalize (nth 0 help))))
(objects (if help (capitalize (nth 1 help))))
(action (if help (capitalize (nth 2 help)))))
(setq map `(("Yes" . act) ("No" . skip) ("Quit" . exit)
(,(if help (concat action " " object " And Quit")
"Do it and Quit") . act-and-exit)
(,(if help (concat action " All " objects)
"Do All") . automatic)
,@(mapcar (lambda (elt)
(cons (capitalize (nth 2 elt))
(vector (nth 1 elt))))
action-alist))
use-menus t
mouse-event last-nonmenu-event))
(setq user-keys (if action-alist
(concat (mapconcat (function
(lambda (elt)
(key-description
(char-to-string (car elt)))))
action-alist ", ")
" ")
"")
;; Make a map that defines each user key as a vector containing
;; its definition.
map (cons 'keymap
(append (mapcar (lambda (elt)
(cons (car elt) (vector (nth 1 elt))))
action-alist)
query-replace-map))))
(unwind-protect
(progn
(if (stringp prompter)
(setq prompter `(lambda (object)
(format ,prompter object))))
(while (funcall next)
(setq prompt (funcall prompter elt))
(cond ((stringp prompt)
;; Prompt the user about this object.
(setq quit-flag nil)
(if use-menus
(setq def (or (x-popup-dialog (or mouse-event use-menus)
(cons prompt map))
'quit))
;; Prompt in the echo area.
(let ((cursor-in-echo-area (not no-cursor-in-echo-area))
(message-log-max nil))
(message "%s(y, n, !, ., q, %sor %s) "
prompt user-keys
(key-description (vector help-char)))
(if minibuffer-auto-raise
(raise-frame (window-frame (minibuffer-window))))
(while (progn
(setq char (read-event))
;; If we get -1, from end of keyboard
;; macro, try again.
(equal char -1)))
;; Show the answer to the question.
(message "%s(y, n, !, ., q, %sor %s) %s"
prompt user-keys
(key-description (vector help-char))
(single-key-description char)))
(setq def (lookup-key map (vector char))))
(cond ((eq def 'exit)
(setq next (function (lambda () nil))))
((eq def 'act)
;; Act on the object.
(funcall actor elt)
(setq actions (1+ actions)))
((eq def 'skip)
;; Skip the object.
)
((eq def 'act-and-exit)
;; Act on the object and then exit.
(funcall actor elt)
(setq actions (1+ actions)
next (function (lambda () nil))))
((eq def 'quit)
(setq quit-flag t)
(setq next `(lambda ()
(setq next ',next)
',elt)))
((eq def 'automatic)
;; Act on this and all following objects.
(if (funcall prompter elt)
(progn
(funcall actor elt)
(setq actions (1+ actions))))
(while (funcall next)
(if (funcall prompter elt)
(progn
(funcall actor elt)
(setq actions (1+ actions))))))
((eq def 'help)
(with-output-to-temp-buffer "*Help*"
(princ
(let ((object (if help (nth 0 help) "object"))
(objects (if help (nth 1 help) "objects"))
(action (if help (nth 2 help) "act on")))
(concat
(format "Type SPC or `y' to %s the current %s;
DEL or `n' to skip the current %s;
RET or `q' to exit (skip all remaining %s);
C-g to quit (cancel the operation);
! to %s all remaining %s;\n"
action object object objects action
objects)
(mapconcat (function
(lambda (elt)
(format "%s to %s"
(single-key-description
(nth 0 elt))
(nth 2 elt))))
action-alist
";\n")
(if action-alist ";\n")
(format "or . (period) to %s \
the current %s and exit."
action object))))
(save-excursion
(set-buffer standard-output)
(help-mode)))
(setq next `(lambda ()
(setq next ',next)
',elt)))
((vectorp def)
;; A user-defined key.
(if (funcall (aref def 0) elt) ;Call its function.
;; The function has eaten this object.
(setq actions (1+ actions))
;; Regurgitated; try again.
(setq next `(lambda ()
(setq next ',next)
',elt))))
((and (consp char)
(eq (car char) 'switch-frame))
;; switch-frame event. Put it off until we're done.
(setq delayed-switch-frame char)
(setq next `(lambda ()
(setq next ',next)
',elt)))
(t
;; Random char.
(message "Type %s for help."
(key-description (vector help-char)))
(beep)
(sit-for 1)
(setq next `(lambda ()
(setq next ',next)
',elt)))))
(prompt
(funcall actor elt)
(setq actions (1+ actions))))))
(if delayed-switch-frame
(setq unread-command-events
(cons delayed-switch-frame unread-command-events))))
;; Clear the last prompt from the minibuffer.
(let ((message-log-max nil))
(message ""))
;; Return the number of actions that were taken.
actions))
;;; map-ynp.el ends here

258
lisp/emacs-lisp/regi.el Normal file
View file

@ -0,0 +1,258 @@
;;; regi.el --- REGular expression Interpreting engine
;; Copyright (C) 1993 Free Software Foundation, Inc.
;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
;; Maintainer: bwarsaw@cen.com
;; Created: 24-Feb-1993
;; Version: 1.8
;; Last Modified: 1993/06/01 21:33:00
;; Keywords: extensions, matching
;; 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(defun regi-pos (&optional position col-p)
"Return the character position at various buffer positions.
Optional POSITION can be one of the following symbols:
`bol' == beginning of line
`boi' == beginning of indentation
`eol' == end of line [default]
`bonl' == beginning of next line
`bopl' == beginning of previous line
Optional COL-P non-nil returns `current-column' instead of character position."
(save-excursion
(cond
((eq position 'bol) (beginning-of-line))
((eq position 'boi) (back-to-indentation))
((eq position 'bonl) (forward-line 1))
((eq position 'bopl) (forward-line -1))
(t (end-of-line)))
(if col-p (current-column) (point))))
(defun regi-mapcar (predlist func &optional negate-p case-fold-search-p)
"Build a regi frame where each element of PREDLIST appears exactly once.
The frame contains elements where each member of PREDLIST is
associated with FUNC, and optionally NEGATE-P and CASE-FOLD-SEARCH-P."
(let (frame tail)
(if (or negate-p case-fold-search-p)
(setq tail (list negate-p)))
(if case-fold-search-p
(setq tail (append tail (list case-fold-search-p))))
(while predlist
(let ((element (list (car predlist) func)))
(if tail
(setq element (append element tail)))
(setq frame (append frame (list element))
predlist (cdr predlist))
))
frame))
(defun regi-interpret (frame &optional start end)
"Interpret the regi frame FRAME.
If optional START and END are supplied, they indicate the region of
interest, and the buffer is narrowed to the beginning of the line
containing START, and beginning of the line after the line containing
END. Otherwise, point and mark are not set and processing continues
until your FUNC returns the `abort' symbol (see below). Beware! Not
supplying a START or END could put you in an infinite loop.
A regi frame is a list of entries of the form:
(PRED FUNC [NEGATE-P [CASE-FOLD-SEARCH]])
PRED is a predicate against which each line in the region is tested,
and if a match occurs, FUNC is `eval'd. Point is then moved to the
beginning of the next line, the frame is reset and checking continues.
If a match doesn't occur, the next entry is checked against the
current line until all entries in the frame are checked. At this
point, if no match occurred, the frame is reset and point is moved to
the next line. Checking continues until every line in the region is
checked. Optional NEGATE-P inverts the result of PRED before FUNC is
called and `case-fold-search' is bound to the optional value of
CASE-FOLD-SEARCH for the PRED check.
PRED can be a string, variable, function or one of the following
symbols: t, nil, `begin', `end', and `every'. If PRED is a string, or
a variable or list that evaluates to a string, it is interpreted as a
regular expression and is matched against the current line (from the
beginning) using `looking-at'. If PRED does not evaluate to a string,
it is interpreted as a binary value (nil or non-nil).
PRED can also be one of the following symbols:
t -- always produces a true outcome
`begin' -- always executes before anything else
`end' -- always executes after everything else
`every' -- execute after frame is matched on a line
Note that NEGATE-P and CASE-FOLD-SEARCH are meaningless if PRED is one
of these special symbols. Only the first occurrence of each symbol in
a frame entry is used, the rest are ignored.
Your FUNC can return values which control regi processing. If a list
is returned from your function, it can contain any combination of the
following elements:
the symbol `continue'
Tells regi to continue processing frame-entries after a match,
instead of resetting to the first entry and advancing to the next
line, as is the default behavior. When returning this symbol,
you must take care not to enter an infinite loop.
the symbol `abort'
Tells regi to terminate processing this frame. any end
frame-entry is still processed.
the list `(frame . NEWFRAME)'
Tells regi to use NEWFRAME as its current frame. In other words,
your FUNC can modify the executing regi frame on the fly.
the list `(step . STEP)'
Tells regi to move STEP number of lines forward during normal
processing. By default, regi moves forward 1 line. STEP can be
negative, but be careful of infinite loops.
You should usually take care to explicitly return nil from your
function if no action is to take place. Your FUNC will always be
`eval'ed. The following variables will be temporarily bound to some
useful information:
`curline'
the current line in the buffer, as a string
`curframe'
the full, current frame being executed
`curentry'
the current frame entry being executed."
(save-excursion
(save-restriction
(let (begin-tag end-tag every-tag current-frame working-frame donep)
;; set up the narrowed region
(and start
end
(let* ((tstart start)
(start (min start end))
(end (max start end)))
(narrow-to-region
(progn (goto-char end) (regi-pos 'bonl))
(progn (goto-char start) (regi-pos 'bol)))))
;; lets find the special tags and remove them from the working
;; frame. note that only the last special tag is used.
(mapcar
(function
(lambda (entry)
(let ((pred (car entry))
(func (car (cdr entry))))
(cond
((eq pred 'begin) (setq begin-tag func))
((eq pred 'end) (setq end-tag func))
((eq pred 'every) (setq every-tag func))
(t
(setq working-frame (append working-frame (list entry))))
) ; end-cond
)))
frame) ; end-mapcar
;; execute the begin entry
(eval begin-tag)
;; now process the frame
(setq current-frame working-frame)
(while (not (or donep (eobp)))
(let* ((entry (car current-frame))
(pred (nth 0 entry))
(func (nth 1 entry))
(negate-p (nth 2 entry))
(case-fold-search (nth 3 entry))
match-p)
(catch 'regi-throw-top
(cond
;; we are finished processing the frame for this line
((not current-frame)
(setq current-frame working-frame) ;reset frame
(forward-line 1)
(throw 'regi-throw-top t))
;; see if predicate evaluates to a string
((stringp (setq match-p (eval pred)))
(setq match-p (looking-at match-p)))
) ; end-cond
;; now that we've done the initial matching, check for
;; negation of match
(and negate-p
(setq match-p (not match-p)))
;; if the line matched, package up the argument list and
;; funcall the FUNC
(if match-p
(let* ((curline (buffer-substring
(regi-pos 'bol)
(regi-pos 'eol)))
(curframe current-frame)
(curentry entry)
(result (eval func))
(step (or (cdr (assq 'step result)) 1))
)
;; changing frame on the fly?
(if (assq 'frame result)
(setq working-frame (cdr (assq 'frame result))))
;; continue processing current frame?
(if (memq 'continue result)
(setq current-frame (cdr current-frame))
(forward-line step)
(setq current-frame working-frame))
;; abort current frame?
(if (memq 'abort result)
(progn
(setq donep t)
(throw 'regi-throw-top t)))
) ; end-let
;; else if no match occurred, then process the next
;; frame-entry on the current line
(setq current-frame (cdr current-frame))
) ; end-if match-p
) ; end catch
) ; end let
;; after every cycle, evaluate every-tag
(eval every-tag)
) ; end-while
;; now process the end entry
(eval end-tag)))))
(provide 'regi)
;;; regi.el ends here

479
lisp/emacs-lisp/timer.el Normal file
View file

@ -0,0 +1,479 @@
;;; timer.el --- run a function with args at some time in future
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Maintainer: FSF
;; 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This package gives you the capability to run Emacs Lisp commands at
;; specified times in the future, either as one-shots or periodically.
;;; Code:
;; Layout of a timer vector:
;; [triggered-p high-seconds low-seconds usecs repeat-delay
;; function args idle-delay]
(defun timer-create ()
"Create a timer object."
(let ((timer (make-vector 8 nil)))
(aset timer 0 t)
timer))
(defun timerp (object)
"Return t if OBJECT is a timer."
(and (vectorp object) (= (length object) 8)))
(defun timer-set-time (timer time &optional delta)
"Set the trigger time of TIMER to TIME.
TIME must be in the internal format returned by, e.g., `current-time'.
If optional third argument DELTA is a positive number, make the timer
fire repeatedly that many seconds apart."
(or (timerp timer)
(error "Invalid timer"))
(aset timer 1 (car time))
(aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time)))
(aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time)))
(nth 2 time))
0))
(aset timer 4 (and (numberp delta) (> delta 0) delta))
timer)
(defun timer-set-idle-time (timer secs &optional repeat)
"Set the trigger idle time of TIMER to SECS.
If optional third argument REPEAT is non-nil, make the timer
fire each time Emacs is idle for that many seconds."
(or (timerp timer)
(error "Invalid timer"))
(aset timer 1 0)
(aset timer 2 0)
(aset timer 3 0)
(timer-inc-time timer secs)
(aset timer 4 repeat)
timer)
(defun timer-next-integral-multiple-of-time (time secs)
"Yield the next value after TIME that is an integral multiple of SECS.
More precisely, the next value, after TIME, that is an integral multiple
of SECS seconds since the epoch. SECS may be a fraction."
(let ((time-base (ash 1 16)))
(if (fboundp 'atan)
;; Use floating point, taking care to not lose precision.
(let* ((float-time-base (float time-base))
(million 1000000.0)
(time-usec (+ (* million
(+ (* float-time-base (nth 0 time))
(nth 1 time)))
(nth 2 time)))
(secs-usec (* million secs))
(mod-usec (mod time-usec secs-usec))
(next-usec (+ (- time-usec mod-usec) secs-usec))
(time-base-million (* float-time-base million)))
(list (floor next-usec time-base-million)
(floor (mod next-usec time-base-million) million)
(floor (mod next-usec million))))
;; Floating point is not supported.
;; Use integer arithmetic, avoiding overflow if possible.
(let* ((mod-sec (mod (+ (* (mod time-base secs)
(mod (nth 0 time) secs))
(nth 1 time))
secs))
(next-1-sec (+ (- (nth 1 time) mod-sec) secs)))
(list (+ (nth 0 time) (floor next-1-sec time-base))
(mod next-1-sec time-base)
0)))))
(defun timer-relative-time (time secs &optional usecs)
"Advance TIME by SECS seconds and optionally USECS microseconds.
SECS may be a fraction."
(let ((high (car time))
(low (if (consp (cdr time)) (nth 1 time) (cdr time)))
(micro (if (numberp (car-safe (cdr-safe (cdr time))))
(nth 2 time)
0)))
;; Add
(if usecs (setq micro (+ micro usecs)))
(if (floatp secs)
(setq micro (+ micro (floor (* 1000000 (- secs (floor secs)))))))
(setq low (+ low (floor secs)))
;; Normalize
;; `/' rounds towards zero while `mod' returns a positive number,
;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))).
(setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0)))
(setq micro (mod micro 1000000))
(setq high (+ high (/ low 65536) (if (< low 0) -1 0)))
(setq low (logand low 65535))
(list high low (and (/= micro 0) micro))))
(defun timer-inc-time (timer secs &optional usecs)
"Increment the time set in TIMER by SECS seconds and USECS microseconds.
SECS may be a fraction. If USECS is omitted, that means it is zero."
(let ((time (timer-relative-time
(list (aref timer 1) (aref timer 2) (aref timer 3))
secs
usecs)))
(aset timer 1 (nth 0 time))
(aset timer 2 (nth 1 time))
(aset timer 3 (or (nth 2 time) 0))))
(defun timer-set-time-with-usecs (timer time usecs &optional delta)
"Set the trigger time of TIMER to TIME plus USECS.
TIME must be in the internal format returned by, e.g., `current-time'.
The microsecond count from TIME is ignored, and USECS is used instead.
If optional fourth argument DELTA is a positive number, make the timer
fire repeatedly that many seconds apart."
(or (timerp timer)
(error "Invalid timer"))
(aset timer 1 (nth 0 time))
(aset timer 2 (nth 1 time))
(aset timer 3 usecs)
(aset timer 4 (and (numberp delta) (> delta 0) delta))
timer)
(make-obsolete 'timer-set-time-with-usecs
"use `timer-set-time' and `timer-inc-time' instead."
"21.4")
(defun timer-set-function (timer function &optional args)
"Make TIMER call FUNCTION with optional ARGS when triggering."
(or (timerp timer)
(error "Invalid timer"))
(aset timer 5 function)
(aset timer 6 args)
timer)
(defun timer-activate (timer)
"Put TIMER on the list of active timers."
(if (and (timerp timer)
(integerp (aref timer 1))
(integerp (aref timer 2))
(integerp (aref timer 3))
(aref timer 5))
(let ((timers timer-list)
last)
;; Skip all timers to trigger before the new one.
(while (and timers
(or (> (aref timer 1) (aref (car timers) 1))
(and (= (aref timer 1) (aref (car timers) 1))
(> (aref timer 2) (aref (car timers) 2)))
(and (= (aref timer 1) (aref (car timers) 1))
(= (aref timer 2) (aref (car timers) 2))
(> (aref timer 3) (aref (car timers) 3)))))
(setq last timers
timers (cdr timers)))
;; Insert new timer after last which possibly means in front of queue.
(if last
(setcdr last (cons timer timers))
(setq timer-list (cons timer timers)))
(aset timer 0 nil)
(aset timer 7 nil)
nil)
(error "Invalid or uninitialized timer")))
(defun timer-activate-when-idle (timer &optional dont-wait)
"Arrange to activate TIMER whenever Emacs is next idle.
If optional argument DONT-WAIT is non-nil, then enable the
timer to activate immediately, or at the right time, if Emacs
is already idle."
(if (and (timerp timer)
(integerp (aref timer 1))
(integerp (aref timer 2))
(integerp (aref timer 3))
(aref timer 5))
(let ((timers timer-idle-list)
last)
;; Skip all timers to trigger before the new one.
(while (and timers
(or (> (aref timer 1) (aref (car timers) 1))
(and (= (aref timer 1) (aref (car timers) 1))
(> (aref timer 2) (aref (car timers) 2)))
(and (= (aref timer 1) (aref (car timers) 1))
(= (aref timer 2) (aref (car timers) 2))
(> (aref timer 3) (aref (car timers) 3)))))
(setq last timers
timers (cdr timers)))
;; Insert new timer after last which possibly means in front of queue.
(if last
(setcdr last (cons timer timers))
(setq timer-idle-list (cons timer timers)))
(aset timer 0 (not dont-wait))
(aset timer 7 t)
nil)
(error "Invalid or uninitialized timer")))
;;;###autoload
(defalias 'disable-timeout 'cancel-timer)
;;;###autoload
(defun cancel-timer (timer)
"Remove TIMER from the list of active timers."
(or (timerp timer)
(error "Invalid timer"))
(setq timer-list (delq timer timer-list))
(setq timer-idle-list (delq timer timer-idle-list))
nil)
;;;###autoload
(defun cancel-function-timers (function)
"Cancel all timers scheduled by `run-at-time' which would run FUNCTION."
(interactive "aCancel timers of function: ")
(let ((tail timer-list))
(while tail
(if (eq (aref (car tail) 5) function)
(setq timer-list (delq (car tail) timer-list)))
(setq tail (cdr tail))))
(let ((tail timer-idle-list))
(while tail
(if (eq (aref (car tail) 5) function)
(setq timer-idle-list (delq (car tail) timer-idle-list)))
(setq tail (cdr tail)))))
;; Record the last few events, for debugging.
(defvar timer-event-last-2 nil)
(defvar timer-event-last-1 nil)
(defvar timer-event-last nil)
(defvar timer-max-repeats 10
"*Maximum number of times to repeat a timer, if real time jumps.")
(defun timer-until (timer time)
"Calculate number of seconds from when TIMER will run, until TIME.
TIMER is a timer, and stands for the time when its next repeat is scheduled.
TIME is a time-list."
(let ((high (- (car time) (aref timer 1)))
(low (- (nth 1 time) (aref timer 2))))
(+ low (* high 65536))))
(defun timer-event-handler (timer)
"Call the handler for the timer TIMER.
This function is called, by name, directly by the C code."
(setq timer-event-last-2 timer-event-last-1)
(setq timer-event-last-1 timer-event-last)
(setq timer-event-last timer)
(let ((inhibit-quit t))
(if (timerp timer)
(progn
;; Delete from queue.
(cancel-timer timer)
;; Re-schedule if requested.
(if (aref timer 4)
(if (aref timer 7)
(timer-activate-when-idle timer)
(timer-inc-time timer (aref timer 4) 0)
;; If real time has jumped forward,
;; perhaps because Emacs was suspended for a long time,
;; limit how many times things get repeated.
(if (and (numberp timer-max-repeats)
(< 0 (timer-until timer (current-time))))
(let ((repeats (/ (timer-until timer (current-time))
(aref timer 4))))
(if (> repeats timer-max-repeats)
(timer-inc-time timer (* (aref timer 4) repeats)))))
(timer-activate timer)))
;; Run handler.
;; We do this after rescheduling so that the handler function
;; can cancel its own timer successfully with cancel-timer.
(condition-case nil
(apply (aref timer 5) (aref timer 6))
(error nil)))
(error "Bogus timer event"))))
;; This function is incompatible with the one in levents.el.
(defun timeout-event-p (event)
"Non-nil if EVENT is a timeout event."
(and (listp event) (eq (car event) 'timer-event)))
;;;###autoload
(defun run-at-time (time repeat function &rest args)
"Perform an action at time TIME.
Repeat the action every REPEAT seconds, if REPEAT is non-nil.
TIME should be a string like \"11:23pm\", nil meaning now, a number of seconds
from now, a value from `current-time', or t (with non-nil REPEAT)
meaning the next integral multiple of REPEAT.
REPEAT may be an integer or floating point number.
The action is to call FUNCTION with arguments ARGS.
This function returns a timer object which you can use in `cancel-timer'."
(interactive "sRun at time: \nNRepeat interval: \naFunction: ")
(or (null repeat)
(and (numberp repeat) (< 0 repeat))
(error "Invalid repetition interval"))
;; Special case: nil means "now" and is useful when repeating.
(if (null time)
(setq time (current-time)))
;; Special case: t means the next integral multiple of REPEAT.
(if (and (eq time t) repeat)
(setq time (timer-next-integral-multiple-of-time (current-time) repeat)))
;; Handle numbers as relative times in seconds.
(if (numberp time)
(setq time (timer-relative-time (current-time) time)))
;; Handle relative times like "2 hours and 35 minutes"
(if (stringp time)
(let ((secs (timer-duration time)))
(if secs
(setq time (timer-relative-time (current-time) secs)))))
;; Handle "11:23pm" and the like. Interpret it as meaning today
;; which admittedly is rather stupid if we have passed that time
;; already. (Though only Emacs hackers hack Emacs at that time.)
(if (stringp time)
(progn
(require 'diary-lib)
(let ((hhmm (diary-entry-time time))
(now (decode-time)))
(if (>= hhmm 0)
(setq time
(encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now)
(nth 4 now) (nth 5 now) (nth 8 now)))))))
(or (consp time)
(error "Invalid time format"))
(let ((timer (timer-create)))
(timer-set-time timer time repeat)
(timer-set-function timer function args)
(timer-activate timer)
timer))
;;;###autoload
(defun run-with-timer (secs repeat function &rest args)
"Perform an action after a delay of SECS seconds.
Repeat the action every REPEAT seconds, if REPEAT is non-nil.
SECS and REPEAT may be integers or floating point numbers.
The action is to call FUNCTION with arguments ARGS.
This function returns a timer object which you can use in `cancel-timer'."
(interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ")
(apply 'run-at-time secs repeat function args))
;;;###autoload
(defun add-timeout (secs function object &optional repeat)
"Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT.
If REPEAT is non-nil, repeat the timer every REPEAT seconds.
This function is for compatibility; see also `run-with-timer'."
(run-with-timer secs repeat function object))
;;;###autoload
(defun run-with-idle-timer (secs repeat function &rest args)
"Perform an action the next time Emacs is idle for SECS seconds.
The action is to call FUNCTION with arguments ARGS.
SECS may be an integer or a floating point number.
If REPEAT is non-nil, do the action each time Emacs has been idle for
exactly SECS seconds (that is, only once for each time Emacs becomes idle).
This function returns a timer object which you can use in `cancel-timer'."
(interactive
(list (read-from-minibuffer "Run after idle (seconds): " nil nil t)
(y-or-n-p "Repeat each time Emacs is idle? ")
(intern (completing-read "Function: " obarray 'fboundp t))))
(let ((timer (timer-create)))
(timer-set-function timer function args)
(timer-set-idle-time timer secs repeat)
(timer-activate-when-idle timer)
timer))
(defun with-timeout-handler (tag)
(throw tag 'timeout))
;;;###autoload (put 'with-timeout 'lisp-indent-function 1)
;;;###autoload
(defmacro with-timeout (list &rest body)
"Run BODY, but if it doesn't finish in SECONDS seconds, give up.
If we give up, we run the TIMEOUT-FORMS and return the value of the last one.
The call should look like:
(with-timeout (SECONDS TIMEOUT-FORMS...) BODY...)
The timeout is checked whenever Emacs waits for some kind of external
event \(such as keyboard input, input from subprocesses, or a certain time);
if the program loops without waiting in any way, the timeout will not
be detected."
(let ((seconds (car list))
(timeout-forms (cdr list)))
`(let ((with-timeout-tag (cons nil nil))
with-timeout-value with-timeout-timer)
(if (catch with-timeout-tag
(progn
(setq with-timeout-timer
(run-with-timer ,seconds nil
'with-timeout-handler
with-timeout-tag))
(setq with-timeout-value (progn . ,body))
nil))
(progn . ,timeout-forms)
(cancel-timer with-timeout-timer)
with-timeout-value))))
(defun y-or-n-p-with-timeout (prompt seconds default-value)
"Like (y-or-n-p PROMPT), with a timeout.
If the user does not answer after SECONDS seconds, return DEFAULT-VALUE."
(with-timeout (seconds default-value)
(y-or-n-p prompt)))
(defvar timer-duration-words
(list (cons "microsec" 0.000001)
(cons "microsecond" 0.000001)
(cons "millisec" 0.001)
(cons "millisecond" 0.001)
(cons "sec" 1)
(cons "second" 1)
(cons "min" 60)
(cons "minute" 60)
(cons "hour" (* 60 60))
(cons "day" (* 24 60 60))
(cons "week" (* 7 24 60 60))
(cons "fortnight" (* 14 24 60 60))
(cons "month" (* 30 24 60 60)) ; Approximation
(cons "year" (* 365.25 24 60 60)) ; Approximation
)
"Alist mapping temporal words to durations in seconds")
(defun timer-duration (string)
"Return number of seconds specified by STRING, or nil if parsing fails."
(let ((secs 0)
(start 0)
(case-fold-search t))
(while (string-match
"[ \t]*\\([0-9.]+\\)?[ \t]*\\([a-z]+[a-rt-z]\\)s?[ \t]*"
string start)
(let ((count (if (match-beginning 1)
(string-to-number (match-string 1 string))
1))
(itemsize (cdr (assoc (match-string 2 string)
timer-duration-words))))
(if itemsize
(setq start (match-end 0)
secs (+ secs (* count itemsize)))
(setq secs nil
start (length string)))))
(if (= start (length string))
secs
(if (string-match "\\`[0-9.]+\\'" string)
(string-to-number string)))))
(provide 'timer)
;;; timer.el ends here

311
lisp/emacs-lisp/warnings.el Normal file
View file

@ -0,0 +1,311 @@
;;; warnings.el --- log and display warnings
;; Copyright (C) 2002 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This file implements the entry points `warn', `lwarn'
;; and `display-warnings'.
;;; Code:
(defgroup warnings nil
"Log and display warnings."
:version "21.4"
:group 'lisp)
(defvar warning-levels
'((:emergency "Emergency%s: " ding)
(:error "Error%s: ")
(:warning "Warning%s: ")
(:debug "Debug%s: "))
"List of severity level definitions for `display-warning'.
Each element looks like (LEVEL STRING FUNCTION) and
defines LEVEL as a severity level. STRING specifies the
description of this level. STRING should use `%s' to
specify where to put the warning group information,
or it can omit the `%s' so as not to include that information.
The optional FUNCTION, if non-nil, is a function to call
with no arguments, to get the user's attention.
The standard levels are :emergency, :error, :warning and :debug.
See `display-warning' for documentation of their meanings.
Level :debug is ignored by default (see `warning-minimum-level').")
(put 'warning-levels 'risky-local-variable t)
;; These are for compatibility with XEmacs.
;; I don't think there is any chance of designing meaningful criteria
;; to distinguish so many levels.
(defvar warning-level-aliases
'((emergency . :emergency)
(error . :error)
(warning . :warning)
(notice . :warning)
(info . :warning)
(critical . :emergency)
(alarm . :emergency))
"Alist of aliases for severity levels for `display-warning'.
Each element looks like (ALIAS . LEVEL) and defines
ALIAS as equivalent to LEVEL. LEVEL must be defined in `warning-levels';
it may not itself be an alias.")
(defcustom warning-minimum-level :warning
"Minimum severity level for displaying the warning buffer.
If a warning's severity level is lower than this,
the warning is logged in the warnings buffer, but the buffer
is not immediately displayed. See also `warning-minimum-log-level'."
:group 'warnings
:type '(choice (const :emergency) (const :error) (const :warning))
:version "21.4")
(defvaralias 'display-warning-minimum-level 'warning-minimum-level)
(defcustom warning-minimum-log-level :warning
"Minimum severity level for logging a warning.
If a warning severity level is lower than this,
the warning is completely ignored."
:group 'warnings
:type '(choice (const :emergency) (const :error) (const :warning))
:version "21.4")
(defvaralias 'log-warning-minimum-level 'warning-minimum-log-level)
(defcustom warning-suppress-log-types nil
"List of warning types that should not be logged.
If any element of this list matches the GROUP argument to `display-warning',
the warning is completely ignored.
The element must match the first elements of GROUP.
Thus, (foo bar) as an element matches (foo bar)
or (foo bar ANYTHING...) as GROUP.
If GROUP is a symbol FOO, that is equivalent to the list (FOO),
so only the element (FOO) will match it."
:group 'warnings
:type '(repeat (repeat symbol))
:version "21.4")
(defcustom warning-suppress-types nil
"Custom groups for warnings not to display immediately.
If any element of this list matches the GROUP argument to `display-warning',
the warning is logged nonetheless, but the warnings buffer is
not immediately displayed.
The element must match an initial segment of the list GROUP.
Thus, (foo bar) as an element matches (foo bar)
or (foo bar ANYTHING...) as GROUP.
If GROUP is a symbol FOO, that is equivalent to the list (FOO),
so only the element (FOO) will match it.
See also `warning-suppress-log-types'."
:group 'warnings
:type '(repeat (repeat symbol))
:version "21.4")
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;;;###autoload
(defvar warning-prefix-function nil
"Function to generate warning prefixes.
This function, if non-nil, is called with two arguments,
the severity level and its entry in `warning-levels',
and should return the entry that should actually be used.
The warnings buffer is current when this function is called
and the function can insert text in it. This text becomes
the beginning of the warning.")
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;;;###autoload
(defvar warning-series nil
"Non-nil means treat multiple `display-warning' calls as a series.
A marker indicates a position in the warnings buffer
which is the start of the current series; it means that
additional warnings in the same buffer should not move point.
t means the next warning begins a series (and stores a marker here).
A symbol with a function definition is like t, except
also call that function before the next warning.")
(put 'warning-series 'risky-local-variable t)
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;;;###autoload
(defvar warning-fill-prefix nil
"Non-nil means fill each warning text using this string as `fill-prefix'.")
;;; The autoload cookie is so that programs can bind this variable
;;; safely, testing the existing value, before they call one of the
;;; warnings functions.
;;;###autoload
(defvar warning-group-format " (%s)"
"Format for displaying the warning group in the warning message.
The result of formatting the group this way gets included in the
message under the control of the string in `warning-levels'.")
(defun warning-numeric-level (level)
"Return a numeric measure of the warning severity level LEVEL."
(let* ((elt (assq level warning-levels))
(link (memq elt warning-levels)))
(length link)))
(defun warning-suppress-p (group suppress-list)
"Non-nil if a warning with group GROUP should be suppressed.
SUPPRESS-LIST is the list of kinds of warnings to suppress."
(let (some-match)
(dolist (elt suppress-list)
(if (symbolp group)
;; If GROUP is a symbol, the ELT must be (GROUP).
(if (and (consp elt)
(eq (car elt) group)
(null (cdr elt)))
(setq some-match t))
;; If GROUP is a list, ELT must match it or some initial segment of it.
(let ((tem1 group)
(tem2 elt)
(match t))
;; Check elements of ELT until we run out of them.
(while tem2
(if (not (equal (car tem1) (car tem2)))
(setq match nil))
(setq tem1 (cdr tem1)
tem2 (cdr tem2)))
;; If ELT is an initial segment of GROUP, MATCH is t now.
;; So set SOME-MATCH.
(if match
(setq some-match t)))))
;; If some element of SUPPRESS-LIST matched,
;; we return t.
some-match))
;;;###autoload
(defun display-warning (group message &optional level buffer-name)
"Display a warning message, MESSAGE.
GROUP should be a custom group name (a symbol),
or else a list of symbols whose first element is a custom group name.
\(The rest of the symbols represent subcategories, for warning purposes
only, and you can use whatever symbols you like.)
LEVEL should be either :warning, :error, or :emergency.
:emergency -- a problem that will seriously impair Emacs operation soon
if you do not attend to it promptly.
:error -- data or circumstances that are inherently wrong.
:warning -- data or circumstances that are not inherently wrong,
but raise suspicion of a possible problem.
:debug -- info for debugging only.
BUFFER-NAME, if specified, is the name of the buffer for logging the
warning. By default, it is `*Warnings*'.
See the `warnings' custom group for user customization features.
See also `warning-series', `warning-prefix-function' and
`warning-fill-prefix' for additional programming features."
(unless level
(setq level :warning))
(if (assq level warning-level-aliases)
(setq level (cdr (assq level warning-level-aliases))))
(or (< (warning-numeric-level level)
(warning-numeric-level warning-minimum-log-level))
(warning-suppress-p group warning-suppress-log-types)
(let* ((groupname (if (consp group) (car group) group))
(buffer (get-buffer-create (or buffer-name "*Warnings*")))
(level-info (assq level warning-levels))
start end)
(with-current-buffer buffer
(goto-char (point-max))
(when (and warning-series (symbolp warning-series))
(setq warning-series
(prog1 (point-marker)
(unless (eq warning-series t)
(funcall warning-series)))))
(unless (bolp)
(newline))
(setq start (point))
(if warning-prefix-function
(setq level-info (funcall warning-prefix-function
level level-info)))
(insert (format (nth 1 level-info)
(format warning-group-format groupname))
message)
(newline)
(when (and warning-fill-prefix (not (string-match "\n" message)))
(let ((fill-prefix warning-fill-prefix)
(fill-column 78))
(fill-region start (point))))
(setq end (point))
(when (and (markerp warning-series)
(eq (marker-buffer warning-series) buffer))
(goto-char warning-series)))
(if (nth 2 level-info)
(funcall (nth 2 level-info)))
(if noninteractive
;; Noninteractively, take the text we inserted
;; in the warnings buffer and print it.
;; Do this unconditionally, since there is no way
;; to view logged messages unless we output them.
(with-current-buffer buffer
(save-excursion
;; Don't include the final newline in the arg
;; to `message', because it adds a newline.
(goto-char end)
(if (bolp)
(forward-char -1))
(message "%s" (buffer-substring start (point)))))
;; Interactively, decide whether the warning merits
;; immediate display.
(or (< (warning-numeric-level level)
(warning-numeric-level warning-minimum-level))
(warning-suppress-p group warning-suppress-types)
(let ((window (display-buffer buffer)))
(when (and (markerp warning-series)
(eq (marker-buffer warning-series) buffer))
(set-window-start window warning-series))
(sit-for 0)))))))
;;;###autoload
(defun lwarn (group level message &rest args)
"Display a warning message made from (format MESSAGE ARGS...).
Aside from generating the message with `format',
this is equivalent to `display-warning'.
GROUP should be a custom group name (a symbol).
or else a list of symbols whose first element is a custom group name.
\(The rest of the symbols represent subcategories and
can be whatever you like.)
LEVEL should be either :warning, :error, or :emergency.
:emergency -- a problem that will seriously impair Emacs operation soon
if you do not attend to it promptly.
:error -- invalid data or circumstances.
:warning -- suspicious data or circumstances."
(display-warning group (apply 'format message args) level))
;;;###autoload
(defun warn (message &rest args)
"Display a warning message made from (format MESSAGE ARGS...).
Aside from generating the message with `format',
this is equivalent to `display-warning', using
`emacs' as the group and `:warning' as the level."
(display-warning 'emacs (apply 'format message args)))
(provide 'warnings)
;;; warnings.el ends here

256
lisp/progmodes/which-func.el Normal file
View file

@ -0,0 +1,256 @@
;;; which-func.el --- print current function in mode line
;; Copyright (C) 1994, 1997, 1998, 2001, 2003 Free Software Foundation, Inc.
;; Author: Alex Rezinsky <alexr@msil.sps.mot.com>
;; (doesn't seem to be responsive any more)
;; Keywords: mode-line, imenu, 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This package prints name of function where your current point is
;; located in mode line. It assumes that you work with imenu package
;; and imenu--index-alist is up to date.
;; KNOWN BUGS
;; ----------
;; Really this package shows not "function where the current point is
;; located now", but "nearest function which defined above the current
;; point". So if your current point is located after end of function
;; FOO but before begin of function BAR, FOO will be displayed in mode
;; line.
;; - if two windows display the same buffer, both windows
;; show the same `which-func' information.
;; TODO LIST
;; ---------
;; 1. Dependence on imenu package should be removed. Separate
;; function determination mechanism should be used to determine the end
;; of a function as well as the beginning of a function.
;; 2. This package should be realized with the help of overlay
;; properties instead of imenu--index-alist variable.
;;; History:
;; THANKS TO
;; ---------
;; Per Abrahamsen <abraham@iesd.auc.dk>
;; Some ideas (inserting in mode-line, using of post-command hook
;; and toggling this mode) have been borrowed from his package
;; column.el
;; Peter Eisenhauer <pipe@fzi.de>
;; Bug fixing in case nested indexes.
;; Terry Tateyama <ttt@ursa0.cs.utah.edu>
;; Suggestion to use find-file-hook for first imenu
;; index building.
;;; Code:
;; Variables for customization
;; ---------------------------
;;
(defvar which-func-unknown "???"
"String to display in the mode line when current function is unknown.")
(defgroup which-func nil
"Mode to display the current function name in the modeline."
:group 'tools
:version "20.3")
(defcustom which-func-modes
'(emacs-lisp-mode c-mode c++-mode perl-mode cperl-mode makefile-mode
sh-mode fortran-mode f90-mode)
"List of major modes for which Which Function mode should be used.
For other modes it is disabled. If this is equal to t,
then Which Function mode is enabled in any major mode that supports it."
:group 'which-func
:type '(choice (const :tag "All modes" t)
(repeat (symbol :tag "Major mode"))))
(defcustom which-func-non-auto-modes nil
"List of major modes where Which Function mode is inactive till Imenu is used.
This means that Which Function mode won't really do anything
until you use Imenu, in these modes. Note that files
larger than `which-func-maxout' behave in this way too;
Which Function mode doesn't do anything until you use Imenu."
:group 'which-func
:type '(repeat (symbol :tag "Major mode")))
(defcustom which-func-maxout 500000
"Don't automatically compute the Imenu menu if buffer is this big or bigger.
Zero means compute the Imenu menu regardless of size."
:group 'which-func
:type 'integer)
(defcustom which-func-format '("[" which-func-current "]")
"Format for displaying the function in the mode line."
:group 'which-func
:type 'sexp)
;;;###autoload (put 'which-func-format 'risky-local-variable t)
(defvar which-func-cleanup-function nil
"Function to transform a string before displaying it in the mode line.
The function is called with one argument, the string to display.
Its return value is displayed in the modeline.
If nil, no function is called. The default value is nil.
This feature can be useful if Imenu is set up to make more
detailed entries (e.g., containing the argument list of a function),
and you want to simplify them for the mode line
\(e.g., removing the parameter list to just have the function name.)")
;;; Code, nothing to customize below here
;;; -------------------------------------
;;;
(require 'imenu)
(defvar which-func-table (make-hash-table :test 'eq :weakness 'key))
(defconst which-func-current
'(:eval (gethash (selected-window) which-func-table which-func-unknown)))
;;;###autoload (put 'which-func-current 'risky-local-variable t)
(defvar which-func-mode nil
"Non-nil means display current function name in mode line.
This makes a difference only if `which-function-mode' is non-nil.")
(make-variable-buffer-local 'which-func-mode)
;;(put 'which-func-mode 'permanent-local t)
(add-hook 'find-file-hook 'which-func-ff-hook t)
(defun which-func-ff-hook ()
"File find hook for Which Function mode.
It creates the Imenu index for the buffer, if necessary."
(setq which-func-mode
(and which-function-mode
(or (eq which-func-modes t)
(member major-mode which-func-modes))))
(condition-case nil
(if (and which-func-mode
(not (member major-mode which-func-non-auto-modes))
(or (null which-func-maxout)
(< buffer-saved-size which-func-maxout)
(= which-func-maxout 0)))
(setq imenu--index-alist
(save-excursion (funcall imenu-create-index-function))))
(error
(setq which-func-mode nil))))
(defun which-func-update ()
;; "Update the Which-Function mode display for all windows."
;; (walk-windows 'which-func-update-1 nil 'visible))
(which-func-update-1 (selected-window)))
(defun which-func-update-1 (window)
"Update the Which-Function mode display for window WINDOW."
(with-selected-window window
(when which-func-mode
(condition-case info
(let ((current (which-function)))
(unless (equal current (gethash window which-func-table))
(puthash window current which-func-table)
(force-mode-line-update)))
(error
(which-func-mode -1)
(error "Error in which-func-update: %s" info))))))
;;;###autoload
(defalias 'which-func-mode 'which-function-mode)
(defvar which-func-update-timer nil)
;; This is the name people would normally expect.
;;;###autoload
(define-minor-mode which-function-mode
"Toggle Which Function mode, globally.
When Which Function mode is enabled, the current function name is
continuously displayed in the mode line, in certain major modes.
With prefix ARG, turn Which Function mode on iff arg is positive,
and off otherwise."
:global t :group 'which-func
(if which-function-mode
;;Turn it on
(progn
(setq which-func-update-timer
(run-with-idle-timer idle-update-delay t 'which-func-update))
(dolist (buf (buffer-list))
(with-current-buffer buf
(setq which-func-mode
(or (eq which-func-modes t)
(member major-mode which-func-modes))))))
;; Turn it off
(cancel-timer which-func-update-timer)
(setq which-func-update-timer nil)
(dolist (buf (buffer-list))
(with-current-buffer buf (setq which-func-mode nil)))))
(defvar which-function-imenu-failed nil
"Locally t in a buffer if `imenu--make-index-alist' found nothing there.")
(defun which-function ()
"Return current function name based on point.
Uses `imenu--index-alist' or `add-log-current-defun-function'.
If no function name is found, return nil."
(let (name)
;; If Imenu is loaded, try to make an index alist with it.
(when (and (boundp 'imenu--index-alist) (null imenu--index-alist)
(null which-function-imenu-failed))
(imenu--make-index-alist)
(unless imenu--index-alist
(make-local-variable 'which-function-imenu-failed)
(setq which-function-imenu-failed t)))
;; If we have an index alist, use it.
(when (and (boundp 'imenu--index-alist) imenu--index-alist)
(let ((alist imenu--index-alist)
(minoffset (point-max))
offset elem pair mark)
(while alist
(setq elem (car-safe alist)
alist (cdr-safe alist))
;; Elements of alist are either ("name" . marker), or
;; ("submenu" ("name" . marker) ... ).
(unless (listp (cdr elem))
(setq elem (list elem)))
(while elem
(setq pair (car elem)
elem (cdr elem))
(and (consp pair)
(number-or-marker-p (setq mark (cdr pair)))
(if (>= (setq offset (- (point) mark)) 0)
(if (< offset minoffset) ; find the closest item
(setq minoffset offset
name (car pair)))
;; Entries in order, so can skip all those after point.
(setq elem nil)))))))
;; Try using add-log support.
(when (and (null name) (boundp 'add-log-current-defun-function)
add-log-current-defun-function)
(setq name (funcall add-log-current-defun-function)))
;; Filter the name if requested.
(when name
(if which-func-cleanup-function
(funcall which-func-cleanup-function name)
name))))
(provide 'which-func)
;;; which-func.el ends here

474
lisp/textmodes/enriched.el Normal file
View file

@ -0,0 +1,474 @@
;;; enriched.el --- read and save files in text/enriched format
;; Copyright (c) 1994, 1995, 1996, 2002 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: wp, faces
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This file implements reading, editing, and saving files with
;; text-properties such as faces, levels of indentation, and true line
;; breaks distinguished from newlines just used to fit text into the window.
;; The file format used is the MIME text/enriched format, which is a
;; standard format defined in internet RFC 1563. All standard annotations
;; are supported except for <smaller> and <bigger>, which are currently not
;; possible to display.
;; A separate file, enriched.doc, contains further documentation and other
;; important information about this code. It also serves as an example
;; file in text/enriched format. It should be in the etc directory of your
;; emacs distribution.
;;; Code:
(provide 'enriched)
;;;
;;; Variables controlling the display
;;;
(defgroup enriched nil
"Read and save files in text/enriched format"
:group 'wp)
(defcustom enriched-verbose t
"*If non-nil, give status messages when reading and writing files."
:type 'boolean
:group 'enriched)
;;;
;;; Set up faces & display table
;;;
;; Emacs doesn't have a "fixed" face by default, since all faces currently
;; have to be fixed-width. So we just pick one that looks different from the
;; default.
(defface fixed
'((t (:weight bold)))
"Face used for text that must be shown in fixed width.
Currently, emacs can only display fixed-width fonts, but this may change.
This face is used for text specifically marked as fixed-width, for example
in text/enriched files."
:group 'enriched)
(defface excerpt
'((t (:slant italic)))
"Face used for text that is an excerpt from another document.
This is used in Enriched mode for text explicitly marked as an excerpt."
:group 'enriched)
(defconst enriched-display-table (or (copy-sequence standard-display-table)
(make-display-table)))
(aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
(defconst enriched-par-props '(left-margin right-margin justification)
"Text-properties that usually apply to whole paragraphs.
These are set front-sticky everywhere except at hard newlines.")
;;;
;;; Variables controlling the file format
;;; (bidirectional)
(defconst enriched-initial-annotation
(lambda ()
(format "Content-Type: text/enriched\nText-Width: %d\n\n"
fill-column))
"What to insert at the start of a text/enriched file.
If this is a string, it is inserted. If it is a list, it should be a lambda
expression, which is evaluated to get the string to insert.")
(defconst enriched-annotation-format "<%s%s>"
"General format of enriched-text annotations.")
(defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-Za-z0-9]+\\)>"
"Regular expression matching enriched-text annotations.")
(defconst enriched-translations
'((face (bold-italic "bold" "italic")
(bold "bold")
(italic "italic")
(underline "underline")
(fixed "fixed")
(excerpt "excerpt")
(default )
(nil enriched-encode-other-face))
(left-margin (4 "indent"))
(right-margin (4 "indentright"))
(justification (none "nofill")
(right "flushright")
(left "flushleft")
(full "flushboth")
(center "center"))
(PARAMETER (t "param")) ; Argument of preceding annotation
;; The following are not part of the standard:
(FUNCTION (enriched-decode-foreground "x-color")
(enriched-decode-background "x-bg-color")
(enriched-decode-display-prop "x-display"))
(read-only (t "x-read-only"))
(display (nil enriched-handle-display-prop))
(unknown (nil format-annotate-value))
; (font-size (2 "bigger") ; unimplemented
; (-2 "smaller"))
)
"List of definitions of text/enriched annotations.
See `format-annotate-region' and `format-deannotate-region' for the definition
of this structure.")
(defconst enriched-ignore
'(front-sticky rear-nonsticky hard)
"Properties that are OK to ignore when saving text/enriched files.
Any property that is neither on this list nor dealt with by
`enriched-translations' will generate a warning.")
;;; Internal variables
(defcustom enriched-mode-hook nil
"Hook run after entering/leaving Enriched mode.
If you set variables in this hook, you should arrange for them to be restored
to their old values if you leave Enriched mode. One way to do this is to add
them and their old values to `enriched-old-bindings'."
:type 'hook
:group 'enriched)
(defvar enriched-old-bindings nil
"Store old variable values that we change when entering mode.
The value is a list of \(VAR VALUE VAR VALUE...).")
(make-variable-buffer-local 'enriched-old-bindings)
;;;
;;; Define the mode
;;;
(put 'enriched-mode 'permanent-local t)
;;;###autoload
(define-minor-mode enriched-mode
"Minor mode for editing text/enriched files.
These are files with embedded formatting information in the MIME standard
text/enriched format.
Turning the mode on runs `enriched-mode-hook'.
More information about Enriched mode is available in the file
etc/enriched.doc in the Emacs distribution directory.
Commands:
\\{enriched-mode-map}"
nil " Enriched" nil
(cond ((null enriched-mode)
;; Turn mode off
(setq buffer-file-format (delq 'text/enriched buffer-file-format))
;; restore old variable values
(while enriched-old-bindings
(set (pop enriched-old-bindings) (pop enriched-old-bindings))))
((memq 'text/enriched buffer-file-format)
;; Mode already on; do nothing.
nil)
(t ; Turn mode on
(push 'text/enriched buffer-file-format)
;; Save old variable values before we change them.
;; These will be restored if we exit Enriched mode.
(setq enriched-old-bindings
(list 'buffer-display-table buffer-display-table
'indent-line-function indent-line-function
'default-text-properties default-text-properties))
(make-local-variable 'indent-line-function)
(make-local-variable 'default-text-properties)
(setq indent-line-function 'indent-to-left-margin ;WHY?? -sm
buffer-display-table enriched-display-table)
(use-hard-newlines 1 nil)
(let ((sticky (plist-get default-text-properties 'front-sticky))
(p enriched-par-props))
(dolist (x p)
(add-to-list 'sticky x))
(if sticky
(setq default-text-properties
(plist-put default-text-properties
'front-sticky sticky)))))))
;;;
;;; Keybindings
;;;
(defvar enriched-mode-map nil
"Keymap for Enriched mode.")
(if (null enriched-mode-map)
(fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
(if (not (assq 'enriched-mode minor-mode-map-alist))
(setq minor-mode-map-alist
(cons (cons 'enriched-mode enriched-mode-map)
minor-mode-map-alist)))
(define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
(define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
(define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
(define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
(define-key enriched-mode-map "\M-S" 'set-justification-center)
(define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
(define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
(define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
;;;
;;; Some functions dealing with text-properties, especially indentation
;;;
(defun enriched-map-property-regions (prop func &optional from to)
"Apply a function to regions of the buffer based on a text property.
For each contiguous region of the buffer for which the value of PROPERTY is
eq, the FUNCTION will be called. Optional arguments FROM and TO specify the
region over which to scan.
The specified function receives three arguments: the VALUE of the property in
the region, and the START and END of each region."
(save-excursion
(save-restriction
(if to (narrow-to-region (point-min) to))
(goto-char (or from (point-min)))
(let ((begin (point))
end
(marker (make-marker))
(val (get-text-property (point) prop)))
(while (setq end (text-property-not-all begin (point-max) prop val))
(move-marker marker end)
(funcall func val begin (marker-position marker))
(setq begin (marker-position marker)
val (get-text-property marker prop)))
(if (< begin (point-max))
(funcall func val begin (point-max)))))))
(put 'enriched-map-property-regions 'lisp-indent-hook 1)
(defun enriched-insert-indentation (&optional from to)
"Indent and justify each line in the region."
(save-excursion
(save-restriction
(if to (narrow-to-region (point-min) to))
(goto-char (or from (point-min)))
(if (not (bolp)) (forward-line 1))
(while (not (eobp))
(if (eolp)
nil ; skip blank lines
(indent-to (current-left-margin))
(justify-current-line t nil t))
(forward-line 1)))))
;;;
;;; Encoding Files
;;;
;;;###autoload
(defun enriched-encode (from to orig-buf)
(if enriched-verbose (message "Enriched: encoding document..."))
(save-restriction
(narrow-to-region from to)
(delete-to-left-margin)
(unjustify-region)
(goto-char from)
(format-replace-strings '(("<" . "<<")))
(format-insert-annotations
(format-annotate-region from (point-max) enriched-translations
'enriched-make-annotation enriched-ignore))
(goto-char from)
(insert (if (stringp enriched-initial-annotation)
enriched-initial-annotation
(save-excursion
;; Eval this in the buffer we are annotating. This
;; fixes a bug which was saving incorrect File-Width
;; information, since we were looking at local
;; variables in the wrong buffer.
(if orig-buf (set-buffer orig-buf))
(funcall enriched-initial-annotation))))
(enriched-map-property-regions 'hard
(lambda (v b e)
(if (and v (= ?\n (char-after b)))
(progn (goto-char b) (insert "\n"))))
(point) nil)
(if enriched-verbose (message nil))
;; Return new end.
(point-max)))
(defun enriched-make-annotation (internal-ann positive)
"Format an annotation INTERNAL-ANN.
INTERNAL-ANN may be a string, for a flag, or a list of the form (PARAM VALUE).
If POSITIVE is non-nil, this is the opening annotation;
if nil, the matching close."
(cond ((stringp internal-ann)
(format enriched-annotation-format (if positive "" "/") internal-ann))
;; Otherwise it is an annotation with parameters, represented as a list
(positive
(let ((item (car internal-ann))
(params (cdr internal-ann)))
(concat (format enriched-annotation-format "" item)
(mapconcat (lambda (i) (concat "<param>" i "</param>"))
params ""))))
(t (format enriched-annotation-format "/" (car internal-ann)))))
(defun enriched-encode-other-face (old new)
"Generate annotations for random face change.
One annotation each for foreground color, background color, italic, etc."
(cons (and old (enriched-face-ans old))
(and new (enriched-face-ans new))))
(defun enriched-face-ans (face)
"Return annotations specifying FACE.
FACE may be a list of faces instead of a single face;
it can also be anything allowed as an element of a list
which can be the value of the `face' text property."
(cond ((and (consp face) (eq (car face) 'foreground-color))
(list (list "x-color" (cdr face))))
((and (consp face) (eq (car face) 'background-color))
(list (list "x-bg-color" (cdr face))))
((and (listp face) (eq (car face) :foreground))
(list (list "x-color" (cadr face))))
((and (listp face) (eq (car face) :background))
(list (list "x-bg-color" (cadr face))))
((listp face)
(apply 'append (mapcar 'enriched-face-ans face)))
((let* ((fg (face-attribute face :foreground))
(bg (face-attribute face :background))
(props (face-font face t))
(ans (cdr (format-annotate-single-property-change
'face nil props enriched-translations))))
(unless (eq fg 'unspecified)
(setq ans (cons (list "x-color" fg) ans)))
(unless (eq bg 'unspecified)
(setq ans (cons (list "x-bg-color" bg) ans)))
ans))))
;;;
;;; Decoding files
;;;
;;;###autoload
(defun enriched-decode (from to)
(if enriched-verbose (message "Enriched: decoding document..."))
(use-hard-newlines 1 'never)
(save-excursion
(save-restriction
(narrow-to-region from to)
(goto-char from)
;; Deal with header
(let ((file-width (enriched-get-file-width)))
(enriched-remove-header)
;; Deal with newlines
(while (search-forward-regexp "\n\n+" nil t)
(if (current-justification)
(delete-char -1))
(set-hard-newline-properties (match-beginning 0) (point)))
;; Translate annotations
(format-deannotate-region from (point-max) enriched-translations
'enriched-next-annotation)
;; Indent or fill the buffer
(cond (file-width ; File was filled to this width
(setq fill-column file-width)
(if enriched-verbose (message "Indenting..."))
(enriched-insert-indentation))
(t ; File was not filled.
(if enriched-verbose (message "Filling paragraphs..."))
(fill-region (point-min) (point-max))))
(if enriched-verbose (message nil)))
(point-max))))
(defun enriched-next-annotation ()
"Find and return next text/enriched annotation.
Any \"<<\" strings encountered are converted to \"<\".
Return value is \(begin end name positive-p), or nil if none was found."
(while (and (search-forward "<" nil 1)
(progn (goto-char (match-beginning 0))
(not (looking-at enriched-annotation-regexp))))
(forward-char 1)
(if (= ?< (char-after (point)))
(delete-char 1)
;; A single < that does not start an annotation is an error,
;; which we note and then ignore.
(message "Warning: malformed annotation in file at %s"
(1- (point)))))
(if (not (eobp))
(let* ((beg (match-beginning 0))
(end (match-end 0))
(name (downcase (buffer-substring
(match-beginning 2) (match-end 2))))
(pos (not (match-beginning 1))))
(list beg end name pos))))
(defun enriched-get-file-width ()
"Look for file width information on this line."
(save-excursion
(if (search-forward "Text-Width: " (+ (point) 1000) t)
(read (current-buffer)))))
(defun enriched-remove-header ()
"Remove file-format header at point."
(while (looking-at "^[-A-Za-z]+: .*\n")
(delete-region (point) (match-end 0)))
(if (looking-at "^\n")
(delete-char 1)))
(defun enriched-decode-foreground (from to &optional color)
(if color
(list from to 'face (list ':foreground color))
(message "Warning: no color specified for <x-color>")
nil))
(defun enriched-decode-background (from to &optional color)
(if color
(list from to 'face (list ':background color))
(message "Warning: no color specified for <x-bg-color>")
nil))
;;; Handling the `display' property.
(defun enriched-handle-display-prop (old new)
"Return a list of annotations for a change in the `display' property.
OLD is the old value of the property, NEW is the new value. Value
is a list `(CLOSE OPEN)', where CLOSE is a list of annotations to
close and OPEN a list of annotations to open. Each of these lists
has the form `(ANNOTATION PARAM ...)'."
(let ((annotation "x-display")
(param (prin1-to-string (or old new))))
(if (null old)
(cons nil (list (list annotation param)))
(cons (list (list annotation param)) nil))))
(defun enriched-decode-display-prop (start end &optional param)
"Decode a `display' property for text between START and END.
PARAM is a `<param>' found for the property.
Value is a list `(START END SYMBOL VALUE)' with START and END denoting
the range of text to assign text property SYMBOL with value VALUE "
(let ((prop (when (stringp param)
(condition-case ()
(car (read-from-string param))
(error nil)))))
(unless prop
(message "Warning: invalid <x-display> parameter %s" param))
(list start end 'display prop)))
;;; enriched.el ends here