X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbackq.lisp;h=6b615f39527a5d209bf5bf5d88250b0e00641f5a;hb=HEAD;hp=4c13b437b737705d1fc8b99ba2babb2e890a3086;hpb=f4f423b699b25a78e70fb990ca3a434f3e2cbba2;p=sbcl.git

diff --git a/src/code/backq.lisp b/src/code/backq.lisp
index 4c13b43..6b615f3 100644
--- a/src/code/backq.lisp
+++ b/src/code/backq.lisp
@@ -16,8 +16,8 @@
 ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
 ;;;
 ;;;   |`,|: [a] => a
-;;;    NIL: [a] => a		;the NIL flag is used only when a is NIL
-;;;      T: [a] => a		;the T flag is used when a is self-evaluating
+;;;    NIL: [a] => a            ;the NIL flag is used only when a is NIL
+;;;      T: [a] => a            ;the T flag is used when a is self-evaluating
 ;;;  QUOTE: [a] => (QUOTE a)
 ;;; APPEND: [a] => (APPEND . a)
 ;;;  NCONC: [a] => (NCONC . a)
@@ -46,6 +46,7 @@
 (defvar *bq-at-flag* '(|,@|))
 (defvar *bq-dot-flag* '(|,.|))
 (defvar *bq-vector-flag* '(|bqv|))
+(defvar *bq-error* "Comma not inside a backquote.")
 
 (/show0 "backq.lisp 50")
 
@@ -54,12 +55,12 @@
   (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))))
+        (backquotify stream (read stream t nil t))
+      (when (eq flag *bq-at-flag*)
+        (simple-reader-error stream ",@ after backquote in ~S" thing))
+      (when (eq flag *bq-dot-flag*)
+        (simple-reader-error stream ",. after backquote in ~S" thing))
+      (backquotify-1 flag thing))))
 
 (/show0 "backq.lisp 64")
 
@@ -68,17 +69,24 @@
   (unless (> *backquote-count* 0)
     (when *read-suppress*
       (return-from comma-macro nil))
-    (%reader-error stream "comma not inside a backquote"))
+    (simple-reader-error stream *bq-error*))
   (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)))
+        (*backquote-count* (1- *backquote-count*)))
+    (flet ((check (what)
+             (let ((x (peek-char t stream t nil t)))
+               (when (and (char= x #\)) (eq #'read-right-paren (get-macro-character #\))))
+                 ;; Easier to figure out than an "unmatched parenthesis".
+                 (simple-reader-error stream "Trailing ~A in backquoted expression." what)))))
+      (cond ((char= c #\@)
+             (check "comma-at")
+             (cons *bq-at-flag* (read stream t nil t)))
+            ((char= c #\.)
+             (check "comma-dot")
+             (cons *bq-dot-flag* (read stream t nil t)))
+            (t
+             (unread-char c stream)
+             (check "comma")
+             (cons *bq-comma-flag* (read stream t nil t)))))))
 
 (/show0 "backq.lisp 83")
 
@@ -89,113 +97,116 @@
          (or (eq flag *bq-at-flag*)
              (eq flag *bq-dot-flag*)))))
 
+(defun backquote-splice (method dflag a d what stream)
+  (cond (dflag
+         (values method
+                 (cond ((eq dflag method)
+                        (cons a d))
+                       (t (list a (backquotify-1 dflag d))))))
+        ((expandable-backq-expression-p a)
+         (values method (list a)))
+        ((not (and (atom a) (backq-constant-p a)))
+         ;; COMMA special cases a few constant atoms, which
+         ;; are illegal in splices.
+         (comma a))
+        (t
+         (simple-reader-error stream "Invalid splice in backquote: ~A~A" what a))))
+
 ;;; This does the expansion from table 2.
 (defun backquotify (stream code)
   (cond ((atom code)
-	 (cond ((null code) (values nil nil))
-	       ((or (consp code)
+         (cond ((null code) (values nil nil))
+               ((or (consp code)
                     (symbolp code))
-		;; Keywords are self-evaluating. Install after packages.
+                ;; Keywords are self-evaluating. Install after packages.
                 (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)))
-	((eq (car code) *bq-comma-flag*)
-	 (comma (cdr code)))
-	((eq (car code) *bq-vector-flag*)
-	 (multiple-value-bind (dflag d) (backquotify stream (cdr code))
-	   (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))
-	       (cond
-		((eq aflag *bq-at-flag*)
-		 (if (null dflag)
-		     (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)
-		     (if (expandable-backq-expression-p a)
-                         (values 'nconc (list a))
-                         (comma a))
-		     (values 'nconc
-			     (cond ((eq dflag 'nconc)
-				    (cons a d))
-				   (t (list a (backquotify-1 dflag d)))))))
-		((null dflag)
-		 (if (member aflag '(quote t nil))
-		     (values 'quote (list a))
-		     (values 'list (list (backquotify-1 aflag a)))))
-		((member dflag '(quote t))
-		 (if (member aflag '(quote t nil))
-		     (values 'quote (cons a d ))
-		     (values 'list* (list (backquotify-1 aflag a)
-					  (backquotify-1 dflag d)))))
-		(t (setq a (backquotify-1 aflag a))
-		   (if (member dflag '(list list*))
-		       (values dflag (cons a d))
-		       (values 'list*
-			       (list a (backquotify-1 dflag d)))))))))))
+               (t (values t code))))
+        ((or (eq (car code) *bq-at-flag*)
+             (eq (car code) *bq-dot-flag*))
+         (values (car code) (cdr code)))
+        ((eq (car code) *bq-comma-flag*)
+         (comma (cdr code)))
+        ((eq (car code) *bq-vector-flag*)
+         (multiple-value-bind (dflag d) (backquotify stream (cdr code))
+           (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))
+               (when (eq dflag *bq-at-flag*)
+                 ;; Get the errors later.
+                 (simple-reader-error stream ",@ after dot in ~S" code))
+               (when (eq dflag *bq-dot-flag*)
+                 (simple-reader-error stream ",. after dot in ~S" code))
+               (cond
+                ((eq aflag *bq-at-flag*)
+                 (backquote-splice 'append dflag a d ",@" stream))
+                ((eq aflag *bq-dot-flag*)
+                 (backquote-splice 'nconc dflag a d ",." stream))
+                ((null dflag)
+                 (if (member aflag '(quote t nil))
+                     (values 'quote (list a))
+                     (values 'list (list (backquotify-1 aflag a)))))
+                ((member dflag '(quote t))
+                 (if (member aflag '(quote t nil))
+                     (values 'quote (cons a d ))
+                     (values 'list* (list (backquotify-1 aflag a)
+                                          (backquotify-1 dflag d)))))
+                (t (setq a (backquotify-1 aflag a))
+                   (if (member dflag '(list list*))
+                       (values dflag (cons a d))
+                       (values 'list*
+                               (list a (backquotify-1 dflag d)))))))))))
 
 (/show0 "backq.lisp 139")
 
+(defun backq-constant-p (x)
+  (or (numberp x) (eq x t)))
+
 ;;; This handles the <hair> cases.
 (defun comma (code)
   (cond ((atom code)
-	 (cond ((null code)
-		(values nil nil))
-	       ((or (numberp code) (eq code t))
-		(values t code))
-	       (t (values *bq-comma-flag* code))))
-	((and (eq (car code) 'quote)
+         (cond ((null code)
+                (values nil nil))
+               ((backq-constant-p code)
+                (values t code))
+               (t
+                (values *bq-comma-flag* 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))))
+        ((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*)
-	     (member flag '(t nil)))
-	 thing)
-	((eq flag 'quote)
-	 (list  'quote thing))
-	((eq flag 'list*)
+             (member flag '(t nil)))
+         thing)
+        ((eq flag 'quote)
+         (list  'quote thing))
+        ((eq flag 'list*)
          (cond ((and (null (cddr thing))
+                     (not (expandable-backq-expression-p (car thing)))
                      (not (expandable-backq-expression-p (cadr thing))))
-		(cons 'backq-cons thing))
-	       ((expandable-backq-expression-p (car (last thing)))
+                (cons 'backq-cons thing))
+               ((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))
-		 thing))))
+                (cons 'backq-list* thing))))
+        ((eq flag 'vector)
+         (list 'backq-vector thing))
+        (t (cons (ecase flag
+                   ((list) 'backq-list)
+                   ((append) 'backq-append)
+                   ((nconc) 'backq-nconc))
+                 thing))))
 
 ;;;; magic BACKQ- versions of builtin functions
 
@@ -204,20 +215,20 @@
 ;;; 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-frob (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
-	       ;; first time I tried to make this work for BACKQ-LIST. See
-	       ;; whether there's still an optimizer bug, and fix it if so, and
-	       ;; then make these INLINE.
-	       `(defun ,b-name (&rest ,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))
+(macrolet ((def (b-name name)
+               ;; FIXME: This function should be INLINE so that the lists
+               ;; aren't consed twice, but I ran into an optimizer bug the
+               ;; first time I tried to make this work for BACKQ-LIST. See
+               ;; whether there's still an optimizer bug, and fix it if so, and
+               ;; then make these INLINE.
+               `(defun ,b-name (&rest rest)
+                  (declare (truly-dynamic-extent rest))
+                  (apply #',name rest))))
+  (def backq-list list)
+  (def backq-list* list*)
+  (def backq-append append)
+  (def backq-nconc nconc)
+  (def backq-cons cons))
 
 (/show0 "backq.lisp 204")
 
@@ -246,4 +257,17 @@
   (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 SIMPLE-READER-ERROR.
+#+sb-xc-host ; proper definition happens for the target
+(defun simple-reader-error (stream format-string &rest format-args)
+  (bug "READER-ERROR on stream ~S: ~?" stream format-string format-args))
+
 (/show0 "done with backq.lisp")