/[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.2 by ram, Fri Feb 8 13:30:51 1991 UTC revision 1.3 by wlott, Thu Jan 16 19:08:55 1992 UTC
# Line 12  Line 12 
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;;    BACKQUOTE: Code Spice Lispified by Lee Schumacher.  ;;;    BACKQUOTE: Code Spice Lispified by Lee Schumacher.
15    ;;;               (unparsing by Miles Bader)
16  ;;;  ;;;
17  (in-package 'lisp)  (in-package 'lisp)
18    
# Line 50  Line 51 
51  (defvar *bq-dot-flag* '(|,.|))  (defvar *bq-dot-flag* '(|,.|))
52  (defvar *bq-vector-flag* '(|bqv|))  (defvar *bq-vector-flag* '(|bqv|))
53    
   
54  ;; This is the actual character macro.  ;; This is the actual character macro.
55  (defun backquote-macro (stream ignore)  (defun backquote-macro (stream ignore)
56    (declare (ignore ignore))    (declare (ignore ignore))
# Line 79  Line 79 
79             (t (unread-char c stream)             (t (unread-char c stream)
80                (cons *bq-comma-flag* (read stream t nil t))))                (cons *bq-comma-flag* (read stream t nil t))))
81       'list)))       'list)))
82    
83  ;;; This does the expansion from table 2.  ;;; This does the expansion from table 2.
84  (defun backquotify (code)  (defun backquotify (code)
85    (cond ((atom code)    (cond ((atom code)
# Line 159  Line 159 
159           (list  'quote thing))           (list  'quote thing))
160          ((eq flag 'list*)          ((eq flag 'list*)
161           (cond ((null (cddr thing))           (cond ((null (cddr thing))
162                  (cons 'cons thing))                  (cons 'backq-cons thing))
163                 (t (cons 'list* thing))))                 (t
164                    (cons 'backq-list* thing))))
165          ((eq flag 'vector)          ((eq flag 'vector)
166           (list 'apply '#'vector thing))           (list 'backq-vector thing))
167          (t (cons (cdr          (t (cons (cdr
168                    (assq flag                    (assq flag
169                          `((cons . cons) (list . list)                          '((cons . backq-cons)
170                            (append . append) (nconc . nconc))))                            (list . backq-list)
171                              (append . backq-append)
172                              (nconc . backq-nconc))))
173                   thing))))                   thing))))
174    
175    
176    ;;;; Magic backq- versions of builtin functions.
177    
178    ;;; Use synonyms for the lisp functions we use, so we can recognize backquoted
179    ;;; material when pretty-printing
180    
181    (defun backq-list (&rest args)
182      args)
183    (defun backq-list* (&rest args)
184      (apply #'list* args))
185    (defun backq-append (&rest args)
186      (apply #'append args))
187    (defun backq-nconc (&rest args)
188      (apply #'nconc args))
189    (defun backq-cons (x y)
190      (cons x y))
191    (defun backq-vector (list)
192      (coerce list 'vector))
193    
194    
195    ;;;; Unparsing
196    
197    (defun backq-unparse-expr (form splicing)
198      (ecase splicing
199        ((nil)
200         `(backq-comma ,form))
201        ((t)
202         `((backq-comma-at ,form)))
203        (:nconc
204         `((backq-comma-dot ,form)))
205        ))
206    
207    (defun backq-unparse (form &optional splicing)
208      "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
209      BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
210      corresponding backquote input form.  In this form, `,' `,@' and `,.' are
211      represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
212      BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
213      SPLICING indicates whether a comma-escape return should be modified for
214      splicing with other forms: a value of T or :NCONC meaning that an extra
215      level of parentheses should be added."
216      (if (atom form)
217          (backq-unparse-expr form splicing)
218          (case (car form)
219            (backq-list
220             (mapcar #'backq-unparse (cdr form)))
221            (backq-list*
222             (do ((tail (cdr form) (cdr tail))
223                  (accum nil))
224                 ((null (cdr tail))
225                  (nconc (nreverse accum)
226                         (backq-unparse (car tail) t)))
227               (push (backq-unparse (car tail)) accum)))
228            (backq-append
229             (mapcan #'(lambda (el) (backq-unparse el t))
230                     (cdr form)))
231            (backq-nconc
232             (mapcan #'(lambda (el) (backq-unparse el :nconc))
233                     (cdr form)))
234            (backq-cons
235             (cons (backq-unparse (cadr form) nil)
236                   (backq-unparse (caddr form) t)))
237            (backq-vector
238             (coerce (backq-unparse (cadr form)) 'vector))
239            (quote
240             (cadr form))
241            (t
242             (backq-unparse-expr form splicing)))))
243    
244    (defun pprint-backquote (stream form &rest noise)
245      (declare (ignore noise))
246      (write-char #\` stream)
247      (write (backq-unparse form) :stream stream))
248    
249    (defun pprint-backq-comma (stream form &rest noise)
250      (declare (ignore noise))
251      (ecase (car form)
252        (backq-comma
253         (write-char #\, stream))
254        (backq-comma-at
255         (princ ",@" stream))
256        (backq-comma-dot
257         (princ ",." stream)))
258      (write (cadr form) :stream stream))
259    
260    
261    ;;;; BACKQ-INIT and BACKQ-PP-INIT
262    
263    ;;; BACKQ-INIT -- interface.
264    ;;;
265    ;;; This is called by %INITIAL-FUNCTION.
266    ;;;
267  (defun backq-init ()  (defun backq-init ()
268    (let ((*readtable* std-lisp-readtable))    (let ((*readtable* std-lisp-readtable))
269      (set-macro-character #\` #'backquote-macro)      (set-macro-character #\` #'backquote-macro)
270      (set-macro-character #\, #'comma-macro)))      (set-macro-character #\, #'comma-macro)))
271    
272    ;;; BACKQ-PP-INIT -- interface.
273    ;;;
274    ;;; This is called by PPRINT-INIT.  This must be seperate from BACKQ-INIT
275    ;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded.
276    ;;;
277    (defun backq-pp-init ()
278      (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
279      (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
280      (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
281      (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
282      (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
283      (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
284    
285      (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
286      (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
287      (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5