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

Last change on this file since 13653 was 13653, checked in by ehuelsmann, 9 years ago

Fix IRONCLAD compilation.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.6 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 13653 2011-10-21 09:14:45Z 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 (or (eq index t)
124                     (integerp object)))))))) ;; strictly this should be 'long'
125
126(declaim (ftype (function (cons stream) t) dump-cons))
127(defun dump-cons (object stream)
128  (cond ((and (eq (car object) 'QUOTE) (= (length object) 2))
129         (%stream-write-char #\' stream)
130         (dump-object (%cadr object) stream))
131        (t
132         (%stream-write-char #\( stream)
133         (loop
134            (dump-object (%car object) stream)
135            (setf object (%cdr object))
136            (when (null object)
137              (return)) ;; escape loop
138            (%stream-write-char #\space stream)
139            (when (atom object)
140              (%stream-write-char #\. stream)
141              (%stream-write-char #\space stream)
142              (dump-object object stream)
143              (return))
144            (when (df-handle-circularity object stream t)
145              (return))
146            (when (> (charpos stream) 80)
147              (%stream-terpri stream)))
148         (%stream-write-char #\) stream))))
149
150(declaim (ftype (function (t stream) t) dump-vector))
151(defun dump-vector (object stream)
152  (write-string "#(" stream)
153  (let ((length (length object)))
154    (when (> length 0)
155      (dotimes (i (1- length))
156        (declare (type index i))
157        (dump-object (aref object i) stream)
158        (when (> (charpos stream) 80)
159          (%stream-terpri stream))
160        (%stream-write-char #\space stream))
161      (dump-object (aref object (1- length)) stream))
162    (%stream-write-char #\) stream)))
163
164(declaim (ftype (function (t stream) t) dump-instance))
165(defun dump-instance (object stream)
166  (write-string "#." stream)
167  (dump-object (get-instance-form object) stream))
168
169(declaim (ftype (function (symbol) integer) dump-uninterned-symbol-index))
170(defun dump-uninterned-symbol-index (symbol)
171  (let ((index (cdr (assoc symbol *fasl-uninterned-symbols*))))
172    (unless index
173      (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1)))
174      (setq *fasl-uninterned-symbols*
175            (acons symbol index *fasl-uninterned-symbols*)))
176    index))
177
178(declaim (ftype (function (t stream) t) dump-object))
179(defun dump-object (object stream)
180  (unless (df-handle-circularity object stream nil)
181    (cond ((consp object)
182           (dump-cons object stream))
183          ((stringp object)
184           (%stream-output-object object stream))
185          ((bit-vector-p object)
186           (%stream-output-object object stream))
187          ((vectorp object)
188           (dump-vector object stream))
189          ((or (structure-object-p object) ;; FIXME instance-p
190               (standard-object-p object)
191               (java:java-object-p object))
192           (dump-instance object stream))
193          ((and (symbolp object) ;; uninterned symbol
194                (null (symbol-package object)))
195           (write-string "#" stream)
196           (write (dump-uninterned-symbol-index object) :stream stream)
197           (write-string "?" stream))
198          (t
199           (%stream-output-object object stream)))))
200
201(defvar *the-fasl-printer-readtable*
202  (copy-readtable (get-fasl-readtable))
203  "This variable holds a copy of the FASL readtable which we need to bind
204below, in order to prevent the current readtable from influencing the content
205being written to the FASL: the READTABLE-CASE setting influences symbol printing.")
206
207(defvar *prevent-fasl-circle-detection* nil)
208
209(declaim (ftype (function (t stream) t) dump-form))
210(defun dump-form (form stream)
211  (let ((*print-fasl* t)
212        (*print-array* t)
213        (*print-base* 10)
214        (*print-case* :upcase)
215        (*print-circle* nil)
216        (*print-escape* t)
217        (*print-gensym* t)
218        (*print-length* nil)
219        (*print-level* nil)
220        (*print-lines* nil)
221        (*print-pretty* nil)
222        (*print-radix* nil)
223#+nil ;; XXX Some types (q.v. (UNSIGNED-BYTE 32)) don't have a
224      ;; readable syntax because they don't roundtrip to the same
225      ;; type, but still return a Lisp object that "works", albeit
226      ;; perhaps inefficiently when READ from their DUMP-FORM
227      ;; representation.
228        (*print-readably* t)
229        (*print-right-margin* nil)
230        (*print-structure* t)
231        (*readtable* *the-fasl-printer-readtable*)
232
233        ;; make sure to write all floats with their exponent marker:
234        ;; the dump-time default may not be the same at load-time
235        (*read-default-float-format* nil)
236
237        ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
238        ;; but not used by our reader/printer, so don't bind them,
239        ;; for efficiency reasons.
240        ;;        (*read-eval* t)
241        ;;        (*read-suppress* nil)
242        ;;        (*print-miser-width* nil)
243        ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
244        ;;        (*read-base* 10)
245        ;;        (*read-default-float-format* 'single-float)
246        ;;        (*readtable* (copy-readtable nil))
247
248        (*circularity* (make-hash-table :test #'eq))
249        (*instance-forms* (make-hash-table :test #'eq))
250        (*circle-counter* 0))
251    (unless *prevent-fasl-circle-detection*
252      (df-check-object form))
253    (dump-object form stream)))
254
255(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.