-;;; 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
+;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
;; Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; 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
;; 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:
;;; 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))
(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
(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.
;;; 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\"."
(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\"."
;;; Program structure.
+;;;###autoload
(defmacro defun* (name args &rest body)
"Define NAME as a function.
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
(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,
(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,
(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))
(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.
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."
;;; 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
(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
(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.
;;; 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'
(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,
(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:
;;; 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.
(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.
(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,
(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
(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)
;;; 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.
'(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
(let ((func (list 'function*
(list 'lambda (cadr x)
(list* 'block (car x) (cddr x))))))
- (if (and (cl-compiling-file)
- (boundp 'byte-compile-function-environment))
- (push (cons (car x) (eval func))
- byte-compile-function-environment))
+ (when (cl-compiling-file)
+ ;; Bug#411. It would be nice to fix this.
+ (and (get (car x) 'byte-compile)
+ (error "Byte-compiling a redefinition of `%s' \
+will not work - use `labels' instead" (symbol-name (car x))))
+ ;; FIXME This affects the rest of the file, when it
+ ;; should be restricted to the flet body.
+ (and (boundp 'byte-compile-function-environment)
+ (push (cons (car x) (eval func))
+ byte-compile-function-environment)))
(list (list 'symbol-function (list 'quote (car x))) func))))
bindings)
body))
+;;;###autoload
(defmacro labels (bindings &rest body)
"Make temporary function bindings.
This is like `flet', except the bindings are lexical instead of dynamic.
;; 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.
(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
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
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
-lexical closures as in Common Lisp.
+The main visible difference is that lambdas inside BODY, and in
+successive bindings within BINDINGS, will create lexical closures
+as in Common Lisp. This is similar to the behavior of `let*' in
+Common Lisp.
\n(fn VARLIST BODY)"
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
;;; 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
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
;;; Declarations.
+;;;###autoload
(defmacro locally (&rest body) (cons 'progn body))
+;;;###autoload
(defmacro the (type form) form)
(defvar cl-proclaim-history t) ; for future compilers
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.
(while p (cl-do-proclaim (pop p) t))
(setq cl-proclaims-deferred nil))
+;;;###autoload
(defmacro declare (&rest specs)
(if (cl-compiling-file)
(while specs
;;; 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...).
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
(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)
(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)
(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
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)
(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
(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)
(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)))
(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'.
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.
(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.
(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
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
(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,
(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.
(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
;;; Structures.
+;;;###autoload
(defmacro defstruct (struct &rest descs)
"Define a struct type.
This macro defines a new Lisp data type called NAME, which contains data
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)
((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"))))
((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."
(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.
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
(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
(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))
(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)
(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