diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-macs.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 130 |
1 files changed, 85 insertions, 45 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c75d3b9f9f0..9ca675f08c4 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1,4 +1,4 @@ -;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*- +;;; cl-macs.el --- Common Lisp macros ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -20,9 +20,7 @@ ;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -45,9 +43,7 @@ ;;; Code: -(or (memq 'cl-19 features) - (error "Tried to load `cl-macs' before `cl'!")) - +(require 'cl) (defmacro cl-pop2 (place) (list 'prog1 (list 'car (list 'cdr place)) @@ -58,8 +54,8 @@ (defvar cl-optimize-speed) -;;; This kludge allows macros which use cl-transform-function-property -;;; to be called at compile-time. +;; This kludge allows macros which use cl-transform-function-property +;; to be called at compile-time. (require (progn @@ -75,10 +71,6 @@ (defvar cl-old-bc-file-form nil) -(defun cl-compile-time-init () - (run-hooks 'cl-hack-bytecomp-hook)) - - ;;; Some predicates for analyzing Lisp forms. These are used by various ;;; macro expanders to optimize the results in certain common cases. @@ -165,6 +157,7 @@ ;;; Symbols. (defvar *gensym-counter*) +;;;###autoload (defun gensym (&optional prefix) "Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\"." @@ -174,6 +167,7 @@ The name is made by appending a number to PREFIX, default \"G\"." (setq *gensym-counter* (1+ *gensym-counter*)))))) (make-symbol (format "%s%d" pfix num)))) +;;;###autoload (defun gentemp (&optional prefix) "Generate a new interned symbol with a unique name. The name is made by appending a number to PREFIX, default \"G\"." @@ -186,6 +180,7 @@ The name is made by appending a number to PREFIX, default \"G\"." ;;; Program structure. +;;;###autoload (defmacro defun* (name args &rest body) "Define NAME as a function. Like normal `defun', except ARGLIST allows full Common Lisp conventions, @@ -196,6 +191,7 @@ and BODY is implicitly surrounded by (block NAME ...). (form (list* 'defun name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +;;;###autoload (defmacro defmacro* (name args &rest body) "Define NAME as a macro. Like normal `defmacro', except ARGLIST allows full Common Lisp conventions, @@ -206,6 +202,7 @@ and BODY is implicitly surrounded by (block NAME ...). (form (list* 'defmacro name (cdr res)))) (if (car res) (list 'progn (car res) form) form))) +;;;###autoload (defmacro function* (func) "Introduce a function. Like normal `function', except that if argument is a lambda form, @@ -426,6 +423,7 @@ its argument list allows full Common Lisp conventions." (setq res (nconc res (cl-arglist-args arg)))))) (nconc res (and args (list args)))))) +;;;###autoload (defmacro destructuring-bind (args expr &rest body) (let* ((bind-lets nil) (bind-forms nil) (bind-inits nil) (bind-defs nil) (bind-block 'cl-none)) @@ -439,6 +437,7 @@ its argument list allows full Common Lisp conventions." (defvar cl-not-toplevel nil) +;;;###autoload (defmacro eval-when (when &rest body) "Control when BODY is evaluated. If `compile' is in WHEN, BODY is evaluated when compiled at top-level. @@ -470,6 +469,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. form))) (t (eval form) form))) +;;;###autoload (defmacro load-time-value (form &optional read-only) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." @@ -492,6 +492,7 @@ The result of the body appears to the compiler as a quoted constant." ;;; Conditional control structures. +;;;###autoload (defmacro case (expr &rest clauses) "Eval EXPR and choose among clauses on that value. Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared @@ -526,12 +527,14 @@ Key values are compared by `eql'. (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) +;;;###autoload (defmacro ecase (expr &rest clauses) "Like `case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" (list* 'case expr (append clauses '((ecase-error-flag))))) +;;;###autoload (defmacro typecase (expr &rest clauses) "Evals EXPR, chooses among clauses on that value. Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it @@ -558,6 +561,7 @@ final clause, and matches if no other keys match. (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) +;;;###autoload (defmacro etypecase (expr &rest clauses) "Like `typecase', but error if no case fits. `otherwise'-clauses are not allowed. @@ -567,6 +571,7 @@ final clause, and matches if no other keys match. ;;; Blocks and exits. +;;;###autoload (defmacro block (name &rest body) "Define a lexically-scoped block named NAME. NAME may be any symbol. Code inside the BODY forms can call `return-from' @@ -602,11 +607,13 @@ called from BODY." (if cl-found (setcdr cl-found t))) (byte-compile-normal-call (cons 'throw (cdr cl-form)))) +;;;###autoload (defmacro return (&optional result) "Return from the block named nil. This is equivalent to `(return-from nil RESULT)'." (list 'return-from nil result)) +;;;###autoload (defmacro return-from (name &optional result) "Return from the block named NAME. This jump out to the innermost enclosing `(block NAME ...)' form, @@ -626,6 +633,7 @@ This is compatible with Common Lisp, but note that `defun' and (defvar loop-result) (defvar loop-result-explicit) (defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs) +;;;###autoload (defmacro loop (&rest args) "The Common Lisp `loop' macro. Valid clauses are: @@ -1185,12 +1193,14 @@ Valid clauses are: ;;; Other iteration control structures. +;;;###autoload (defmacro do (steps endtest &rest body) "The Common Lisp `do' loop. \(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" (cl-expand-do-loop steps endtest body nil)) +;;;###autoload (defmacro do* (steps endtest &rest body) "The Common Lisp `do*' loop. @@ -1218,6 +1228,7 @@ Valid clauses are: (apply 'append sets))))))) (or (cdr endtest) '(nil))))) +;;;###autoload (defmacro dolist (spec &rest body) "Loop over a list. Evaluate BODY with VAR bound to each `car' from LIST, in turn. @@ -1234,6 +1245,7 @@ Then evaluate RESULT to get return value, default nil. (cons (list 'setq (car spec) nil) (cdr (cdr spec))) '(nil)))))) +;;;###autoload (defmacro dotimes (spec &rest body) "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers from 0, inclusive, @@ -1248,6 +1260,7 @@ nil. (append body (list (list 'incf (car spec))))) (or (cdr (cdr spec)) '(nil)))))) +;;;###autoload (defmacro do-symbols (spec &rest body) "Loop over all symbols. Evaluate BODY with VAR bound to each interned symbol, or to each symbol @@ -1262,12 +1275,14 @@ from OBARRAY. (and (cadr spec) (list (cadr spec)))) (caddr spec)))) +;;;###autoload (defmacro do-all-symbols (spec &rest body) (list* 'do-symbols (list (car spec) nil (cadr spec)) body)) ;;; Assignments. +;;;###autoload (defmacro psetq (&rest args) "Set SYMs to the values VALs in parallel. This is like `setq', except that all VAL forms are evaluated (in order) @@ -1279,6 +1294,7 @@ before assigning any symbols SYM to the corresponding values. ;;; Binding control structures. +;;;###autoload (defmacro progv (symbols values &rest body) "Bind SYMBOLS to VALUES dynamically in BODY. The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists. @@ -1292,6 +1308,7 @@ a `let' form, except that the list of symbols can be computed at run-time." '(cl-progv-after)))) ;;; This should really have some way to shadow 'byte-compile properties, etc. +;;;###autoload (defmacro flet (bindings &rest body) "Make temporary function definitions. This is an analogue of `let' that operates on the function cell of FUNC @@ -1319,6 +1336,7 @@ go back to their previous definitions, or lack thereof). bindings) body)) +;;;###autoload (defmacro labels (bindings &rest body) "Make temporary function bindings. This is like `flet', except the bindings are lexical instead of dynamic. @@ -1343,6 +1361,7 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard. ;; The following ought to have a better definition for use with newer ;; byte compilers. +;;;###autoload (defmacro macrolet (bindings &rest body) "Make temporary macro definitions. This is like `flet', but for macros instead of functions. @@ -1359,6 +1378,7 @@ This is like `flet', but for macros instead of functions. (cons (list* name 'lambda (cdr res)) cl-macro-environment)))))) +;;;###autoload (defmacro symbol-macrolet (bindings &rest body) "Make symbol macro definitions. Within the body FORMs, references to the variable NAME will be replaced @@ -1375,6 +1395,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). cl-macro-environment))))) (defvar cl-closure-vars nil) +;;;###autoload (defmacro lexical-let (bindings &rest body) "Like `let', but lexically scoped. The main visible difference is that lambdas inside BODY will create @@ -1418,6 +1439,7 @@ lexical closures as in Common Lisp. vars)) ebody)))) +;;;###autoload (defmacro lexical-let* (bindings &rest body) "Like `let*', but lexically scoped. The main visible difference is that lambdas inside BODY will create @@ -1438,6 +1460,7 @@ lexical closures as in Common Lisp. ;;; Multiple values. +;;;###autoload (defmacro multiple-value-bind (vars form &rest body) "Collect multiple return values. FORM must return a list; the BODY is then executed with the first N elements @@ -1455,6 +1478,7 @@ a synonym for (list A B C). vars)) body))) +;;;###autoload (defmacro multiple-value-setq (vars form) "Collect multiple return values. FORM must return a list; the first N elements of this list are stored in @@ -1481,7 +1505,9 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;; Declarations. +;;;###autoload (defmacro locally (&rest body) (cons 'progn body)) +;;;###autoload (defmacro the (type form) form) (defvar cl-proclaim-history t) ; for future compilers @@ -1519,15 +1545,11 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). byte-compile-delete-errors (nth 1 safety))))) ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) - (if (eq byte-compile-warnings t) - (setq byte-compile-warnings byte-compile-warning-types)) (while (setq spec (cdr spec)) (if (consp (car spec)) (if (eq (cadar spec) 0) - (setq byte-compile-warnings - (delq (caar spec) byte-compile-warnings)) - (setq byte-compile-warnings - (adjoin (caar spec) byte-compile-warnings))))))) + (byte-compile-disable-warning (caar spec)) + (byte-compile-enable-warning (caar spec))))))) nil) ;;; Process any proclamations made before cl-macs was loaded. @@ -1536,6 +1558,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). (while p (cl-do-proclaim (pop p) t)) (setq cl-proclaims-deferred nil)) +;;;###autoload (defmacro declare (&rest specs) (if (cl-compiling-file) (while specs @@ -1547,6 +1570,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C). ;;; Generalized variables. +;;;###autoload (defmacro define-setf-method (func args &rest body) "Define a `setf' method. This method shows how to handle `setf's to places of the form (NAME ARGS...). @@ -1565,8 +1589,9 @@ form. See `defsetf' for a simpler way to define most setf-methods. func 'setf-method (cons args body))))) (defalias 'define-setf-expander 'define-setf-method) +;;;###autoload (defmacro defsetf (func arg1 &rest args) - "(defsetf NAME FUNC): define a `setf' method. + "Define a `setf' method. This macro is an easy-to-use substitute for `define-setf-method' that works well for simple place forms. In the simple `defsetf' form, `setf's of the form (setf (NAME ARGS...) VAL) are transformed to function or macro @@ -1585,7 +1610,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v)) \(fn NAME [FUNC | ARGLIST (STORE) BODY...])" - (if (listp arg1) + (if (and (listp arg1) (consp args)) (let* ((largs nil) (largsr nil) (temps nil) (tempsr nil) (restarg nil) (rest-temps nil) @@ -1723,7 +1748,7 @@ Example: (defsetf frame-parameters modify-frame-parameters t) (defsetf frame-visible-p cl-set-frame-visible-p) (defsetf frame-width set-screen-width t) -(defsetf frame-parameter set-frame-parameter) +(defsetf frame-parameter set-frame-parameter t) (defsetf getenv setenv t) (defsetf get-register set-register) (defsetf global-key-binding global-set-key) @@ -1840,6 +1865,7 @@ Example: (list 'substring (nth 4 method) from-temp to-temp)))) ;;; Getting and optimizing setf-methods. +;;;###autoload (defun get-setf-method (place &optional env) "Return a list of five values describing the setf-method for PLACE. PLACE may be any Lisp form which can appear as the PLACE argument to @@ -1859,8 +1885,7 @@ a macro like `setf' or `incf'." method (error "Setf-method for %s returns malformed method" func))) - (and (save-match-data - (string-match "\\`c[ad][ad][ad]?[ad]?r\\'" name)) + (and (string-match-p "\\`c[ad][ad][ad]?[ad]?r\\'" name) (get-setf-method (compiler-macroexpand place))) (and (eq func 'edebug-after) (get-setf-method (nth (1- (length place)) place) @@ -1907,6 +1932,7 @@ a macro like `setf' or `incf'." (not (eq (car-safe (symbol-function (car form))) 'macro)))) ;;; The standard modify macros. +;;;###autoload (defmacro setf (&rest args) "Set each PLACE to the value of its VAL. This is a generalized version of `setq'; the PLACEs may be symbolic @@ -1925,6 +1951,7 @@ The return value is the last VAL in the list. (store (cl-setf-do-store (nth 1 method) (nth 1 args)))) (if (car method) (list 'let* (car method) store) store))))) +;;;###autoload (defmacro psetf (&rest args) "Set PLACEs to the values VALs in parallel. This is like `setf', except that all VAL forms are evaluated (in order) @@ -1948,6 +1975,7 @@ before assigning any PLACEs to the corresponding values. (setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr)))) (list 'progn expr nil))))) +;;;###autoload (defun cl-do-pop (place) (if (cl-simple-expr-p place) (list 'prog1 (list 'car place) (list 'setf place (list 'cdr place))) @@ -1960,6 +1988,7 @@ before assigning any PLACEs to the corresponding values. (list 'car temp) (cl-setf-do-store (nth 1 method) (list 'cdr temp))))))) +;;;###autoload (defmacro remf (place tag) "Remove TAG from property list PLACE. PLACE may be a symbol, or any generalized variable allowed by `setf'. @@ -1980,6 +2009,7 @@ The form returns true if TAG was found and removed, nil otherwise." t) (list 'cl-do-remf tval ttag))))) +;;;###autoload (defmacro shiftf (place &rest args) "Shift left among PLACEs. Example: (shiftf A B C) sets A to B, B to C, and returns the old A. @@ -1995,6 +2025,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (prog1 ,(nth 2 method) ,(cl-setf-do-store (nth 1 method) `(shiftf ,@args)))))))) +;;;###autoload (defmacro rotatef (&rest args) "Rotate left among PLACEs. Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil. @@ -2020,6 +2051,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (list 'let* (append (car method) (list (list temp (nth 2 method)))) (cl-setf-do-store (nth 1 method) form) nil))))) +;;;###autoload (defmacro letf (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let', but with generalized variables (in the @@ -2076,6 +2108,7 @@ the PLACE is not modified before executing BODY. rev (cdr rev)))) (list* 'let* lets body)))) +;;;###autoload (defmacro letf* (bindings &rest body) "Temporarily bind to PLACEs. This is the analogue of `let*', but with generalized variables (in the @@ -2094,6 +2127,7 @@ the PLACE is not modified before executing BODY. (setq body (list (list* 'letf (list (pop bindings)) body)))) (car body))) +;;;###autoload (defmacro callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). FUNC should be an unquoted function name. PLACE may be a symbol, @@ -2108,6 +2142,7 @@ or any generalized variable allowed by `setf'. (list* 'funcall (list 'function func) rargs)))))) +;;;###autoload (defmacro callf2 (func arg1 place &rest args) "Set PLACE to (FUNC ARG1 PLACE ARGS...). Like `callf', but PLACE is the second argument of FUNC, not the first. @@ -2124,6 +2159,7 @@ Like `callf', but PLACE is the second argument of FUNC, not the first. (list* 'funcall (list 'function func) rargs))))))) +;;;###autoload (defmacro define-modify-macro (name arglist func &optional doc) "Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other arguments @@ -2138,6 +2174,7 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)" ;;; Structures. +;;;###autoload (defmacro defstruct (struct &rest descs) "Define a struct type. This macro defines a new Lisp data type called NAME, which contains data @@ -2362,6 +2399,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors. forms) (cons 'progn (nreverse (cons (list 'quote name) forms))))) +;;;###autoload (defun cl-struct-setf-expander (x name accessor pred-form pos) (let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--"))) (list (list temp) (list x) (list store) @@ -2404,7 +2442,7 @@ The type name can then be used in `typecase', `check-type', etc." ((eq type 'real) `(numberp ,val)) ((eq type 'fixnum) `(integerp ,val)) ;; FIXME: Should `character' accept things like ?\C-\M-a ? -stef - ((memq type '(character string-char)) `(char-valid-p ,val)) + ((memq type '(character string-char)) `(characterp ,val)) (t (let* ((name (symbol-name type)) (namep (intern (concat name "p")))) @@ -2430,11 +2468,13 @@ The type name can then be used in `typecase', `check-type', etc." ((eq (car type) 'satisfies) (list (cadr type) val)) (t (error "Bad type spec: %s" type))))) +;;;###autoload (defun typep (object type) ; See compiler macro below. "Check that OBJECT is of type TYPE. TYPE is a Common Lisp-style type specifier." (eval (cl-make-type-test 'object type))) +;;;###autoload (defmacro check-type (form type &optional string) "Verify that FORM is of type TYPE; signal an error if not. STRING is an optional description of the desired type." @@ -2449,6 +2489,7 @@ STRING is an optional description of the desired type." (if (eq temp form) (list 'progn body nil) (list 'let (list (list temp form)) body nil))))) +;;;###autoload (defmacro assert (form &optional show-args string &rest args) "Verify that FORM returns non-nil; signal an error if not. Second arg SHOW-ARGS means to include arguments of FORM in message. @@ -2457,11 +2498,12 @@ They are not evaluated unless the assertion fails. If STRING is omitted, a default message listing FORM itself is used." (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) - (let ((sargs (and show-args (delq nil (mapcar - (function - (lambda (x) - (and (not (cl-const-expr-p x)) - x))) (cdr form)))))) + (let ((sargs (and show-args + (delq nil (mapcar + (lambda (x) + (unless (cl-const-expr-p x) + x)) + (cdr form)))))) (list 'progn (list 'or form (if string @@ -2470,14 +2512,9 @@ omitted, a default message listing FORM itself is used." (list* 'list (list 'quote form) sargs)))) nil)))) -(defmacro ignore-errors (&rest body) - "Execute BODY; if an error occurs, return nil. -Otherwise, return result of last form in BODY." - `(condition-case nil (progn ,@body) (error nil))) - - ;;; Compiler macros. +;;;###autoload (defmacro define-compiler-macro (func args &rest body) "Define a compiler-only macro. This is like `defmacro', but macro expansion occurs only if the call to @@ -2501,6 +2538,7 @@ and then returning foo." (list 'put (list 'quote func) '(quote byte-compile) '(quote cl-byte-compile-compiler-macro))))) +;;;###autoload (defun compiler-macroexpand (form) (while (let ((func (car-safe form)) (handler nil)) @@ -2556,9 +2594,9 @@ surrounded by (block NAME ...). (if lets (list 'let lets body) body)))) -;;; Compile-time optimizations for some functions defined in this package. -;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, -;;; mainly to make sure these macros will be present. +;; Compile-time optimizations for some functions defined in this package. +;; Note that cl.el arranges to force cl-macs to be loaded at compile-time, +;; mainly to make sure these macros will be present. (put 'eql 'byte-compile nil) (define-compiler-macro eql (&whole form a b) @@ -2669,9 +2707,11 @@ surrounded by (block NAME ...). (run-hooks 'cl-macs-load-hook) -;;; Local variables: -;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime) -;;; End: +;; Local variables: +;; byte-compile-dynamic: t +;; byte-compile-warnings: (not cl-functions) +;; generated-autoload-file: "cl-loaddefs.el" +;; End: ;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46 ;;; cl-macs.el ends here |