Mercurial > hg > xemacs-beta

diff lisp/cl-extra.el @ 5075:868a9ffcc37b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Normally return a compiled function if one argument, #'constantly. 2010-02-24 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (constantly): Normally return a compiled function from #'constantly if we are handed a single argument. Shouldn't actually matter, the overhead for returning a single constant in a lambda form vs. in a compiled function is minuscule, but using compiled functions as much as possible is good style in XEmacs, our interpreter is not stellar (nor indeed should it need to be).
author Aidan Kehoe <kehoea@parhasard.net>
date Wed, 24 Feb 2010 17:17:13 +0000
parents 6aba0daedb7c
children 41262f87eb39
line wrap: on
line diff
--- a/lisp/cl-extra.el	Wed Feb 24 15:45:20 2010 +0100
+++ b/lisp/cl-extra.el	Wed Feb 24 17:17:13 2010 +0000
@@ -612,9 +612,7 @@
 	  ((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).
+;; See also the compiler macro in cl-macs.el.
 (defun constantly (value &rest more-values)
   "Construct a function always returning VALUE, and possibly MORE-VALUES.
 
@@ -622,7 +620,24 @@
 
 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))))
+  (symbol-macrolet
+      ((arglist '(&rest ignore)))
+    (if (or more-values (eval-when-compile (not (cl-compiling-file))))
+        `(lambda ,arglist (values-list ',(cons value more-values)))
+      (make-byte-code
+       arglist
+       (eval-when-compile
+         (let ((compiled (byte-compile-sexp #'(lambda (&rest ignore)
+                                                (declare (ignore ignore))
+                                                'placeholder))))
+           (assert (and
+                    (equal [placeholder]
+                           (compiled-function-constants compiled))
+                    (= 1 (compiled-function-stack-depth compiled)))
+		   t
+		   "Our assumptions about compiled code appear not to hold.")
+           (compiled-function-instructions compiled)))
+       (vector value) 1))))
 
 ;;; Hash tables.