X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbackq.lisp;h=4c13b437b737705d1fc8b99ba2babb2e890a3086;hb=90ca09b75fbc3b63b2f7d09c67b04b866dd783f6;hp=acc783918cd3f352e05dd074083d6523cbe5828d;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git

diff --git a/src/code/backq.lisp b/src/code/backq.lisp
index acc7839..4c13b43 100644
--- a/src/code/backq.lisp
+++ b/src/code/backq.lisp
@@ -28,7 +28,7 @@
 ;;;  ([a] means that a should be converted according to the previous table)
 ;;;
 ;;;   \ car  ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|
-;;;cdr \     ||		 |    T or NIL     |		|
+;;;cdr \     ||                 |    T or NIL     |                |
 ;;;================================================================================
 ;;;  |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d])
 ;;;  NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a
@@ -82,15 +82,22 @@
 
 (/show0 "backq.lisp 83")
 
+;;;
+(defun expandable-backq-expression-p (object)
+  (and (consp object)
+       (let ((flag (car object)))
+         (or (eq flag *bq-at-flag*)
+             (eq flag *bq-dot-flag*)))))
+
 ;;; This does the expansion from table 2.
 (defun backquotify (stream code)
   (cond ((atom code)
 	 (cond ((null code) (values nil nil))
-	       ((or (numberp code)
-		    (eq code t))
+	       ((or (consp code)
+                    (symbolp code))
 		;; Keywords are self-evaluating. Install after packages.
-		(values t code))
-	       (t (values 'quote code))))
+                (values 'quote code))
+	       (t (values t code))))
 	((or (eq (car code) *bq-at-flag*)
 	     (eq (car code) *bq-dot-flag*))
 	 (values (car code) (cdr code)))
@@ -109,14 +116,18 @@
 	       (cond
 		((eq aflag *bq-at-flag*)
 		 (if (null dflag)
-		     (comma a)
+		     (if (expandable-backq-expression-p a)
+                         (values 'append (list a))
+                         (comma a))
 		     (values 'append
 			     (cond ((eq dflag 'append)
 				    (cons a d ))
 				   (t (list a (backquotify-1 dflag d)))))))
 		((eq aflag *bq-dot-flag*)
 		 (if (null dflag)
-		     (comma a)
+		     (if (expandable-backq-expression-p a)
+                         (values 'nconc (list a))
+                         (comma a))
 		     (values 'nconc
 			     (cond ((eq dflag 'nconc)
 				    (cons a d))
@@ -146,8 +157,9 @@
 	       ((or (numberp code) (eq code t))
 		(values t code))
 	       (t (values *bq-comma-flag* code))))
-	((eq (car code) 'quote)
-	 (values (car code) (cadr code)))
+	((and (eq (car code) 'quote)
+              (not (expandable-backq-expression-p (cadr code))))
+         (values (car code) (cadr code)))
 	((member (car code) '(append list list* nconc))
 	 (values (car code) (cdr code)))
 	((eq (car code) 'cons)
@@ -164,9 +176,15 @@
 	((eq flag 'quote)
 	 (list  'quote thing))
 	((eq flag 'list*)
-	 (cond ((null (cddr thing))
+         (cond ((and (null (cddr thing))
+                     (not (expandable-backq-expression-p (cadr thing))))
 		(cons 'backq-cons thing))
-	       (t
+	       ((expandable-backq-expression-p (car (last thing)))
+                (list 'backq-append
+                      (cons 'backq-list (butlast thing))
+                      ;; Can it be optimized further? -- APD, 2001-12-21
+                      (car (last thing))))
+               (t
 		(cons 'backq-list* thing))))
 	((eq flag 'vector)
 	 (list 'backq-vector thing))