--- a/lisp/ChangeLog	Fri Feb 19 23:46:53 2010 +0000
+++ b/lisp/ChangeLog	Mon Feb 22 20:08:51 2010 +0000
@@ -1,3 +1,14 @@
+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.
+
 2010-02-08  Ben Wing  <ben@xemacs.org>
 
 	* help.el (describe-function-1):

--- a/lisp/cl-extra.el	Fri Feb 19 23:46:53 2010 +0000
+++ b/lisp/cl-extra.el	Mon Feb 22 20:08:51 2010 +0000
@@ -612,6 +612,17 @@
 	  ((memq (car plst) indicator-list)
 	   (return (values (car plst) (cadr plst) plst))))))
 
+;; See our compiler macro in cl-macs.el, we will only pass back the
+;; actual lambda list in interpreted code or if we've been funcalled
+;; (from #'apply or #'mapcar or whatever).
+(defun constantly (value &rest more-values)
+  "Construct a function always returning VALUE, and possibly MORE-VALUES.
+
+The constructed function accepts any number of arguments, and ignores them.
+
+Members of MORE-VALUES, if provided, will be passed as multiple values; see
+`multiple-value-bind' and `multiple-value-setq'."
+  `(lambda (&rest ignore) (values-list ',(cons value more-values))))
 
 ;;; Hash tables.
 

--- 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)