source: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp @ 13600

Last change on this file since 13600 was 13600, checked in by ehuelsmann, 10 years ago

Fix #143: Support circularity in serialized forms

-- this enables compilation of CLOSURE-HTML.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.5 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 13600 2011-09-19 20:49:29Z ehuelsmann $
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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, 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(in-package "SYSTEM")
33
34(export '(dump-form dump-uninterned-symbol-index))
35
36(declaim (special *circularity* *circle-counter* *instance-forms*))
37
38
39(defun get-instance-form (object)
40  (multiple-value-bind
41        (value presence)
42      (gethash object *instance-forms*)
43    (cond
44      (presence value)
45      (t
46       (multiple-value-bind (creation-form initialization-form)
47           (make-load-form object)
48         (if initialization-form
49             (let* ((instance (gensym))
50                    load-form)
51               (setf initialization-form
52                     (subst instance object initialization-form))
53               (setf initialization-form
54                     (subst instance (list 'quote instance) initialization-form
55                            :test #'equal))
56               (setf load-form `(progn
57                                  (let ((,instance ,creation-form))
58                                    ,initialization-form
59                                    ,instance)))
60               (setf (gethash object *instance-forms*) load-form))
61             (setf (gethash object *instance-forms*) creation-form)))))))
62
63(defun df-register-circularity (object)
64  (setf (gethash object *circularity*)
65        (if (gethash object *circularity*)
66            :circular
67            t)))
68
69(defun df-check-cons (object)
70  (loop
71     (df-check-object (car object))
72     (setf object (cdr object))
73     (when (atom object)
74       (df-check-object object)
75       (return))
76     (when (null object)
77       (return-from df-check-cons))
78     (df-register-circularity object)))
79
80(defun df-check-vector (object)
81  (dotimes (index (length object))
82    (df-check-object (aref object index))))
83
84(defun df-check-instance (object)
85  (df-check-object (get-instance-form object)))
86
87(defun df-check-object (object)
88  (unless (eq :circular (df-register-circularity object))
89    (cond
90      ((consp object) (df-check-cons object))
91      ((vectorp object) (df-check-vector object))
92      ((or (structure-object-p object)
93           (standard-object-p object)
94           (java:java-object-p object))
95       (df-check-instance object)))))
96
97(defun df-handle-circularity (object stream within-list)
98  (let ((index (gethash object *circularity*)))
99    (cond
100      ((eq index :circular)
101       (setf index
102             (incf *circle-counter*))
103       (setf (gethash object *circularity*) index)
104       (when within-list
105         (write-string " . " stream))
106       (%stream-write-char #\# stream)
107       (write index :stream stream)
108       (%stream-write-char #\= stream)
109       (when within-list
110         (dump-cons object stream)  ;; ### *cough*
111         (return-from df-handle-circularity t))
112       (return-from df-handle-circularity))
113      ((integerp index)
114       (when within-list
115         (write-string " . " stream))
116       (%stream-write-char #\# stream)
117       (write index :stream stream)
118       (%stream-write-char #\# stream)
119       (%stream-write-char #\Space stream)
120       (return-from df-handle-circularity t))
121      (t
122       (unless *prevent-fasl-circle-detection*
123         (assert (eq index t)))))))
124
125(declaim (ftype (function (cons stream) t) dump-cons))
126(defun dump-cons (object stream)
127  (cond ((and (eq (car object) 'QUOTE) (= (length object) 2))
128         (%stream-write-char #\' stream)
129         (dump-object (%cadr object) stream))
130        (t
131         (%stream-write-char #\( stream)
132         (loop
133            (dump-object (%car object) stream)
134            (setf object (%cdr object))
135            (when (null object)
136              (return)) ;; escape loop
137            (%stream-write-char #\space stream)
138            (when (atom object)
139              (%stream-write-char #\. stream)
140              (%stream-write-char #\space stream)
141              (dump-object object stream)
142              (return))
143            (when (df-handle-circularity object stream t)
144              (return))
145            (when (> (charpos stream) 80)
146              (%stream-terpri stream)))
147         (%stream-write-char #\) stream))))
148
149(declaim (ftype (function (t stream) t) dump-vector))
150(defun dump-vector (object stream)
151  (write-string "#(" stream)
152  (let ((length (length object)))
153    (when (> length 0)
154      (dotimes (i (1- length))
155        (declare (type index i))
156        (dump-object (aref object i) stream)
157        (when (> (charpos stream) 80)
158          (%stream-terpri stream))
159        (%stream-write-char #\space stream))
160      (dump-object (aref object (1- length)) stream))
161    (%stream-write-char #\) stream)))
162
163(declaim (ftype (function (t stream) t) dump-instance))
164(defun dump-instance (object stream)
165  (write-string "#." stream)
166  (dump-object (get-instance-form object)))
167
168(declaim (ftype (function (symbol) integer) dump-uninterned-symbol-index))
169(defun dump-uninterned-symbol-index (symbol)
170  (let ((index (cdr (assoc symbol *fasl-uninterned-symbols*))))
171    (unless index
172      (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1)))
173      (setq *fasl-uninterned-symbols*
174            (acons symbol index *fasl-uninterned-symbols*)))
175    index))
176
177(declaim (ftype (function (t stream) t) dump-object))
178(defun dump-object (object stream)
179  (unless (df-handle-circularity object stream nil)
180    (cond ((consp object)
181           (dump-cons object stream))
182          ((stringp object)
183           (%stream-output-object object stream))
184          ((bit-vector-p object)
185           (%stream-output-object object stream))
186          ((vectorp object)
187           (dump-vector object stream))
188          ((or (structure-object-p object) ;; FIXME instance-p
189               (standard-object-p object)
190               (java:java-object-p object))
191           (dump-instance object stream))
192          ((and (symbolp object) ;; uninterned symbol
193                (null (symbol-package object)))
194           (write-string "#" stream)
195           (write (dump-uninterned-symbol-index object) :stream stream)
196           (write-string "?" stream))
197          (t
198           (%stream-output-object object stream)))))
199
200(defvar *the-fasl-printer-readtable*
201  (copy-readtable (get-fasl-readtable))
202  "This variable holds a copy of the FASL readtable which we need to bind
203below, in order to prevent the current readtable from influencing the content
204being written to the FASL: the READTABLE-CASE setting influences symbol printing.")
205
206(defvar *prevent-fasl-circle-detection* nil)
207
208(declaim (ftype (function (t stream) t) dump-form))
209(defun dump-form (form stream)
210  (let ((*print-fasl* t)
211        (*print-array* t)
212        (*print-base* 10)
213        (*print-case* :upcase)
214        (*print-circle* nil)
215        (*print-escape* t)
216        (*print-gensym* t)
217        (*print-length* nil)
218        (*print-level* nil)
219        (*print-lines* nil)
220        (*print-pretty* nil)
221        (*print-radix* nil)
222#+nil ;; XXX Some types (q.v. (UNSIGNED-BYTE 32)) don't have a
223      ;; readable syntax because they don't roundtrip to the same
224      ;; type, but still return a Lisp object that "works", albeit
225      ;; perhaps inefficiently when READ from their DUMP-FORM
226      ;; representation.
227        (*print-readably* t)
228        (*print-right-margin* nil)
229        (*print-structure* t)
230        (*readtable* *the-fasl-printer-readtable*)
231
232        ;; make sure to write all floats with their exponent marker:
233        ;; the dump-time default may not be the same at load-time
234        (*read-default-float-format* nil)
235
236        ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
237        ;; but not used by our reader/printer, so don't bind them,
238        ;; for efficiency reasons.
239        ;;        (*read-eval* t)
240        ;;        (*read-suppress* nil)
241        ;;        (*print-miser-width* nil)
242        ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
243        ;;        (*read-base* 10)
244        ;;        (*read-default-float-format* 'single-float)
245        ;;        (*readtable* (copy-readtable nil))
246
247        (*circularity* (make-hash-table :test #'eq))
248        (*instance-forms* (make-hash-table :test #'eq))
249        (*circle-counter* 0))
250    (unless *prevent-fasl-circle-detection*
251      (df-check-object form))
252    (dump-object form stream)))
253
254(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.