(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")
(multiple-value-bind (flag thing)
(backquotify stream (read stream t nil t))
(when (eq flag *bq-at-flag*)
- (%reader-error stream ",@ after backquote in ~S" thing))
+ (simple-reader-error stream ",@ after backquote in ~S" thing))
(when (eq flag *bq-dot-flag*)
- (%reader-error stream ",. after backquote in ~S" thing))
+ (simple-reader-error stream ",. after backquote in ~S" thing))
(backquotify-1 flag thing))))
(/show0 "backq.lisp 64")
(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*)))
- (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")
(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)
(multiple-value-bind (dflag d) (backquotify stream (cdr code))
(when (eq dflag *bq-at-flag*)
;; Get the errors later.
- (%reader-error stream ",@ after dot in ~S" code))
+ (simple-reader-error stream ",@ after dot in ~S" code))
(when (eq dflag *bq-dot-flag*)
- (%reader-error stream ",. after dot in ~S" code))
+ (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))
(/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)))
(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)))
;;; 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 (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)
;;; 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.
+;;; function condition on SIMPLE-READER-ERROR.
#+sb-xc-host ; proper definition happens for the target
-(defun %reader-error (stream format-string &rest format-args)
+(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")
projects / sbcl.git / blobdiff