0.8.21.6:

[sbcl.git] / src / code / backq.lisp

diff --git a/src/code/backq.lisp b/src/code/backq.lisp
index 1a30b5d..0e7896d 100644 (file)
--- a/src/code/backq.lisp
+++ b/src/code/backq.lisp
@@ -55,11 +55,11 @@
   (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")
 
@@ -71,14 +71,12 @@
     (%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")
 
@@ -108,11 +106,11 @@
           (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)
@@ -188,13 +186,10 @@
                (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))))
 \f
 ;;;; magic BACKQ- versions of builtin functions
@@ -212,6 +207,7 @@
               ;; 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 backq-list list)
   (def backq-list* list*)
@@ -246,4 +242,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 %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")