X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=9e4d3b441e54e3d576b5aa4e59fe150886414892;hb=2b69e4fdba7249fb494635bf78bb3595e34c1eb7;hp=0b52e48c455bd6ef9fae87518990b7aba16f9063;hpb=87c62dadeba82095c672161e30a3611016d270fb;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 0b52e48..9e4d3b4 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1150,7 +1150,7 @@
 ;;; practice.
 ;;;
 ;;; Limit full open coding based on length of constant sequences. Default
-;;; value is chosen so that other parts of to compiler (constraint propagation
+;;; value is chosen so that other parts of the compiler (constraint propagation
 ;;; mainly) won't go nonlinear too badly. It's not an exact number -- but
 ;;; in the right ballpark.
 (defvar *concatenate-open-code-limit* 129)
@@ -1615,3 +1615,74 @@
   (define-trimmer-transform string-right-trim nil t)
   (define-trimmer-transform string-trim t t))
 
+
+;;; (partially) constant-fold backq-* functions, or convert to their
+;;; plain CL equivalent (now that they're not needed for pprinting).
+
+;; Pop constant values from the end, list/list* them if any, and link
+;; the remainder with list* at runtime.
+(defun transform-backq-list-or-list* (function values)
+  (let ((gensyms (make-gensym-list (length values)))
+        (reverse (reverse values))
+        (constants '()))
+    (loop while (and reverse
+                     (constant-lvar-p (car reverse)))
+          do (push (lvar-value (pop reverse))
+                   constants))
+    (if (null constants)
+        `(lambda ,gensyms
+           (,function ,@gensyms))
+        (let ((tail (apply function constants)))
+          (if (null reverse)
+              `',tail
+              (let* ((nvariants (length reverse))
+                     (variants (subseq gensyms 0 nvariants)))
+                `(lambda ,gensyms
+                   (declare (ignore ,@(subseq gensyms nvariants)))
+                   ,(if tail
+                        `(list* ,@variants ',tail)
+                        `(list ,@variants)))))))))
+
+(deftransform sb!impl::backq-list ((&rest elts))
+  (transform-backq-list-or-list* 'list elts))
+
+(deftransform sb!impl::backq-list* ((&rest elts))
+  (transform-backq-list-or-list* 'list* elts))
+
+;; Merge adjacent constant values
+(deftransform sb!impl::backq-append ((&rest elts))
+  (let ((gensyms (make-gensym-list (length elts)))
+        (acc nil)
+        (ignored '())
+        (arguments '()))
+    (flet ((convert-accumulator ()
+             (let ((constant (apply 'append (nreverse (shiftf acc nil)))))
+               (when constant
+                 (push `',constant arguments)))))
+      (loop for gensym in gensyms
+            for (elt . next) on elts by #'cdr
+            do (cond ((constant-lvar-p elt)
+                      (let ((elt (lvar-value elt)))
+                        (when (and next (not (proper-list-p elt)))
+                          (abort-ir1-transform
+                           "Non-list or improper list spliced in ~
+                            the middle of a backquoted list."))
+                        (push gensym ignored)
+                        (push elt acc)))
+                     (t
+                      (convert-accumulator)
+                      (push gensym arguments)))
+            finally (convert-accumulator)))
+    (let ((arguments (nreverse arguments)))
+      `(lambda ,gensyms
+         (declare (ignore ,@ignored))
+         (append ,@arguments)))))
+
+;; Nothing special for nconc
+(define-source-transform sb!impl::backq-nconc (&rest elts)
+  `(nconc ,@elts))
+
+;; cons and vector are handled with regular constant folding...
+;; but we still want to convert backq-cons into cl:cons.
+(deftransform sb!impl::backq-cons ((x y))
+  `(cons x y))