;;; cl-macs.el --- Common Lisp macros
-;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;;; Count number of times X refers to Y. Return nil for 0 times.
(defun cl-expr-contains (x y)
+ ;; FIXME: This is naive, and it will count Y as referred twice in
+ ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on
+ ;; non-macroexpanded code, so it may also miss some occurrences that would
+ ;; only appear in the expanded code.
(cond ((equal y x) 1)
((and (consp x) (not (memq (car-safe x) '(quote function function*))))
(let ((sum 0))
- (while x
+ (while (consp x)
(setq sum (+ sum (or (cl-expr-contains (pop x) y) 0))))
+ (setq sum (+ sum (or (cl-expr-contains x y) 0)))
(and (> sum 0) sum)))
(t nil)))
;;; Symbols.
-(defvar *gensym-counter*)
+(defvar cl--gensym-counter)
;;;###autoload
(defun gensym (&optional prefix)
"Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
(let ((pfix (if (stringp prefix) prefix "G"))
(num (if (integerp prefix) prefix
- (prog1 *gensym-counter*
- (setq *gensym-counter* (1+ *gensym-counter*))))))
+ (prog1 cl--gensym-counter
+ (setq cl--gensym-counter (1+ cl--gensym-counter))))))
(make-symbol (format "%s%d" pfix num))))
;;;###autoload
The name is made by appending a number to PREFIX, default \"G\"."
(let ((pfix (if (stringp prefix) prefix "G"))
name)
- (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*)))
- (setq *gensym-counter* (1+ *gensym-counter*)))
+ (while (intern-soft (setq name (format "%s%d" pfix cl--gensym-counter)))
+ (setq cl--gensym-counter (1+ cl--gensym-counter)))
(intern name)))
;;; Program structure.
+(def-edebug-spec cl-declarations
+ (&rest ("declare" &rest sexp)))
+
+(def-edebug-spec cl-declarations-or-string
+ (&or stringp cl-declarations))
+
+(def-edebug-spec cl-lambda-list
+ (([&rest arg]
+ [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]]
+ [&optional ["&rest" arg]]
+ [&optional ["&key" [cl-&key-arg &rest cl-&key-arg]
+ &optional "&allow-other-keys"]]
+ [&optional ["&aux" &rest
+ &or (symbolp &optional def-form) symbolp]]
+ )))
+
+(def-edebug-spec cl-&optional-arg
+ (&or (arg &optional def-form arg) arg))
+
+(def-edebug-spec cl-&key-arg
+ (&or ([&or (symbolp arg) arg] &optional def-form arg) arg))
+
;;;###autoload
(defmacro defun* (name args &rest body)
"Define NAME as a function.
and BODY is implicitly surrounded by (block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
+ (declare (debug
+ ;; Same as defun but use cl-lambda-list.
+ (&define [&or name ("setf" :name setf name)]
+ cl-lambda-list
+ cl-declarations-or-string
+ [&optional ("interactive" interactive)]
+ def-body))
+ (indent 2))
(let* ((res (cl-transform-lambda (cons args body) name))
(form (list* 'defun name (cdr res))))
(if (car res) (list 'progn (car res) form) form)))
+;; The lambda list for macros is different from that of normal lambdas.
+;; Note that &environment is only allowed as first or last items in the
+;; top level list.
+
+(def-edebug-spec cl-macro-list
+ (([&optional "&environment" arg]
+ [&rest cl-macro-arg]
+ [&optional ["&optional" &rest
+ &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
+ [&optional [[&or "&rest" "&body"] cl-macro-arg]]
+ [&optional ["&key" [&rest
+ [&or ([&or (symbolp cl-macro-arg) arg]
+ &optional def-form cl-macro-arg)
+ arg]]
+ &optional "&allow-other-keys"]]
+ [&optional ["&aux" &rest
+ &or (symbolp &optional def-form) symbolp]]
+ [&optional "&environment" arg]
+ )))
+
+(def-edebug-spec cl-macro-arg
+ (&or arg cl-macro-list1))
+
+(def-edebug-spec cl-macro-list1
+ (([&optional "&whole" arg] ;; only allowed at lower levels
+ [&rest cl-macro-arg]
+ [&optional ["&optional" &rest
+ &or (cl-macro-arg &optional def-form cl-macro-arg) arg]]
+ [&optional [[&or "&rest" "&body"] cl-macro-arg]]
+ [&optional ["&key" [&rest
+ [&or ([&or (symbolp cl-macro-arg) arg]
+ &optional def-form cl-macro-arg)
+ arg]]
+ &optional "&allow-other-keys"]]
+ [&optional ["&aux" &rest
+ &or (symbolp &optional def-form) symbolp]]
+ . [&or arg nil])))
+
;;;###autoload
(defmacro defmacro* (name args &rest body)
"Define NAME as a macro.
and BODY is implicitly surrounded by (block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
+ (declare (debug
+ (&define name cl-macro-list cl-declarations-or-string def-body))
+ (indent 2))
(let* ((res (cl-transform-lambda (cons args body) name))
(form (list* 'defmacro name (cdr res))))
(if (car res) (list 'progn (car res) form) form)))
+(def-edebug-spec cl-lambda-expr
+ (&define ("lambda" cl-lambda-list
+ ;;cl-declarations-or-string
+ ;;[&optional ("interactive" interactive)]
+ def-body)))
+
+;; Redefine function-form to also match function*
+(def-edebug-spec function-form
+ ;; form at the end could also handle "function",
+ ;; but recognize it specially to avoid wrapping function forms.
+ (&or ([&or "quote" "function"] &or symbolp lambda-expr)
+ ("function*" function*)
+ form))
+
;;;###autoload
(defmacro function* (func)
"Introduce a function.
Like normal `function', except that if argument is a lambda form,
its argument list allows full Common Lisp conventions."
+ (declare (debug (&or symbolp cl-lambda-expr)))
(if (eq (car-safe func) 'lambda)
(let* ((res (cl-transform-lambda (cdr func) 'cl-none))
(form (list 'function (cons 'lambda (cdr res)))))
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
+(defun cl--make-usage-var (x)
+ "X can be a var or a (destructuring) lambda-list."
+ (cond
+ ((symbolp x) (make-symbol (upcase (symbol-name x))))
+ ((consp x) (cl--make-usage-args x))
+ (t x)))
+
+(defun cl--make-usage-args (arglist)
+ ;; `orig-args' can contain &cl-defs (an internal
+ ;; CL thingy I don't understand), so remove it.
+ (let ((x (memq '&cl-defs arglist)))
+ (when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
+ (let ((state nil))
+ (mapcar (lambda (x)
+ (cond
+ ((symbolp x)
+ (if (eq ?\& (aref (symbol-name x) 0))
+ (setq state x)
+ (make-symbol (upcase (symbol-name x)))))
+ ((not (consp x)) x)
+ ((memq state '(nil &rest)) (cl--make-usage-args x))
+ (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
+ (list*
+ (if (and (consp (car x)) (eq state '&key))
+ (list (caar x) (cl--make-usage-var (nth 1 (car x))))
+ (cl--make-usage-var (car x)))
+ (nth 1 x) ;INITFORM.
+ (cl--make-usage-args (nthcdr 2 x)) ;SVAR.
+ ))))
+ arglist)))
+
(defun cl-transform-lambda (form bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(bind-defs nil) (bind-enquote nil)
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car hdr)) (pop hdr))
- ;; orig-args can contain &cl-defs (an internal
- ;; CL thingy I don't understand), so remove it.
- (let ((x (memq '&cl-defs orig-args)))
- (if (null x) orig-args
- (delq (car x) (remq (cadr x) orig-args)))))
+ (format "%S"
+ (cons 'fn
+ (cl--make-usage-args orig-args))))
hdr)))
(list (nconc (list 'let* bind-lets)
(nreverse bind-forms) body)))))))
;;;###autoload
(defmacro destructuring-bind (args expr &rest body)
+ (declare (indent 2)
+ (debug (&define cl-macro-list def-form cl-declarations def-body)))
(let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
(bind-defs nil) (bind-block 'cl-none) (bind-enquote nil))
(cl-do-arglist (or args '(&aux)) expr)
If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
\(fn (WHEN...) BODY...)"
+ (declare (indent 1) (debug ((&rest &or "compile" "load" "eval") body)))
(if (and (fboundp 'cl-compiling-file) (cl-compiling-file)
(not cl-not-toplevel) (not (boundp 'for-effect))) ; horrible kludge
(let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
(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."
+ (declare (debug (form &optional sexp)))
(if (cl-compiling-file)
(let* ((temp (gentemp "--cl-load-time--"))
(set (list 'set (list 'quote temp) form)))
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
- (print set (symbol-value 'bytecomp-outbuffer)))
+ (print set (symbol-value 'byte-compile--outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
allowed only in the final clause, and matches if no other keys match.
Key values are compared by `eql'.
\n(fn EXPR (KEYLIST BODY...)...)"
+ (declare (indent 1) (debug (form &rest (sexp body))))
(let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
(head-list nil)
(body (cons
"Like `case', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
+ (declare (indent 1) (debug case))
(list* 'case expr (append clauses '((ecase-error-flag)))))
;;;###autoload
typecase returns nil. A TYPE of t or `otherwise' is allowed only in the
final clause, and matches if no other keys match.
\n(fn EXPR (TYPE BODY...)...)"
+ (declare (indent 1)
+ (debug (form &rest ([&or cl-type-spec "otherwise"] body))))
(let* ((temp (if (cl-simple-expr-p expr 3) expr (make-symbol "--cl-var--")))
(type-list nil)
(body (cons
"Like `typecase', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (TYPE BODY...)...)"
+ (declare (indent 1) (debug typecase))
(list* 'typecase expr (append clauses '((ecase-error-flag)))))
dynamically scoped: Only references to it within BODY will work. These
references may appear inside macro expansions, but not inside functions
called from BODY."
+ (declare (indent 1) (debug (symbolp body)))
(if (cl-safe-expr-p (cons 'progn body)) (cons 'progn body)
(list 'cl-block-wrapper
(list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
body))))
-(defvar cl-active-block-names nil)
-
-(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
-(defun cl-byte-compile-block (cl-form)
- (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
- (progn
- (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
- (cl-active-block-names (cons cl-entry cl-active-block-names))
- (cl-body (byte-compile-top-level
- (cons 'progn (cddr (nth 1 cl-form))))))
- (if (cdr cl-entry)
- (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
- (byte-compile-form cl-body))))
- (byte-compile-form (nth 1 cl-form))))
-
-(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
-(defun cl-byte-compile-throw (cl-form)
- (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
- (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)'."
+ (declare (debug (&optional form)))
(list 'return-from nil result))
;;;###autoload
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
+ (declare (indent 1) (debug (symbolp &optional form)))
(let ((name2 (intern (format "--cl-block-%s--" name))))
(list 'cl-block-throw (list 'quote name2) result)))
finally return EXPR, named NAME.
\(fn CLAUSE...)"
+ (declare (debug (&rest &or symbolp form)))
(if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args))))))
(list 'block nil (list* 'while t loop-args))
(let ((loop-name nil) (loop-bindings nil)
(setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
(list* 'block loop-name body)))))
+;; Below is a complete spec for loop, in several parts that correspond
+;; to the syntax given in CLtL2. The specs do more than specify where
+;; the forms are; it also specifies, as much as Edebug allows, all the
+;; syntactically valid loop clauses. The disadvantage of this
+;; completeness is rigidity, but the "for ... being" clause allows
+;; arbitrary extensions of the form: [symbolp &rest &or symbolp form].
+
+;; (def-edebug-spec loop
+;; ([&optional ["named" symbolp]]
+;; [&rest
+;; &or
+;; ["repeat" form]
+;; loop-for-as
+;; loop-with
+;; loop-initial-final]
+;; [&rest loop-clause]
+;; ))
+
+;; (def-edebug-spec loop-with
+;; ("with" loop-var
+;; loop-type-spec
+;; [&optional ["=" form]]
+;; &rest ["and" loop-var
+;; loop-type-spec
+;; [&optional ["=" form]]]))
+
+;; (def-edebug-spec loop-for-as
+;; ([&or "for" "as"] loop-for-as-subclause
+;; &rest ["and" loop-for-as-subclause]))
+
+;; (def-edebug-spec loop-for-as-subclause
+;; (loop-var
+;; loop-type-spec
+;; &or
+;; [[&or "in" "on" "in-ref" "across-ref"]
+;; form &optional ["by" function-form]]
+
+;; ["=" form &optional ["then" form]]
+;; ["across" form]
+;; ["being"
+;; [&or "the" "each"]
+;; &or
+;; [[&or "element" "elements"]
+;; [&or "of" "in" "of-ref"] form
+;; &optional "using" ["index" symbolp]];; is this right?
+;; [[&or "hash-key" "hash-keys"
+;; "hash-value" "hash-values"]
+;; [&or "of" "in"]
+;; hash-table-p &optional ["using" ([&or "hash-value" "hash-values"
+;; "hash-key" "hash-keys"] sexp)]]
+
+;; [[&or "symbol" "present-symbol" "external-symbol"
+;; "symbols" "present-symbols" "external-symbols"]
+;; [&or "in" "of"] package-p]
+
+;; ;; Extensions for Emacs Lisp, including Lucid Emacs.
+;; [[&or "frame" "frames"
+;; "screen" "screens"
+;; "buffer" "buffers"]]
+
+;; [[&or "window" "windows"]
+;; [&or "of" "in"] form]
+
+;; [[&or "overlay" "overlays"
+;; "extent" "extents"]
+;; [&or "of" "in"] form
+;; &optional [[&or "from" "to"] form]]
+
+;; [[&or "interval" "intervals"]
+;; [&or "in" "of"] form
+;; &optional [[&or "from" "to"] form]
+;; ["property" form]]
+
+;; [[&or "key-code" "key-codes"
+;; "key-seq" "key-seqs"
+;; "key-binding" "key-bindings"]
+;; [&or "in" "of"] form
+;; &optional ["using" ([&or "key-code" "key-codes"
+;; "key-seq" "key-seqs"
+;; "key-binding" "key-bindings"]
+;; sexp)]]
+;; ;; For arbitrary extensions, recognize anything else.
+;; [symbolp &rest &or symbolp form]
+;; ]
+
+;; ;; arithmetic - must be last since all parts are optional.
+;; [[&optional [[&or "from" "downfrom" "upfrom"] form]]
+;; [&optional [[&or "to" "downto" "upto" "below" "above"] form]]
+;; [&optional ["by" form]]
+;; ]))
+
+;; (def-edebug-spec loop-initial-final
+;; (&or ["initially"
+;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this.
+;; &rest loop-non-atomic-expr]
+;; ["finally" &or
+;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr]
+;; ["return" form]]))
+
+;; (def-edebug-spec loop-and-clause
+;; (loop-clause &rest ["and" loop-clause]))
+
+;; (def-edebug-spec loop-clause
+;; (&or
+;; [[&or "while" "until" "always" "never" "thereis"] form]
+
+;; [[&or "collect" "collecting"
+;; "append" "appending"
+;; "nconc" "nconcing"
+;; "concat" "vconcat"] form
+;; [&optional ["into" loop-var]]]
+
+;; [[&or "count" "counting"
+;; "sum" "summing"
+;; "maximize" "maximizing"
+;; "minimize" "minimizing"] form
+;; [&optional ["into" loop-var]]
+;; loop-type-spec]
+
+;; [[&or "if" "when" "unless"]
+;; form loop-and-clause
+;; [&optional ["else" loop-and-clause]]
+;; [&optional "end"]]
+
+;; [[&or "do" "doing"] &rest loop-non-atomic-expr]
+
+;; ["return" form]
+;; loop-initial-final
+;; ))
+
+;; (def-edebug-spec loop-non-atomic-expr
+;; ([¬ atom] form))
+
+;; (def-edebug-spec loop-var
+;; ;; The symbolp must be last alternative to recognize e.g. (a b . c)
+;; ;; loop-var =>
+;; ;; (loop-var . [&or nil loop-var])
+;; ;; (symbolp . [&or nil loop-var])
+;; ;; (symbolp . loop-var)
+;; ;; (symbolp . (symbolp . [&or nil loop-var]))
+;; ;; (symbolp . (symbolp . loop-var))
+;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp)
+;; (&or (loop-var . [&or nil loop-var]) [gate symbolp]))
+
+;; (def-edebug-spec loop-type-spec
+;; (&optional ["of-type" loop-d-type-spec]))
+
+;; (def-edebug-spec loop-d-type-spec
+;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec))
+
+
+
(defun cl-parse-loop-clause () ; uses loop-*
(let ((word (pop loop-args))
(hash-types '(hash-key hash-keys hash-value hash-values))
"The Common Lisp `do' loop.
\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
+ (declare (indent 2)
+ (debug
+ ((&rest &or symbolp (symbolp &optional form form))
+ (form body)
+ cl-declarations body)))
(cl-expand-do-loop steps endtest body nil))
;;;###autoload
"The Common Lisp `do*' loop.
\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
+ (declare (indent 2) (debug do))
(cl-expand-do-loop steps endtest body t))
(defun cl-expand-do-loop (steps endtest body star)
"Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
+An implicit nil block is established around the loop.
\(fn (VAR LIST [RESULT]) BODY...)"
+ (declare (debug ((symbolp form &optional form) cl-declarations body)))
(let ((temp (make-symbol "--cl-dolist-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (car spec))
- (list* 'while temp (list 'setq (car spec) (list 'car temp))
- (append body (list (list 'setq temp
- (list 'cdr temp)))))
- (if (cdr (cdr spec))
- (cons (list 'setq (car spec) nil) (cdr (cdr spec)))
- '(nil))))))
+ ;; FIXME: Copy&pasted from subr.el.
+ `(block nil
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other is slightly faster (and has cleaner semantics)
+ ;; with lexical scoping.
+ ,(if lexical-binding
+ `(let ((,temp ,(nth 1 spec)))
+ (while ,temp
+ (let ((,(car spec) (car ,temp)))
+ ,@body
+ (setq ,temp (cdr ,temp))))
+ ,@(if (cdr (cdr spec))
+ ;; FIXME: This let often leads to "unused var" warnings.
+ `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
+ `(let ((,temp ,(nth 1 spec))
+ ,(car spec))
+ (while ,temp
+ (setq ,(car spec) (car ,temp))
+ ,@body
+ (setq ,temp (cdr ,temp)))
+ ,@(if (cdr (cdr spec))
+ `((setq ,(car spec) nil) ,@(cddr spec))))))))
;;;###autoload
(defmacro dotimes (spec &rest body)
nil.
\(fn (VAR COUNT [RESULT]) BODY...)"
- (let ((temp (make-symbol "--cl-dotimes-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
- (list* 'while (list '< (car spec) temp)
- (append body (list (list 'incf (car spec)))))
- (or (cdr (cdr spec)) '(nil))))))
+ (declare (debug dolist))
+ (let ((temp (make-symbol "--cl-dotimes-temp--"))
+ (end (nth 1 spec)))
+ ;; FIXME: Copy&pasted from subr.el.
+ `(block nil
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other has cleaner semantics.
+ ,(if lexical-binding
+ (let ((counter '--dotimes-counter--))
+ `(let ((,temp ,end)
+ (,counter 0))
+ (while (< ,counter ,temp)
+ (let ((,(car spec) ,counter))
+ ,@body)
+ (setq ,counter (1+ ,counter)))
+ ,@(if (cddr spec)
+ ;; FIXME: This let often leads to "unused var" warnings.
+ `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
+ `(let ((,temp ,end)
+ (,(car spec) 0))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (incf ,(car spec)))
+ ,@(cdr (cdr spec)))))))
;;;###autoload
(defmacro do-symbols (spec &rest body)
from OBARRAY.
\(fn (VAR [OBARRAY [RESULT]]) BODY...)"
+ (declare (indent 1)
+ (debug ((symbolp &optional form form) cl-declarations body)))
;; Apparently this doesn't have an implicit block.
(list 'block nil
(list 'let (list (car spec))
;;;###autoload
(defmacro do-all-symbols (spec &rest body)
+ (declare (indent 1) (debug ((symbolp &optional form) cl-declarations body)))
(list* 'do-symbols (list (car spec) nil (cadr spec)) body))
before assigning any symbols SYM to the corresponding values.
\(fn SYM VAL SYM VAL ...)"
+ (declare (debug setq))
(cons 'psetf args))
second list (or made unbound if VALUES is shorter than SYMBOLS); then the
BODY forms are executed and their result is returned. This is much like
a `let' form, except that the list of symbols can be computed at run-time."
+ (declare (indent 2) (debug (form form body)))
(list 'let '((cl-progv-save nil))
(list 'unwind-protect
(list* 'progn (list 'cl-progv-before symbols values) body)
go back to their previous definitions, or lack thereof).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
+ (declare (indent 1) (debug ((&rest (defun*)) cl-declarations body)))
(list* 'letf*
(mapcar
(function
Unlike `flet', this macro is fully compliant with the Common Lisp standard.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
+ (declare (indent 1) (debug flet))
(let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
(while bindings
;; Use `gensym' rather than `make-symbol'. It's important that
This is like `flet', but for macros instead of functions.
\(fn ((NAME ARGLIST BODY...) ...) FORM...)"
+ (declare (indent 1)
+ (debug
+ ((&rest (&define name (&rest arg) cl-declarations-or-string
+ def-body))
+ cl-declarations body)))
(if (cdr bindings)
(list 'macrolet
(list (car bindings)) (list* 'macrolet (cdr bindings) body))
by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
\(fn ((NAME EXPANSION) ...) FORM...)"
+ (declare (indent 1) (debug ((&rest (symbol sexp)) cl-declarations body)))
(if (cdr bindings)
(list 'symbol-macrolet
(list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
-\n(fn VARLIST BODY)"
+\n(fn BINDINGS BODY)"
+ (declare (indent 1) (debug let))
(let* ((cl-closure-vars cl-closure-vars)
(vars (mapcar (function
(lambda (x)
(cons 'progn body)
(nconc (mapcar (function (lambda (x)
(list (symbol-name (car x))
- (list 'symbol-value (caddr x))
+ (list 'symbol-value (caddr x))
t))) vars)
(list '(defun . cl-defun-expander))
cl-macro-environment))))
(if (not (get (car (last cl-closure-vars)) 'used))
- (list 'let (mapcar (function (lambda (x)
- (list (caddr x) (cadr x)))) vars)
- (sublis (mapcar (function (lambda (x)
- (cons (caddr x)
- (list 'quote (caddr x)))))
- vars)
- ebody))
+ ;; Turn (let ((foo (gensym))) (set foo <val>) ...(symbol-value foo)...)
+ ;; into (let ((foo <val>)) ...(symbol-value 'foo)...).
+ ;; This is good because it's more efficient but it only works with
+ ;; dynamic scoping, since with lexical scoping we'd need
+ ;; (let ((foo <val>)) ...foo...).
+ `(progn
+ ,@(mapcar (lambda (x) `(defvar ,(caddr x))) vars)
+ (let ,(mapcar (lambda (x) (list (caddr x) (cadr x))) vars)
+ ,(sublis (mapcar (lambda (x)
+ (cons (caddr x)
+ (list 'quote (caddr x))))
+ vars)
+ ebody)))
(list 'let (mapcar (function (lambda (x)
(list (caddr x)
(list 'make-symbol
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
-successive bindings within VARLIST, will create lexical closures
+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)"
+\n(fn BINDINGS BODY)"
+ (declare (indent 1) (debug let))
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
a synonym for (list A B C).
\(fn (SYM...) FORM BODY)"
+ (declare (indent 2) (debug ((&rest symbolp) form body)))
(let ((temp (make-symbol "--cl-var--")) (n -1))
(list* 'let* (cons (list temp form)
(mapcar (function
values. For compatibility, (values A B C) is a synonym for (list A B C).
\(fn (SYM...) FORM)"
+ (declare (indent 1) (debug ((&rest symbolp) form)))
(cond ((null vars) (list 'progn form nil))
((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
(t
;;; Declarations.
;;;###autoload
-(defmacro locally (&rest body) (cons 'progn body))
+(defmacro locally (&rest body)
+ (declare (debug t))
+ (cons 'progn body))
;;;###autoload
-(defmacro the (type form) form)
+(defmacro the (type form)
+ (declare (indent 1) (debug (cl-type-spec form)))
+ form)
(defvar cl-proclaim-history t) ; for future compilers
(defvar cl-declare-stack t) ; for future compilers
;;;###autoload
(defmacro declare (&rest specs)
+ "Declare SPECS about the current function while compiling.
+For instance
+
+ \(declare (warn 0))
+
+will turn off byte-compile warnings in the function.
+See Info node `(cl)Declarations' for details."
(if (cl-compiling-file)
(while specs
(if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
form. See `defsetf' for a simpler way to define most setf-methods.
\(fn NAME ARGLIST BODY...)"
+ (declare (debug
+ (&define name cl-lambda-list cl-declarations-or-string def-body)))
(append '(eval-when (compile load eval))
(if (stringp (car body))
(list (list 'put (list 'quote func) '(quote setf-documentation)
(defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
+ (declare (debug
+ (&define name
+ [&or [symbolp &optional stringp]
+ [cl-lambda-list (symbolp)]]
+ cl-declarations-or-string def-body)))
(if (and (listp arg1) (consp args))
(let* ((largs nil) (largsr nil)
(temps nil) (tempsr nil)
The return value is the last VAL in the list.
\(fn PLACE VAL PLACE VAL ...)"
+ (declare (debug (&rest [place form])))
(if (cdr (cdr args))
(let ((sets nil))
(while args (push (list 'setf (pop args) (pop args)) sets))
before assigning any PLACEs to the corresponding values.
\(fn PLACE VAL PLACE VAL ...)"
+ (declare (debug setf))
(let ((p args) (simple t) (vars nil))
(while p
(if (or (not (symbolp (car p))) (cl-expr-depends-p (nth 1 p) vars))
"Remove TAG from property list PLACE.
PLACE may be a symbol, or any generalized variable allowed by `setf'.
The form returns true if TAG was found and removed, nil otherwise."
+ (declare (debug (place form)))
(let* ((method (cl-setf-do-modify place t))
(tag-temp (and (not (cl-const-expr-p tag)) (make-symbol "--cl-remf-tag--")))
(val-temp (and (not (cl-simple-expr-p place))
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE... VAL)"
+ (declare (debug (&rest place)))
(cond
((null args) place)
((symbolp place) `(prog1 ,place (setq ,place (shiftf ,@args))))
Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
\(fn PLACE...)"
+ (declare (debug (&rest place)))
(if (not (memq nil (mapcar 'symbolp args)))
(and (cdr args)
(let ((sets nil)
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
+ (declare (indent 1) (debug ((&rest (gate place &optional form)) body)))
(if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
(list* 'let bindings body)
(let ((lets nil) (sets nil)
the PLACE is not modified before executing BODY.
\(fn ((PLACE VALUE) ...) BODY...)"
+ (declare (indent 1) (debug letf))
(if (null bindings)
(cons 'progn body)
(setq bindings (reverse bindings))
or any generalized variable allowed by `setf'.
\(fn FUNC PLACE ARGS...)"
+ (declare (indent 2) (debug (function* place &rest form)))
(let* ((method (cl-setf-do-modify place (cons 'list args)))
(rargs (cons (nth 2 method) args)))
(list 'let* (car method)
Like `callf', but PLACE is the second argument of FUNC, not the first.
\(fn FUNC ARG1 PLACE ARGS...)"
+ (declare (indent 3) (debug (function* form place &rest form)))
(if (and (cl-safe-expr-p arg1) (cl-simple-expr-p place) (symbolp func))
(list 'setf place (list* func arg1 place args))
(let* ((method (cl-setf-do-modify place (cons 'list args)))
"Define a `setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other arguments
from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
+ (declare (debug
+ (&define name cl-lambda-list ;; should exclude &key
+ symbolp &optional stringp)))
(if (memq '&key arglist) (error "&key not allowed in define-modify-macro"))
(let ((place (make-symbol "--cl-place--")))
(list 'defmacro* name (cons place arglist) doc
value, that slot cannot be set via `setf'.
\(fn NAME SLOTS...)"
+ (declare (debug
+ (&define ;Makes top-level form not be wrapped.
+ [&or symbolp
+ (gate
+ symbolp &rest
+ (&or [":conc-name" symbolp]
+ [":constructor" symbolp &optional cl-lambda-list]
+ [":copier" symbolp]
+ [":predicate" symbolp]
+ [":include" symbolp &rest sexp] ;; Not finished.
+ ;; The following are not supported.
+ ;; [":print-function" ...]
+ ;; [":type" ...]
+ ;; [":initial-offset" ...]
+ ))]
+ [&optional stringp]
+ ;; All the above is for the following def-form.
+ &rest &or symbolp (symbolp def-form
+ &optional ":read-only" sexp))))
(let* ((name (if (consp struct) (car struct) struct))
(opts (cdr-safe struct))
(slots nil)
(append
(and pred-check
(list (list 'or pred-check
- (list 'error
- (format "%s accessing a non-%s"
- accessor name)))))
+ `(error "%s accessing a non-%s"
+ ',accessor ',name))))
(list (if (eq type 'vector) (list 'aref 'cl-x pos)
(if (= pos 0) '(car cl-x)
(list 'nth pos 'cl-x)))))) forms)
(push (cons accessor t) side-eff)
(push (list 'define-setf-method accessor '(cl-x)
(if (cadr (memq :read-only (cddr desc)))
- (list 'error (format "%s is a read-only slot"
- accessor))
+ (list 'progn '(ignore cl-x)
+ `(error "%s is a read-only slot"
+ ',accessor))
;; If cl is loaded only for compilation,
;; the call to cl-struct-setf-expander would
;; cause a warning because it may not be
(push (cons name t) side-eff))))
(if print-auto (nconc print-func (list '(princ ")" cl-s) t)))
(if print-func
- (push (list 'push
- (list 'function
- (list 'lambda '(cl-x cl-s cl-n)
- (list 'and pred-form print-func)))
- 'custom-print-functions) forms))
+ (push `(push
+ ;; The auto-generated function does not pay attention to
+ ;; the depth argument cl-n.
+ (lambda (cl-x cl-s ,(if print-auto '_cl-n 'cl-n))
+ (and ,pred-form ,print-func))
+ custom-print-functions)
+ forms))
(push (list 'setq tag-symbol (list 'list (list 'quote tag))) forms)
(push (list* 'eval-when '(compile load eval)
(list 'put (list 'quote name) '(quote cl-struct-slots)
(defmacro deftype (name arglist &rest body)
"Define NAME as a new data type.
The type name can then be used in `typecase', `check-type', etc."
+ (declare (debug defmacro*))
(list 'eval-when '(compile load eval)
(cl-transform-function-property
name 'cl-deftype-handler (cons (list* '&cl-defs ''('*) arglist) body))))
(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."
+ (declare (debug (place cl-type-spec &optional stringp)))
(and (or (not (cl-compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let* ((temp (if (cl-simple-expr-p form 3)
Other args STRING and ARGS... are arguments to be passed to `error'.
They are not evaluated unless the assertion fails. If STRING is
omitted, a default message listing FORM itself is used."
+ (declare (debug (form &rest form)))
(and (or (not (cl-compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let ((sargs (and show-args
possible. Unlike regular macros, BODY can decide to \"punt\" and leave the
original function call alone by declaring an initial `&whole foo' parameter
and then returning foo."
+ (declare (debug defmacro*))
(let ((p args) (res nil))
(while (consp p) (push (pop p) res))
(setq args (nconc (nreverse res) (and p (list '&rest p)))))
(cl-transform-function-property
func 'cl-compiler-macro
(cons (if (memq '&whole args) (delq '&whole args)
- (cons '--cl-whole-arg-- args)) body))
+ (cons '_cl-whole-arg args)) body))
(list 'or (list 'get (list 'quote func) '(quote byte-compile))
(list 'progn
(list 'put (list 'quote func) '(quote byte-compile)
(byte-compile-normal-call form)
(byte-compile-form form)))
+;; Optimize away unused block-wrappers.
+
+(defvar cl-active-block-names nil)
+
+(define-compiler-macro cl-block-wrapper (cl-form)
+ (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
+ (cl-active-block-names (cons cl-entry cl-active-block-names))
+ (cl-body (macroexpand-all ;Performs compiler-macro expansions.
+ (cons 'progn (cddr cl-form))
+ macroexpand-all-environment)))
+ ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
+ ;; to indicate that this return value is already fully expanded.
+ (if (cdr cl-entry)
+ `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
+ cl-body)))
+
+(define-compiler-macro cl-block-throw (cl-tag cl-value)
+ (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names)))
+ (if cl-found (setcdr cl-found t)))
+ `(throw ,cl-tag ,cl-value))
+
;;;###autoload
(defmacro defsubst* (name args &rest body)
"Define NAME as a function.
surrounded by (block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
+ (declare (debug defun*))
(let* ((argns (cl-arglist-args args)) (p argns)
(pbody (cons 'progn body))
(unsafe (not (cl-safe-expr-p pbody))))