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)