Mercurial > emacs
changeset 51349:dd8d7c8c6ae8
Moved from lisp/.
| author | Juanma Barranquero <lekktu@gmail.com> |
|---|---|
| date | Fri, 30 May 2003 23:31:15 +0000 |
| parents | ae6bdfe1f4ce |
| children | d555ff64edde |
| files | lisp/emacs-lisp/byte-run.el lisp/emacs-lisp/derived.el lisp/emacs-lisp/float-sup.el lisp/emacs-lisp/map-ynp.el lisp/emacs-lisp/regi.el lisp/emacs-lisp/timer.el lisp/emacs-lisp/warnings.el lisp/progmodes/which-func.el lisp/textmodes/enriched.el |
| diffstat | 9 files changed, 2713 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/byte-run.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/derived.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/float-sup.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/map-ynp.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/regi.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/timer.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/warnings.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/which-func.el Fri May 30 23:31:15 2003 +0000 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/enriched.el Fri May 30 23:31:15 2003 +0000 @@ -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