source: branches/streams/abcl/src/org/armedbear/lisp/dump-form.lisp

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

Fix #274: Infinite loop when compiling COM.INFORMATIMAGO.COMMON-LISP.CESARUM.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 10.4 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 14426 2013-03-07 21:38:26Z 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     (when (eq :circular (df-register-circularity object))
79       (return))))
80
81(defun df-check-vector (object)
82  (dotimes (index (length object))
83    (df-check-object (aref object index))))
84
85(defun df-check-instance (object)
86  (df-check-object (get-instance-form object)))
87
88(defun df-check-object (object)
89  (unless (eq :circular (df-register-circularity object))
90    (cond
91      ((consp object) (df-check-cons object))
92      ((vectorp object) (df-check-vector object))
93      ((or (structure-object-p object)
94           (standard-object-p object)
95           (java:java-object-p object))
96       (df-check-instance object)))))
97
98(defun df-handle-circularity (object stream within-list)
99  (let ((index (gethash object *circularity*)))
100    (cond
101      ((eq index :circular)
102       (setf index
103             (incf *circle-counter*))
104       (setf (gethash object *circularity*) index)
105       (when within-list
106         (write-string " . " stream))
107       (%stream-write-char #\# stream)
108       (write index :stream stream)
109       (%stream-write-char #\= stream)
110       (when within-list
111         (dump-cons object stream)  ;; ### *cough*
112         (return-from df-handle-circularity t))
113       (return-from df-handle-circularity))
114      ((integerp index)
115       (when within-list
116         (write-string " . " stream))
117       (%stream-write-char #\# stream)
118       (write index :stream stream)
119       (%stream-write-char #\# stream)
120       (%stream-write-char #\Space stream)
121       (return-from df-handle-circularity t))
122      (t
123       (unless *prevent-fasl-circle-detection*
124         (assert (or (eq index t)
125                     (integerp object)))))))) ;; strictly this should be 'long'
126
127(declaim (ftype (function (cons stream) t) dump-cons))
128(defun dump-cons (object stream)
129  (cond ((and (eq (car object) 'QUOTE) (proper-list-of-length-p object 2))
130         (%stream-write-char #\' stream)
131         (dump-object (%cadr object) stream))
132        (t
133         (%stream-write-char #\( stream)
134         (loop
135            (dump-object (%car object) stream)
136            (setf object (%cdr object))
137            (when (null object)
138              (return)) ;; escape loop
139            (%stream-write-char #\space stream)
140            (when (atom object)
141              (%stream-write-char #\. stream)
142              (%stream-write-char #\space stream)
143              (dump-object object stream)
144              (return))
145            (when (df-handle-circularity object stream t)
146              (return))
147            (when (> (charpos stream) 80)
148              (%stream-terpri stream)))
149         (%stream-write-char #\) stream))))
150
151(declaim (ftype (function (t stream) t) dump-vector))
152(defun dump-vector (object stream)
153  (write-string "#(" stream)
154  (let ((length (length object)))
155    (when (> length 0)
156      (dotimes (i (1- length))
157        (declare (type index i))
158        (dump-object (aref object i) stream)
159        (when (> (charpos stream) 80)
160          (%stream-terpri stream))
161        (%stream-write-char #\space stream))
162      (dump-object (aref object (1- length)) stream))
163    (%stream-write-char #\) stream)))
164
165(declaim (ftype (function (t stream) t) dump-instance))
166(defun dump-instance (object stream)
167  (write-string "#." stream)
168  (dump-object (get-instance-form object) stream))
169
170(declaim (ftype (function (symbol) integer) dump-uninterned-symbol-index))
171(defun dump-uninterned-symbol-index (symbol)
172  (let ((index (cdr (assoc symbol *fasl-uninterned-symbols*))))
173    (unless index
174      (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1)))
175      (setq *fasl-uninterned-symbols*
176            (acons symbol index *fasl-uninterned-symbols*)))
177    index))
178
179(declaim (ftype (function (pathname stream) t) dump-pathname))
180(defun dump-pathname (pathname stream)
181  (write-string "#P(" stream)
182  (write-string ":HOST " stream)
183  (dump-form (pathname-host pathname) stream)
184  (write-string " :DEVICE " stream)
185  (dump-form (pathname-device pathname) stream)
186  (write-string " :DIRECTORY " stream)
187  (dump-form (pathname-directory pathname) stream)
188  (write-string " :NAME " stream)
189  (dump-form (pathname-name pathname) stream)
190  (write-string " :TYPE " stream)
191  (dump-form (pathname-type pathname) stream)
192  (write-string " :VERSION " stream)
193  (dump-form (pathname-version pathname) stream)
194  (write-string ")" stream))
195
196(declaim (ftype (function (t stream) t) dump-object))
197(defun dump-object (object stream)
198  (unless (df-handle-circularity object stream nil)
199    (cond ((consp object)
200           (dump-cons object stream))
201          ((stringp object)
202           (%stream-output-object object stream))
203          ((pathnamep object)
204           (dump-pathname object stream))
205          ((bit-vector-p object)
206           (%stream-output-object object stream))
207          ((vectorp object)
208           (dump-vector object stream))
209          ((or (structure-object-p object) ;; FIXME instance-p
210               (standard-object-p object)
211               (java:java-object-p object))
212           (dump-instance object stream))
213          ((and (symbolp object) ;; uninterned symbol
214                (null (symbol-package object)))
215           (write-string "#" stream)
216           (write (dump-uninterned-symbol-index object) :stream stream)
217           (write-string "?" stream))
218          (t
219           (%stream-output-object object stream)))))
220
221(defvar *the-fasl-printer-readtable*
222  (copy-readtable (get-fasl-readtable))
223  "This variable holds a copy of the FASL readtable which we need to bind
224below, in order to prevent the current readtable from influencing the content
225being written to the FASL: the READTABLE-CASE setting influences symbol printing.")
226
227(defvar *prevent-fasl-circle-detection* nil)
228
229(declaim (ftype (function (t stream) t) dump-form))
230(defun dump-form (form stream)
231  (let ((*print-fasl* t)
232        (*print-array* t)
233        (*print-base* 10)
234        (*print-case* :upcase)
235        (*print-circle* nil)
236        (*print-escape* t)
237        (*print-gensym* t)
238        (*print-length* nil)
239        (*print-level* nil)
240        (*print-lines* nil)
241        (*print-pretty* nil)
242        (*print-radix* nil)
243#+nil ;; XXX Some types (q.v. (UNSIGNED-BYTE 32)) don't have a
244      ;; readable syntax because they don't roundtrip to the same
245      ;; type, but still return a Lisp object that "works", albeit
246      ;; perhaps inefficiently when READ from their DUMP-FORM
247      ;; representation.
248        (*print-readably* t)
249        (*print-right-margin* nil)
250        (*print-structure* t)
251        (*readtable* *the-fasl-printer-readtable*)
252
253        ;; make sure to write all floats with their exponent marker:
254        ;; the dump-time default may not be the same at load-time
255        (*read-default-float-format* nil)
256
257        ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
258        ;; but not used by our reader/printer, so don't bind them,
259        ;; for efficiency reasons.
260        ;;        (*read-eval* t)
261        ;;        (*read-suppress* nil)
262        ;;        (*print-miser-width* nil)
263        ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
264        ;;        (*read-base* 10)
265        ;;        (*read-default-float-format* 'single-float)
266        ;;        (*readtable* (copy-readtable nil))
267
268        (*circularity* (make-hash-table :test #'eq))
269        (*instance-forms* (make-hash-table :test #'eq))
270        (*circle-counter* 0))
271;;    (print form)
272    (unless *prevent-fasl-circle-detection*
273      (df-check-object form))
274    (dump-object form stream)))
275
276(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.