X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbackq.lisp;h=6b615f39527a5d209bf5bf5d88250b0e00641f5a;hb=HEAD;hp=cd418aa40e4ed3a82f442ae13840c3a9f68faee7;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/backq.lisp b/src/code/backq.lisp index cd418aa..6b615f3 100644 --- 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") @@ -56,9 +57,9 @@ (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") @@ -68,15 +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*))) - (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) @@ -108,28 +133,14 @@ (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)) @@ -147,14 +158,18 @@ (/show0 "backq.lisp 139") +(defun backq-constant-p (x) + (or (numberp x) (eq x t))) + ;;; This handles the 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))) @@ -175,6 +190,7 @@ (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))) @@ -200,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 (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) @@ -250,9 +265,9 @@ ;;; 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")