Mercurial > emacs
changeset 51344:67c8a7fdf699
Moved to emacs-lisp/.
| author | Juanma Barranquero <lekktu@gmail.com> |
|---|---|
| date | Fri, 30 May 2003 23:26:50 +0000 |
| parents | 09019ffe5baf |
| children | 4628274506d5 |
| files | lisp/byte-run.el lisp/derived.el lisp/float-sup.el lisp/map-ynp.el lisp/regi.el lisp/timer.el lisp/warnings.el |
| diffstat | 7 files changed, 0 insertions(+), 1983 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/byte-run.el Fri May 30 23:24:41 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,172 +0,0 @@ -;;; 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
--- a/lisp/derived.el Fri May 30 23:24:41 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,436 +0,0 @@ -;;; 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
--- a/lisp/float-sup.el Fri May 30 23:24:41 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -;;; 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
--- a/lisp/map-ynp.el Fri May 30 23:24:41 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,264 +0,0 @@ -;;; 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
--- a/lisp/regi.el Fri May 30 23:24:41 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,258 +0,0 @@ -;;; 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
--- a/lisp/timer.el Fri May 30 23:24:41 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,479 +0,0 @@ -;;; 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
--- a/lisp/warnings.el Fri May 30 23:24:41 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,311 +0,0 @@ -;;; 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