Mercurial > hg > xemacs-beta
diff lisp/cl-macs.el @ 5057:742b7a124d6c
Automated merge with file:///home/aidan/xemacs-21.5-checked-out
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Mon, 22 Feb 2010 20:09:23 +0000 |
parents | 6aba0daedb7c |
children | cc74f60c150e |
line wrap: on
line diff
--- a/lisp/cl-macs.el Sun Feb 21 23:20:44 2010 -0500 +++ b/lisp/cl-macs.el Mon Feb 22 20:09:23 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)