source: trunk/j/src/org/armedbear/lisp/backquote.lisp @ 8063

Last change on this file since 8063 was 8063, checked in by piso, 17 years ago

New backquote implementation from SBCL.

File size: 8.3 KB
Line 
1;;; backquote.lisp
2;;;
3;;; Copyright (C) 2004 Peter Graves
4;;; $Id: backquote.lisp,v 1.6 2004-10-24 18:06:20 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from SBCL.
21
22;;;; the backquote reader macro
23
24;;;; This software is part of the SBCL system. See the README file for
25;;;; more information.
26;;;;
27;;;; This software is derived from the CMU CL system, which was
28;;;; written at Carnegie Mellon University and released into the
29;;;; public domain. The software is in the public domain and is
30;;;; provided with absolutely no warranty. See the COPYING and CREDITS
31;;;; files for more information.
32
33(in-package #:system)
34
35;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
36;;;
37;;;   |`,|: [a] => a
38;;;    NIL: [a] => a    ;the NIL flag is used only when a is NIL
39;;;      T: [a] => a    ;the T flag is used when a is self-evaluating
40;;;  QUOTE: [a] => (QUOTE a)
41;;; APPEND: [a] => (APPEND . a)
42;;;  NCONC: [a] => (NCONC . a)
43;;;   LIST: [a] => (LIST . a)
44;;;  LIST*: [a] => (LIST* . a)
45;;;
46;;; The flags are combined according to the following set of rules:
47;;;  ([a] means that a should be converted according to the previous table)
48;;;
49;;;   \ car  ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|
50;;;cdr \     ||                 |    T or NIL     |                |
51;;;================================================================================
52;;;  |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d])
53;;;  NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a
54;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC (a [d])
55;;; APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
56;;; NCONC    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
57;;;  LIST    || LIST  ([a] . d) | LIST  ([a] . d) | APPEND (a [d]) | NCONC (a [d])
58;;;  LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d])
59;;;
60;;;<hair> involves starting over again pretending you had read ".,a)" instead
61;;; of ",@a)"
62
63;; (%defvar '*backquote-count* 0)
64(%defvar '*bq-comma-flag* '(|,|))
65(%defvar '*bq-at-flag* '(|,@|))
66(%defvar '*bq-dot-flag* '(|,.|))
67;; (%defvar '*bq-vector-flag* '(|bqv|))
68
69;;; the actual character macro
70(defun backquote-macro (stream ignore)
71  (declare (ignore ignore))
72  (let ((*backquote-count* (1+ *backquote-count*)))
73    (multiple-value-bind (flag thing)
74  (backquotify stream (read stream t nil t))
75      (when (eq flag *bq-at-flag*)
76  (%reader-error stream ",@ after backquote in ~S" thing))
77      (when (eq flag *bq-dot-flag*)
78  (%reader-error stream ",. after backquote in ~S" thing))
79      (backquotify-1 flag thing))))
80
81(defun comma-macro (stream ignore)
82  (declare (ignore ignore))
83  (unless (> *backquote-count* 0)
84    (when *read-suppress*
85      (return-from comma-macro nil))
86    (%reader-error stream "comma not inside a backquote"))
87  (let ((c (read-char stream))
88  (*backquote-count* (1- *backquote-count*)))
89    (cond ((char= c #\@)
90     (cons *bq-at-flag* (read stream t nil t)))
91    ((char= c #\.)
92     (cons *bq-dot-flag* (read stream t nil t)))
93    (t (unread-char c stream)
94       (cons *bq-comma-flag* (read stream t nil t))))))
95
96;;;
97(defun expandable-backq-expression-p (object)
98  (and (consp object)
99       (let ((flag (car object)))
100         (or (eq flag *bq-at-flag*)
101             (eq flag *bq-dot-flag*)))))
102
103;;; This does the expansion from table 2.
104(defun backquotify (stream code)
105  (cond ((atom code)
106   (cond ((null code) (values nil nil))
107         ((or (consp code)
108                    (symbolp code))
109    ;; Keywords are self-evaluating. Install after packages.
110                (values 'quote code))
111         (t (values t code))))
112  ((or (eq (car code) *bq-at-flag*)
113       (eq (car code) *bq-dot-flag*))
114   (values (car code) (cdr code)))
115  ((eq (car code) *bq-comma-flag*)
116   (comma (cdr code)))
117  ((eq (car code) *bq-vector-flag*)
118   (multiple-value-bind (dflag d) (backquotify stream (cdr code))
119     (values 'vector (backquotify-1 dflag d))))
120  (t (multiple-value-bind (aflag a) (backquotify stream (car code))
121       (multiple-value-bind (dflag d) (backquotify stream (cdr code))
122         (when (eq dflag *bq-at-flag*)
123     ;; Get the errors later.
124     (%reader-error stream ",@ after dot in ~S" code))
125         (when (eq dflag *bq-dot-flag*)
126     (%reader-error stream ",. after dot in ~S" code))
127         (cond
128    ((eq aflag *bq-at-flag*)
129     (if (null dflag)
130         (if (expandable-backq-expression-p a)
131                         (values 'append (list a))
132                         (comma a))
133         (values 'append
134           (cond ((eq dflag 'append)
135            (cons a d ))
136           (t (list a (backquotify-1 dflag d)))))))
137    ((eq aflag *bq-dot-flag*)
138     (if (null dflag)
139         (if (expandable-backq-expression-p a)
140                         (values 'nconc (list a))
141                         (comma a))
142         (values 'nconc
143           (cond ((eq dflag 'nconc)
144            (cons a d))
145           (t (list a (backquotify-1 dflag d)))))))
146    ((null dflag)
147     (if (memq aflag '(quote t nil))
148         (values 'quote (list a))
149         (values 'list (list (backquotify-1 aflag a)))))
150    ((memq dflag '(quote t))
151     (if (memq aflag '(quote t nil))
152         (values 'quote (cons a d ))
153         (values 'list* (list (backquotify-1 aflag a)
154            (backquotify-1 dflag d)))))
155    (t (setq a (backquotify-1 aflag a))
156       (if (memq dflag '(list list*))
157           (values dflag (cons a d))
158           (values 'list*
159             (list a (backquotify-1 dflag d)))))))))))
160
161;;; This handles the <hair> cases.
162(defun comma (code)
163  (cond ((atom code)
164   (cond ((null code)
165    (values nil nil))
166         ((or (numberp code) (eq code t))
167    (values t code))
168         (t (values *bq-comma-flag* code))))
169  ((and (eq (car code) 'quote)
170              (not (expandable-backq-expression-p (cadr code))))
171         (values (car code) (cadr code)))
172  ((memq (car code) '(append list list* nconc))
173   (values (car code) (cdr code)))
174  ((eq (car code) 'cons)
175   (values 'list* (cdr code)))
176  (t (values *bq-comma-flag* code))))
177
178;;; This handles table 1.
179(defun backquotify-1 (flag thing)
180  (cond ((or (eq flag *bq-comma-flag*)
181       (memq flag '(t nil)))
182   thing)
183  ((eq flag 'quote)
184   (list  'quote thing))
185  ((eq flag 'list*)
186         (cond ((and (null (cddr thing))
187                     (not (expandable-backq-expression-p (cadr thing))))
188    (cons 'backq-cons thing))
189         ((expandable-backq-expression-p (car (last thing)))
190                (list 'backq-append
191                      (cons 'backq-list (butlast thing))
192                      ;; Can it be optimized further? -- APD, 2001-12-21
193                      (car (last thing))))
194               (t
195    (cons 'backq-list* thing))))
196  ((eq flag 'vector)
197   (list 'backq-vector thing))
198  (t (cons (ecase flag
199       ((list) 'backq-list)
200       ((append) 'backq-append)
201       ((nconc) 'backq-nconc))
202     thing))))
203
204;;;; magic BACKQ- versions of builtin functions
205
206;;; Define synonyms for the lisp functions we use, so that by using
207;;; them, the backquoted material will be recognizable to the
208;;; pretty-printer.
209(defun backq-list   (&rest args) (apply #'list   args))
210(defun backq-list*  (&rest args) (apply #'list*  args))
211(defun backq-append (&rest args) (apply #'append args))
212(defun backq-nconc  (&rest args) (apply #'nconc  args))
213(defun backq-cons   (&rest args) (apply #'cons   args))
214
215(defun backq-vector (list)
216  (declare (list list))
217  (coerce list 'simple-vector))
218
219;;; The pretty-printer needs to know about our special tokens
220(%defvar '*backq-tokens*
221  '(backq-comma backq-comma-at backq-comma-dot backq-list
222    backq-list* backq-append backq-nconc backq-cons backq-vector))
223
224(defun %reader-error (stream control &rest args)
225  (error 'reader-error
226   :stream stream
227   :format-control control
228   :format-arguments args))
Note: See TracBrowser for help on using the repository browser.