X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbackq.lisp;h=0e7896d87a414ea0e23ab3b6c25d28c46bbdda5f;hb=5bad55941fafc315116f6fcf2c8c2cce8af7ed9a;hp=c601ee4198a851eb05f1b068092ff30591257eca;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/backq.lisp b/src/code/backq.lisp
index c601ee4..0e7896d 100644
--- a/src/code/backq.lisp
+++ b/src/code/backq.lisp
@@ -11,6 +11,8 @@
 
 (in-package "SB!IMPL")
 
+(/show0 "entering backq.lisp")
+
 ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
 ;;;
 ;;;   |`,|: [a] => a
@@ -26,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
@@ -45,17 +47,21 @@
 (defvar *bq-dot-flag* '(|,.|))
 (defvar *bq-vector-flag* '(|bqv|))
 
+(/show0 "backq.lisp 50")
+
 ;;; the actual character macro
 (defun backquote-macro (stream ignore)
   (declare (ignore ignore))
   (let ((*backquote-count* (1+ *backquote-count*)))
     (multiple-value-bind (flag thing)
 	(backquotify stream (read stream t nil t))
-      (if (eq flag *bq-at-flag*)
-	  (%reader-error stream ",@ after backquote in ~S" thing))
-      (if (eq flag *bq-dot-flag*)
-	  (%reader-error stream ",. after backquote in ~S" thing))
-      (values (backquotify-1 flag thing) 'list))))
+      (when (eq flag *bq-at-flag*)
+	(%reader-error stream ",@ after backquote in ~S" thing))
+      (when (eq flag *bq-dot-flag*)
+	(%reader-error stream ",. after backquote in ~S" thing))
+      (backquotify-1 flag thing))))
+
+(/show0 "backq.lisp 64")
 
 (defun comma-macro (stream ignore)
   (declare (ignore ignore))
@@ -65,24 +71,31 @@
     (%reader-error stream "comma not inside a backquote"))
   (let ((c (read-char stream))
 	(*backquote-count* (1- *backquote-count*)))
-    (values
-     (cond ((char= c #\@)
-	    (cons *bq-at-flag* (read stream t nil t)))
-	   ((char= c #\.)
-	    (cons *bq-dot-flag* (read stream t nil t)))
-	   (t (unread-char c stream)
-	      (cons *bq-comma-flag* (read stream t nil t))))
-     'list)))
+    (cond ((char= c #\@)
+	   (cons *bq-at-flag* (read stream t nil t)))
+	  ((char= c #\.)
+	   (cons *bq-dot-flag* (read stream t nil t)))
+	  (t (unread-char c stream)
+	     (cons *bq-comma-flag* (read stream t nil t))))))
+
+(/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)))
@@ -93,22 +106,26 @@
 	   (values 'vector (backquotify-1 dflag d))))
 	(t (multiple-value-bind (aflag a) (backquotify stream (car code))
 	     (multiple-value-bind (dflag d) (backquotify stream (cdr code))
-	       (if (eq dflag *bq-at-flag*)
-		   ;; Get the errors later.
-		   (%reader-error stream ",@ after dot in ~S" code))
-	       (if (eq dflag *bq-dot-flag*)
-		   (%reader-error stream ",. after dot in ~S" code))
+	       (when (eq dflag *bq-at-flag*)
+		 ;; Get the errors later.
+		 (%reader-error stream ",@ after dot in ~S" code))
+	       (when (eq dflag *bq-dot-flag*)
+		 (%reader-error stream ",. after dot in ~S" code))
 	       (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))
@@ -128,22 +145,27 @@
 		       (values 'list*
 			       (list a (backquotify-1 dflag d)))))))))))
 
+(/show0 "backq.lisp 139")
+
 ;;; This handles the <hair> cases.
 (defun comma (code)
   (cond ((atom code)
 	 (cond ((null code)
 		(values nil nil))
-	       ((or (numberp code) (eq code 't))
+	       ((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)
 	 (values 'list* (cdr code)))
 	(t (values *bq-comma-flag* code))))
 
+(/show0 "backq.lisp 157")
+
 ;;; This handles table 1.
 (defun backquotify-1 (flag thing)
   (cond ((or (eq flag *bq-comma-flag*)
@@ -152,26 +174,32 @@
 	((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))
-	(t (cons (cdr
-		  (assoc flag
-			 '((cons . backq-cons)
-			   (list . backq-list)
-			   (append . backq-append)
-			   (nconc . backq-nconc))
-			 :test #'equal))
+	(t (cons (ecase flag
+		   ((list) 'backq-list)
+		   ((append) 'backq-append)
+		   ((nconc) 'backq-nconc))
 		 thing))))
 
 ;;;; magic BACKQ- versions of builtin functions
 
-;;; Define synonyms for the lisp functions we use, so that by using them, we
-;;; backquoted material will be recognizable to the pretty-printer.
-(macrolet ((def-frob (b-name name)
+(/show0 "backq.lisp 184")
+
+;;; Define synonyms for the lisp functions we use, so that by using
+;;; them, the backquoted material will be recognizable to the
+;;; pretty-printer.
+(macrolet ((def (b-name name)
 	     (let ((args (gensym "ARGS")))
 	       ;; FIXME: This function should be INLINE so that the lists
 	       ;; aren't consed twice, but I ran into an optimizer bug the
@@ -179,12 +207,15 @@
 	       ;; whether there's still an optimizer bug, and fix it if so, and
 	       ;; then make these INLINE.
 	       `(defun ,b-name (&rest ,args)
+                  (declare (dynamic-extent ,args))
 		  (apply #',name ,args)))))
-  (def-frob backq-list list)
-  (def-frob backq-list* list*)
-  (def-frob backq-append append)
-  (def-frob backq-nconc nconc)
-  (def-frob backq-cons cons))
+  (def backq-list list)
+  (def backq-list* list*)
+  (def backq-append append)
+  (def backq-nconc nconc)
+  (def backq-cons cons))
+
+(/show0 "backq.lisp 204")
 
 (defun backq-vector (list)
   (declare (list list))
@@ -192,18 +223,36 @@
 
 ;;;; initialization
 
+(/show0 "backq.lisp 212")
+
 ;;; Install BACKQ stuff in the current *READTABLE*.
 ;;;
-;;; In the target Lisp, we have to wait to do this until the readtable has been
-;;; created. In the cross-compilation host Lisp, we can do this right away.
-;;; (You may ask: In the cross-compilation host, which already has its own
-;;; implementation of the backquote readmacro, why do we do this at all?
-;;; Because the cross-compilation host might -- as SBCL itself does -- express
-;;; the backquote expansion in terms of internal, nonportable functions. By
-;;; redefining backquote in terms of functions which are guaranteed to exist on
-;;; the target Lisp, we ensure that backquote expansions in code-generating
-;;; code work properly.)
+;;; In the target Lisp, we have to wait to do this until the readtable
+;;; has been created. In the cross-compilation host Lisp, we can do
+;;; this right away. (You may ask: In the cross-compilation host,
+;;; which already has its own implementation of the backquote
+;;; readmacro, why do we do this at all? Because the cross-compilation
+;;; host might -- as SBCL itself does -- express the backquote
+;;; expansion in terms of internal, nonportable functions. By
+;;; redefining backquote in terms of functions which are guaranteed to
+;;; exist on the target Lisp, we ensure that backquote expansions in
+;;; code-generating code work properly.)
 (defun !backq-cold-init ()
   (set-macro-character #\` #'backquote-macro)
   (set-macro-character #\, #'comma-macro))
 #+sb-xc-host (!backq-cold-init)
+
+;;; The pretty-printer needs to know about our special tokens
+(defvar *backq-tokens*
+  '(backq-comma backq-comma-at backq-comma-dot backq-list
+    backq-list* backq-append backq-nconc backq-cons backq-vector))
+
+;;; Since our backquote is installed on the host lisp, and since
+;;; developers make mistakes with backquotes and commas too, let's
+;;; ensure that we can report errors rather than get an undefined
+;;; function condition on %READER-ERROR.
+#+sb-xc-host ; proper definition happens for the target
+(defun %reader-error (stream format-string &rest format-args)
+  (bug "READER-ERROR on stream ~S: ~?" stream format-string format-args))
+
+(/show0 "done with backq.lisp")