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

Last change on this file since 11391 was 11391, checked in by vvoutilainen, 12 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.0 KB
Line 
1;;; backquote.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: backquote.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
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;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from SBCL.
33
34;;;; the backquote reader macro
35
36;;;; This software is part of the SBCL system. See the README file for
37;;;; more information.
38;;;;
39;;;; This software is derived from the CMU CL system, which was
40;;;; written at Carnegie Mellon University and released into the
41;;;; public domain. The software is in the public domain and is
42;;;; provided with absolutely no warranty. See the COPYING and CREDITS
43;;;; files for more information.
44
45(in-package #:system)
46
47;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
48;;;
49;;;   |`,|: [a] => a
50;;;    NIL: [a] => a    ;the NIL flag is used only when a is NIL
51;;;      T: [a] => a    ;the T flag is used when a is self-evaluating
52;;;  QUOTE: [a] => (QUOTE a)
53;;; APPEND: [a] => (APPEND . a)
54;;;  NCONC: [a] => (NCONC . a)
55;;;   LIST: [a] => (LIST . a)
56;;;  LIST*: [a] => (LIST* . a)
57;;;
58;;; The flags are combined according to the following set of rules:
59;;;  ([a] means that a should be converted according to the previous table)
60;;;
61;;;   \ car  ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|
62;;;cdr \     ||                 |    T or NIL     |                |
63;;;================================================================================
64;;;  |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d])
65;;;  NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a
66;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC (a [d])
67;;; APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
68;;; NCONC    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
69;;;  LIST    || LIST  ([a] . d) | LIST  ([a] . d) | APPEND (a [d]) | NCONC (a [d])
70;;;  LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d])
71;;;
72;;;<hair> involves starting over again pretending you had read ".,a)" instead
73;;; of ",@a)"
74
75;; (%defvar '*backquote-count* 0)
76(%defvar '*bq-comma-flag* '(|,|))
77(%defvar '*bq-at-flag* '(|,@|))
78(%defvar '*bq-dot-flag* '(|,.|))
79;; (%defvar '*bq-vector-flag* '(|bqv|))
80
81;;; the actual character macro
82(defun backquote-macro (stream ignore)
83  (declare (ignore ignore))
84  (let ((*backquote-count* (1+ *backquote-count*)))
85    (multiple-value-bind (flag thing)
86  (backquotify stream (read stream t nil t))
87      (when (eq flag *bq-at-flag*)
88  (%reader-error stream ",@ after backquote in ~S" thing))
89      (when (eq flag *bq-dot-flag*)
90  (%reader-error stream ",. after backquote in ~S" thing))
91      (backquotify-1 flag thing))))
92
93(defun comma-macro (stream ignore)
94  (declare (ignore ignore))
95  (unless (> *backquote-count* 0)
96    (when *read-suppress*
97      (return-from comma-macro nil))
98    (%reader-error stream "Comma not inside a backquote."))
99  (let ((c (read-char stream))
100  (*backquote-count* (1- *backquote-count*)))
101    (cond ((char= c #\@)
102     (cons *bq-at-flag* (read stream t nil t)))
103    ((char= c #\.)
104     (cons *bq-dot-flag* (read stream t nil t)))
105    (t (unread-char c stream)
106       (cons *bq-comma-flag* (read stream t nil t))))))
107
108;;;
109(defun expandable-backq-expression-p (object)
110  (and (consp object)
111       (let ((flag (%car object)))
112         (or (eq flag *bq-at-flag*)
113             (eq flag *bq-dot-flag*)))))
114
115;;; This does the expansion from table 2.
116(defun backquotify (stream code)
117  (cond ((atom code)
118   (cond ((null code) (values nil nil))
119         ((or (consp code)
120                    (symbolp code))
121    ;; Keywords are self-evaluating. Install after packages.
122                (values 'quote code))
123         (t (values t code))))
124  ((or (eq (car code) *bq-at-flag*)
125       (eq (car code) *bq-dot-flag*))
126   (values (car code) (cdr code)))
127  ((eq (car code) *bq-comma-flag*)
128   (comma (cdr code)))
129  ((eq (car code) *bq-vector-flag*)
130   (multiple-value-bind (dflag d) (backquotify stream (cdr code))
131     (values 'vector (backquotify-1 dflag d))))
132  (t (multiple-value-bind (aflag a) (backquotify stream (car code))
133       (multiple-value-bind (dflag d) (backquotify stream (cdr code))
134         (when (eq dflag *bq-at-flag*)
135     ;; Get the errors later.
136     (%reader-error stream ",@ after dot in ~S" code))
137         (when (eq dflag *bq-dot-flag*)
138     (%reader-error stream ",. after dot in ~S" code))
139         (cond
140    ((eq aflag *bq-at-flag*)
141     (if (null dflag)
142         (if (expandable-backq-expression-p a)
143                         (values 'append (list a))
144                         (comma a))
145         (values 'append
146           (cond ((eq dflag 'append)
147            (cons a d ))
148           (t (list a (backquotify-1 dflag d)))))))
149    ((eq aflag *bq-dot-flag*)
150     (if (null dflag)
151         (if (expandable-backq-expression-p a)
152                         (values 'nconc (list a))
153                         (comma a))
154         (values 'nconc
155           (cond ((eq dflag 'nconc)
156            (cons a d))
157           (t (list a (backquotify-1 dflag d)))))))
158    ((null dflag)
159     (if (memq aflag '(quote t nil))
160         (values 'quote (list a))
161         (values 'list (list (backquotify-1 aflag a)))))
162    ((memq dflag '(quote t))
163     (if (memq aflag '(quote t nil))
164         (values 'quote (cons a d ))
165         (values 'list* (list (backquotify-1 aflag a)
166            (backquotify-1 dflag d)))))
167    (t (setq a (backquotify-1 aflag a))
168       (if (memq dflag '(list list*))
169           (values dflag (cons a d))
170           (values 'list*
171             (list a (backquotify-1 dflag d)))))))))))
172
173;;; This handles the <hair> cases.
174(defun comma (code)
175  (cond ((atom code)
176   (cond ((null code)
177    (values nil nil))
178         ((or (numberp code) (eq code t))
179    (values t code))
180         (t (values *bq-comma-flag* code))))
181  ((and (eq (car code) 'quote)
182              (not (expandable-backq-expression-p (cadr code))))
183         (values (car code) (cadr code)))
184  ((memq (car code) '(append list list* nconc))
185   (values (car code) (cdr code)))
186  ((eq (car code) 'cons)
187   (values 'list* (cdr code)))
188  (t (values *bq-comma-flag* code))))
189
190;;; This handles table 1.
191(defun backquotify-1 (flag thing)
192  (cond ((or (eq flag *bq-comma-flag*)
193       (memq flag '(t nil)))
194   thing)
195  ((eq flag 'quote)
196   (list  'quote thing))
197  ((eq flag 'list*)
198         (cond ((and (null (cddr thing))
199                     (not (expandable-backq-expression-p (cadr thing))))
200    (cons 'backq-cons thing))
201         ((expandable-backq-expression-p (car (last thing)))
202                (list 'backq-append
203                      (cons 'backq-list (butlast thing))
204                      ;; Can it be optimized further? -- APD, 2001-12-21
205                      (car (last thing))))
206               (t
207    (cons 'backq-list* thing))))
208  ((eq flag 'vector)
209   (list 'backq-vector thing))
210  (t (cons (ecase flag
211       ((list) 'backq-list)
212       ((append) 'backq-append)
213       ((nconc) 'backq-nconc))
214     thing))))
215
216;;;; magic BACKQ- versions of builtin functions
217
218;;; Define synonyms for the lisp functions we use, so that by using
219;;; them, the backquoted material will be recognizable to the
220;;; pretty-printer.
221(defun backq-list   (&rest args) (apply #'list   args))
222(defun backq-list*  (&rest args) (apply #'list*  args))
223(defun backq-append (&rest args) (apply #'append args))
224(defun backq-nconc  (&rest args) (apply #'nconc  args))
225(defun backq-cons   (&rest args) (apply #'cons   args))
226
227(defun backq-vector (list)
228  (declare (list list))
229  (coerce list 'simple-vector))
230
231;;; The pretty-printer needs to know about our special tokens
232(%defvar '*backq-tokens*
233  '(backq-comma backq-comma-at backq-comma-dot backq-list
234    backq-list* backq-append backq-nconc backq-cons backq-vector))
235
236(defun %reader-error (stream control &rest args)
237  (error 'reader-error
238   :stream stream
239   :format-control control
240   :format-arguments args))
Note: See TracBrowser for help on using the repository browser.