Mercurial > hg > xemacs-beta
diff lisp/cl-macs.el @ 5056:6aba0daedb7c
Add #'constantly, as specified by ANSI Common Lisp.
2010-02-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (constantly):
Add this function, from ANSI Common Lisp, using the SBCL extension
that extra arguments to it are passed back as multiple values in
the constructed function.
* cl-macs.el (constantly):
In the compiler macro for #'constantly, construct a
compiled-function object almost every time, at compile time when
all arguments are constant, and at runtime when they vary.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 22 Feb 2010 20:08:51 +0000 |
| parents | 8800b5350a13 |
| children | cc74f60c150e |
line wrap: on
line diff
--- a/lisp/cl-macs.el Fri Feb 19 23:46:53 2010 +0000 +++ b/lisp/cl-macs.el Mon Feb 22 20:08:51 2010 +0000 @@ -3551,6 +3551,41 @@ (define-compiler-macro notevery (&whole form &rest cl-rest) (cons 'not (cons 'every (cdr cl-rest)))) +(define-compiler-macro constantly (&whole form value &rest more-values) + (cond + ((< (length form) 2) + ;; Error at runtime: + form) + ((cl-const-exprs-p (cdr form)) + `#'(lambda (&rest ignore) (values ,@(cdr form)))) + (t + (let* ((num-values (length (cdr form))) + (placeholders-counts (make-vector num-values -1)) + (placeholders (loop + for i from 0 below num-values + collect (make-symbol (format "%d" i)))) + (compiled + (byte-compile-sexp + `#'(lambda (&rest ignore) + ;; Compiles to a references into the compiled function + ;; constants vector: + (values ,@(mapcar #'quote-maybe placeholders))))) + position) + `(make-byte-code '(&rest ignore) + ,(compiled-function-instructions compiled) + (vector ,@(loop + for constant across (compiled-function-constants compiled) + collect (if (setq position + (position constant placeholders)) + (prog2 + (incf (aref placeholders-counts position)) + (nth position (cdr form))) + (quote-maybe constant)) + finally + (assert (every #'zerop placeholders-counts) + t "Placeholders should each have been used once"))) + ,(compiled-function-stack-depth compiled)))))) + (mapc #'(lambda (y) (put (car y) 'side-effect-free t)