source: trunk/abcl/src/org/armedbear/lisp/read-circle.lisp @ 12216

Last change on this file since 12216 was 12216, checked in by ehuelsmann, 12 years ago

Make sure the #n= and #n# reader functionality gets compiled.

It's unacceptable to have uncompiled functions processing potentially
huge amounts of data.

File size: 7.8 KB
1;;; read-circle.lisp
3;;; Copyright (C) 2009 Erik Huelsmann
4;;; $Id: read-conditional.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
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.
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; GNU General Public License for more details.
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.
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.
32(in-package "SYSTEM")
35;;; Reading circular data: the #= and ## reader macros (from SBCL)
37;;; Objects already seen by CIRCLE-SUBST.
38(defvar *sharp-equal-circle-table*)
40;; This function is kind of like NSUBLIS, but checks for circularities and
41;; substitutes in arrays and structures as well as lists. The first arg is an
42;; alist of the things to be replaced assoc'd with the things to replace them.
43(defun circle-subst (old-new-alist tree)
44  (macrolet ((recursable-element-p (subtree)
45                `(typep ,subtree
46                       '(or cons (array t) structure-object standard-object)))
47             (element-replacement (subtree)
48               `(let ((entry (find ,subtree old-new-alist :key #'second)))
49                  (if entry (third entry) ,subtree))))
50  (cond ((not (recursable-element-p tree))
51         (element-replacement tree))
52        ((null (gethash tree *sharp-equal-circle-table*))
53         (cond
54          ((typep tree 'structure-object)
55           (setf (gethash tree *sharp-equal-circle-table*) t)
56           (do ((i 0 (1+ i))
57                (end (structure-length tree)))
58               ((= i end))
59             (let* ((old (structure-ref tree i))
60                    (new (circle-subst old-new-alist old)))
61               (unless (eq old new)
62                 (structure-set tree i new)))))
63;;           ((typep tree 'standard-object)
64;;            (setf (gethash tree *sharp-equal-circle-table*) t)
65;;            (do ((i 1 (1+ i))
66;;                 (end (%instance-length tree)))
67;;                ((= i end))
68;;              (let* ((old (%instance-ref tree i))
69;;                     (new (circle-subst old-new-alist old)))
70;;                (unless (eq old new)
71;;                  (setf (%instance-ref tree i) new)))))
72          ((arrayp tree)
73           (setf (gethash tree *sharp-equal-circle-table*) t)
74           (do ((i 0 (1+ i))
75                (end (array-total-size tree)))
76               ((>= i end))
77             (let* ((old (row-major-aref tree i))
78                    (new (circle-subst old-new-alist old)))
79               (unless (eq old new)
80                 (setf (row-major-aref tree i) new)))))
81         (t ;; being CONSP as all the other cases have been handled
82            (do ((subtree tree (cdr subtree)))
83                ((or (not (consp subtree))
84                     (gethash subtree *sharp-equal-circle-table*)))
85                ;; CDR no longer a CONS; no need to recurse any further:
86                ;; the case where the CDR is a symbol to be replaced
87                ;; has been handled in the last iteration
88              (setf (gethash subtree *sharp-equal-circle-table*) t)
89              (let* ((c (car subtree))
90                     (d (cdr subtree))
91                     (a (if (recursable-element-p c)
92                            (circle-subst old-new-alist c)
93                            (element-replacement c)))
94                     (b (cond
95                         ((consp d) d) ;; CONSes handled in the loop
96                         ((recursable-element-p d)
97                          ;; ARRAY, STRUCTURE-OBJECT and STANDARD-OBJECT
98                          ;; handled in recursive calls
99                          (circle-subst old-new-alist d))
100                         (t
101                          (element-replacement d)))))
102                (unless (eq a c)
103                  (rplaca subtree a))
104                (unless (eq d b)
105                  (rplacd subtree b))))))
106        tree)
107  (t tree))))
109;;; Sharp-equal works as follows. When a label is assigned (i.e. when
110;;; #= is called) we GENSYM a symbol is which is used as an
111;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
112;;; gensym.
114;;; When SHARP-SHARP encounters a reference to a label, it returns the
115;;; symbol assoc'd with the label. Resolution of the reference is
116;;; deferred until the read done by #= finishes. Any already resolved
117;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
119;;; After reading of the #= form is completed, we add an entry to
120;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
121;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
122;;; object is searched and any uses of the gensysm token are replaced
123;;; with the actual value.
125(defvar *sharp-sharp-alist* ())
127(defun sharp-equal (stream ignore label)
128  (declare (ignore ignore))
129  (when *read-suppress* (return-from sharp-equal (values)))
130  (unless label
131    (error 'reader-error
132           :stream stream
133           :format-control "Missing label for #="))
134  (when (or (assoc label *sharp-sharp-alist*)
135            (assoc label *sharp-equal-alist*))
136    (error 'reader-error
137           :stream stream
138           :format-control "Multiply defined label: #~D="
139           :format-arguments (list label)))
140  (let* ((tag (gensym))
141         (*sharp-sharp-alist* (cons (list label tag nil) *sharp-sharp-alist*))
142         (obj (read stream t nil t)))
143    (when (eq obj tag)
144      (error 'reader-error
145             :stream stream
146             :format-control "Must tag something more than just #~D#"
147             :format-arguments (list label)))
148    (push (list label tag obj) *sharp-equal-alist*)
149    (when (third (car *sharp-sharp-alist*)) ;; set to T on circularity
150      (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
151        (circle-subst *sharp-equal-alist* obj)))
152    obj))
154(defun sharp-sharp (stream ignore label)
155  (declare (ignore ignore))
156  (when *read-suppress* (return-from sharp-sharp nil))
157  (unless label
158    (error 'reader-error :stream stream :format-control "Missing label for ##"))
159  (let ((entry (assoc label *sharp-equal-alist*)))
160    (if entry
161        (third entry)
162        (let ((pair (assoc label *sharp-sharp-alist*)))
163          (unless pair
164            (error 'reader-error
165                   :stream stream
166                   :format-control "Object is not labelled #~S#"
167                   :format-arguments (list label)))
168          (setf (third pair) t)
169          (second pair)))))
171(set-dispatch-macro-character #\# #\= #'sharp-equal +standard-readtable+)
172(set-dispatch-macro-character #\# #\# #'sharp-sharp +standard-readtable+)
Note: See TracBrowser for help on using the repository browser.