gencgc: More precise conservatism for pointers to boxed pages.

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

diff --git a/src/code/backq.lisp b/src/code/backq.lisp
index d9c8c00..6b615f3 100644 (file)
--- a/src/code/backq.lisp
+++ b/src/code/backq.lisp
@@ -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")
 
@@ -68,15 +69,24 @@
   (unless (> *backquote-count* 0)
     (when *read-suppress*
       (return-from comma-macro nil))
-    (simple-reader-error stream "comma not inside a backquote"))
+    (simple-reader-error stream *bq-error*))
   (let ((c (read-char stream))
         (*backquote-count* (1- *backquote-count*)))
-    (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))))))
+    (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")
 
@@ -87,6 +97,21 @@
          (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)
@@ -113,23 +138,9 @@
                  (simple-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)))))))
+                 (backquote-splice 'append dflag a d ",@" stream))
                 ((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)))))))
+                 (backquote-splice 'nconc dflag a d ",." stream))
                 ((null dflag)
                  (if (member aflag '(quote t nil))
                      (values 'quote (list a))
@@ -147,14 +158,18 @@
 
 (/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))
+               ((backq-constant-p code)
                 (values t code))
-               (t (values *bq-comma-flag* code))))
+               (t
+                (values *bq-comma-flag* code))))
         ((and (eq (car code) 'quote)
               (not (expandable-backq-expression-p (cadr code))))
          (values (car code) (cadr code)))
@@ -201,15 +216,14 @@
 ;;; 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
                ;; 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)
-                  (declare (truly-dynamic-extent ,args))
-                  (apply #',name ,args)))))
+               `(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)