diff --git a/code/backq.lisp b/code/backq.lisp index d8f3a073006844f5bbdc1c1466ce6fa83b6680fb..f16491f8d122d54c7f792a4da6ed88a68744919a 100644 --- a/code/backq.lisp +++ b/code/backq.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/backq.lisp,v 1.10 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/backq.lisp,v 1.11 2002/10/14 21:37:57 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -78,15 +78,23 @@ (cons *bq-comma-flag* (read stream t nil t)))) 'list))) +;;; +(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))) @@ -105,14 +113,18 @@ (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)) @@ -140,7 +152,8 @@ ((or (numberp code) (eq code 't)) (values t code)) (t (values *bq-comma-flag* code)))) - ((eq (car code) 'quote) + ((and (eq (car code) 'quote) + (not (expandable-backq-expression-p (cadr code)))) (values (car code) (cadr code))) ((memq (car code) '(append list list* nconc)) (values (car code) (cdr code))) @@ -156,9 +169,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))