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

Last change on this file since 4273 was 4273, checked in by piso, 19 years ago

maptree => sys::maptree

File size: 3.4 KB
Line 
1;;; backquote.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: backquote.lisp,v 1.5 2003-10-10 01:54:26 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(in-package "COMMON-LISP")
21
22(defconstant *comma* 'COMMA)
23(defconstant *comma-atsign* 'COMMA-ATSIGN)
24(defconstant *comma-dot* 'COMMA-DOT)
25(defconstant *bq-list* (make-symbol "BQ-LIST"))
26(defconstant *bq-append* (make-symbol "BQ-APPEND"))
27(defconstant *bq-list** (make-symbol "BQ-LIST*"))
28(defconstant *bq-nconc* (make-symbol "BQ-NCONC"))
29(defconstant *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
30(defconstant *bq-quote* (make-symbol "BQ-QUOTE"))
31
32(defmacro backquote (form)
33  (bq-completely-process form))
34
35(defun bq-completely-process (x)
36  (let ((raw-result (bq-process x)))
37    (bq-remove-tokens raw-result)))
38
39(defun bq-process (x)
40  (cond ((atom x)
41         (list *bq-quote* x))
42        ((eq (car x) 'backquote)
43         (bq-process (bq-completely-process (cadr x))))
44        ((eq (car x) *comma*) (cadr x))
45        ((eq (car x) *comma-atsign*)
46         (error ",@~S after `" (cadr x)))
47        ((eq (car x) *comma-dot*)
48         (error ",.~S after `" (cadr x)))
49        (t (do ((p x (cdr p))
50                (q '() (cons (bracket (car p)) q)))
51             ((atom p)
52              (cons *bq-append*
53                    (nreconc q (list (list *bq-quote* p)))))
54             (when (eq (car p) *comma*)
55               (unless (null (cddr p)) (error "malformed ,~S" p))
56               (return (cons *bq-append*
57                             (nreconc q (list (cadr p))))))
58             (when (eq (car p) *comma-atsign*)
59               (error "dotted ,@~S" p))
60             (when (eq (car p) *comma-dot*)
61               (error "dotted ,.~S" p))))))
62
63(defun bracket (x)
64  (cond ((atom x)
65         (list *bq-list* (bq-process x)))
66        ((eq (car x) *comma*)
67         (list *bq-list* (cadr x)))
68        ((eq (car x) *comma-atsign*)
69         (cadr x))
70        ((eq (car x) *comma-dot*)
71         (list *bq-clobberable* (cadr x)))
72        (t (list *bq-list* (bq-process x)))))
73
74;; (defun maptree (fn x)
75;;   (if (atom x)
76;;       (funcall fn x)
77;;       (let ((a (funcall fn (car x)))
78;;             (d (maptree fn (cdr x))))
79;;         (if (and (eql a (car x)) (eql d (cdr x)))
80;;             x
81;;             (cons a d)))))
82
83(defun bq-remove-tokens (x)
84  (cond ((eq x *bq-list*) 'list)
85        ((eq x *bq-append*) 'append)
86        ((eq x *bq-nconc*) 'nconc)
87        ((eq x *bq-list**) 'list*)
88        ((eq x *bq-quote*) 'quote)
89        ((atom x) x)
90        ((eq (car x) *bq-clobberable*)
91         (bq-remove-tokens (cadr x)))
92        ((and (eq (car x) *bq-list**)
93              (consp (cddr x))
94              (null (cdddr x)))
95         (cons 'cons (sys::maptree #'bq-remove-tokens (cdr x))))
96        (t (sys::maptree #'bq-remove-tokens x))))
Note: See TracBrowser for help on using the repository browser.