X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbackq.lisp;h=32cbdcf13be92bddc006d989bcb65a615c098f4a;hb=acce826c593a188b231b7b7918c752bda21d0201;hp=b1afe3b5ff8f8c15b6ff15c77ac75c13a4ebec3b;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/backq.lisp b/src/code/backq.lisp index b1afe3b..32cbdcf 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -11,8 +11,7 @@ (in-package "SB!IMPL") -(file-comment - "$Header$") +(/show0 "entering backq.lisp") ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: ;;; @@ -29,7 +28,7 @@ ;;; ([a] means that a should be converted according to the previous table) ;;; ;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| -;;;cdr \ || | T or NIL | | +;;;cdr \ || | T or NIL | | ;;;================================================================================ ;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d]) ;;; NIL || LIST ([a]) | QUOTE (a) | a | a @@ -48,17 +47,21 @@ (defvar *bq-dot-flag* '(|,.|)) (defvar *bq-vector-flag* '(|bqv|)) +(/show0 "backq.lisp 50") + ;;; the actual character macro (defun backquote-macro (stream ignore) (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)))) + (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") (defun comma-macro (stream ignore) (declare (ignore ignore)) @@ -68,24 +71,31 @@ (%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") + +;;; +(defun expandable-backq-expression-p (object) + (and (consp object) + (let ((flag (car object))) + (or (eq flag *bq-at-flag*) + (eq flag *bq-dot-flag*))))) ;;; This does the expansion from table 2. (defun backquotify (stream code) (cond ((atom code) (cond ((null code) (values nil nil)) - ((or (numberp code) - (eq code t)) + ((or (consp code) + (symbolp code)) ;; Keywords are self-evaluating. Install after packages. - (values t code)) - (t (values 'quote code)))) + (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))) @@ -96,22 +106,26 @@ (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) - (comma a) + (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) - (comma a) + (if (expandable-backq-expression-p a) + (values 'nconc (list a)) + (comma a)) (values 'nconc (cond ((eq dflag 'nconc) (cons a d)) @@ -131,22 +145,27 @@ (values 'list* (list a (backquotify-1 dflag d))))))))))) +(/show0 "backq.lisp 139") + ;;; This handles the cases. (defun comma (code) (cond ((atom code) (cond ((null code) (values nil nil)) - ((or (numberp code) (eq code 't)) + ((or (numberp code) (eq code t)) (values t code)) (t (values *bq-comma-flag* code)))) - ((eq (car code) 'quote) - (values (car code) (cadr 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)))) +(/show0 "backq.lisp 157") + ;;; This handles table 1. (defun backquotify-1 (flag thing) (cond ((or (eq flag *bq-comma-flag*) @@ -155,9 +174,15 @@ ((eq flag 'quote) (list 'quote thing)) ((eq flag 'list*) - (cond ((null (cddr thing)) + (cond ((and (null (cddr thing)) + (not (expandable-backq-expression-p (cadr thing)))) (cons 'backq-cons thing)) - (t + ((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)) @@ -172,9 +197,12 @@ ;;;; magic BACKQ- versions of builtin functions -;;; Define synonyms for the lisp functions we use, so that by using them, we -;;; backquoted material will be recognizable to the pretty-printer. -(macrolet ((def-frob (b-name name) +(/show0 "backq.lisp 184") + +;;; 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 (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 @@ -183,11 +211,13 @@ ;; 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)) + (def backq-list list) + (def backq-list* list*) + (def backq-append append) + (def backq-nconc nconc) + (def backq-cons cons)) + +(/show0 "backq.lisp 204") (defun backq-vector (list) (declare (list list)) @@ -195,18 +225,23 @@ ;;;; initialization +(/show0 "backq.lisp 212") + ;;; Install BACKQ stuff in the current *READTABLE*. ;;; -;;; In the target Lisp, we have to wait to do this until the readtable has been -;;; created. In the cross-compilation host Lisp, we can do this right away. -;;; (You may ask: In the cross-compilation host, which already has its own -;;; implementation of the backquote readmacro, why do we do this at all? -;;; Because the cross-compilation host might -- as SBCL itself does -- express -;;; the backquote expansion in terms of internal, nonportable functions. By -;;; redefining backquote in terms of functions which are guaranteed to exist on -;;; the target Lisp, we ensure that backquote expansions in code-generating -;;; code work properly.) +;;; In the target Lisp, we have to wait to do this until the readtable +;;; has been created. In the cross-compilation host Lisp, we can do +;;; this right away. (You may ask: In the cross-compilation host, +;;; which already has its own implementation of the backquote +;;; readmacro, why do we do this at all? Because the cross-compilation +;;; host might -- as SBCL itself does -- express the backquote +;;; expansion in terms of internal, nonportable functions. By +;;; redefining backquote in terms of functions which are guaranteed to +;;; exist on the target Lisp, we ensure that backquote expansions in +;;; code-generating code work properly.) (defun !backq-cold-init () (set-macro-character #\` #'backquote-macro) (set-macro-character #\, #'comma-macro)) #+sb-xc-host (!backq-cold-init) + +(/show0 "done with backq.lisp")