(in-package "SB!IMPL")
+(/show0 "entering backq.lisp")
+
;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
;;;
;;; |`,|: [a] => a
;;; ([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) | <hair> a | <hair> a
(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))
(%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)))
(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))
(values 'list*
(list a (backquotify-1 dflag d)))))))))))
+(/show0 "backq.lisp 139")
+
;;; This handles the <hair> 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*)
((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))
\f
;;;; 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
;; 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))
\f
;;;; 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")
projects / sbcl.git / blobdiff