/[cmucl]/src/code/backq.lisp
ViewVC logotype

Diff of /src/code/backq.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by ram, Mon Oct 31 04:11:27 1994 UTC revision 1.11 by toy, Mon Oct 14 21:37:57 2002 UTC
# Line 78  Line 78 
78                (cons *bq-comma-flag* (read stream t nil t))))                (cons *bq-comma-flag* (read stream t nil t))))
79       'list)))       'list)))
80    
81    ;;;
82    (defun expandable-backq-expression-p (object)
83      (and (consp object)
84           (let ((flag (car object)))
85             (or (eq flag *bq-at-flag*)
86                 (eq flag *bq-dot-flag*)))))
87    
88    
89  ;;; This does the expansion from table 2.  ;;; This does the expansion from table 2.
90  (defun backquotify (stream code)  (defun backquotify (stream code)
91    (cond ((atom code)    (cond ((atom code)
92           (cond ((null code) (values nil nil))           (cond ((null code) (values nil nil))
93                 ((or (numberp code)                 ((or (consp code)
94                      (eq code t))                      (symbolp code))
95                  ;; Keywords are self evaluating. Install after packages.                  ;; Keywords are self evaluating. Install after packages.
96                  (values t code))                  (values 'quote code))
97                 (t (values 'quote code))))                 (t (values t code))))
98          ((or (eq (car code) *bq-at-flag*)          ((or (eq (car code) *bq-at-flag*)
99               (eq (car code) *bq-dot-flag*))               (eq (car code) *bq-dot-flag*))
100           (values (car code) (cdr code)))           (values (car code) (cdr code)))
# Line 105  Line 113 
113                 (cond                 (cond
114                  ((eq aflag *bq-at-flag*)                  ((eq aflag *bq-at-flag*)
115                   (if (null dflag)                   (if (null dflag)
116                       (comma a)                       (if (expandable-backq-expression-p a)
117                             (values 'append (list a))
118                             (comma a))
119                       (values 'append                       (values 'append
120                               (cond ((eq dflag 'append)                               (cond ((eq dflag 'append)
121                                      (cons a d ))                                      (cons a d ))
122                                     (t (list a (backquotify-1 dflag d)))))))                                     (t (list a (backquotify-1 dflag d)))))))
123                  ((eq aflag *bq-dot-flag*)                  ((eq aflag *bq-dot-flag*)
124                   (if (null dflag)                   (if (null dflag)
125                       (comma a)                       (if (expandable-backq-expression-p a)
126                             (values 'nconc (list a))
127                             (comma a))
128                       (values 'nconc                       (values 'nconc
129                               (cond ((eq dflag 'nconc)                               (cond ((eq dflag 'nconc)
130                                      (cons a d))                                      (cons a d))
# Line 140  Line 152 
152                 ((or (numberp code) (eq code 't))                 ((or (numberp code) (eq code 't))
153                  (values t code))                  (values t code))
154                 (t (values *bq-comma-flag* code))))                 (t (values *bq-comma-flag* code))))
155          ((eq (car code) 'quote)          ((and (eq (car code) 'quote)
156                  (not (expandable-backq-expression-p (cadr code))))
157           (values (car code) (cadr code)))           (values (car code) (cadr code)))
158          ((memq (car code) '(append list list* nconc))          ((memq (car code) '(append list list* nconc))
159           (values (car code) (cdr code)))           (values (car code) (cdr code)))
# Line 156  Line 169 
169          ((eq flag 'quote)          ((eq flag 'quote)
170           (list  'quote thing))           (list  'quote thing))
171          ((eq flag 'list*)          ((eq flag 'list*)
172           (cond ((null (cddr thing))           (cond ((and (null (cddr thing))
173                         (not (expandable-backq-expression-p (cadr thing))))
174                  (cons 'backq-cons thing))                  (cons 'backq-cons thing))
175                 (t                 ((expandable-backq-expression-p (car (last thing)))
176                    (list 'backq-append
177                          (cons 'backq-list (butlast thing))
178                          ;; Can it be optimized further? -- APD, 2001-12-21
179                          (car (last thing))))
180                   (t
181                  (cons 'backq-list* thing))))                  (cons 'backq-list* thing))))
182          ((eq flag 'vector)          ((eq flag 'vector)
183           (list 'backq-vector thing))           (list 'backq-vector thing))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

  ViewVC Help
Powered by ViewVC 1.1.5