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

Last change on this file since 13380 was 13380, checked in by Mark Evenson, 11 years ago

Fasls are no no longer created with *PRINT-READABLY*.

This fixes #156 in which the compiler could no longer dump forms into
the fasls containing arrays of (UNSIGNED-BYTE 32) because in r13274 we
required that all forms be created with a non-nil *PRINT-READABLY*.
Presumably, SimpleArray_UnsignedByte32.writeToString() signals an
error when invoked with a non-NIL *PRINT-READABLY* because the
resulting read of the form will not necessarily be of the specified
base type.

With this change, we restore ABCL's behavior before r13274 to fix
#147, which is to read a create a less precise type from the fasl.

The more correct solution would be to dump some aspects of the fasls
directly into JVM code that would perform the stricter intialization.

Tests added for both cases to ensure this remains fixed.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.4 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 13380 2011-07-08 08:40:37Z mevenson $
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 (ftype (function (cons stream) t) dump-cons))
37(defun dump-cons (object stream)
38  (cond ((and (eq (car object) 'QUOTE) (= (length object) 2))
39         (%stream-write-char #\' stream)
40         (dump-object (%cadr object) stream))
41        (t
42         (%stream-write-char #\( stream)
43         (loop
44           (dump-object (%car object) stream)
45           (setf object (%cdr object))
46           (when (null object)
47             (return))
48           (when (> (charpos stream) 80)
49             (%stream-terpri stream))
50           (%stream-write-char #\space stream)
51           (when (atom object)
52             (%stream-write-char #\. stream)
53             (%stream-write-char #\space stream)
54             (dump-object object stream)
55             (return)))
56         (%stream-write-char #\) stream))))
57
58(declaim (ftype (function (t stream) t) dump-vector))
59(defun dump-vector (object stream)
60  (write-string "#(" stream)
61  (let ((length (length object)))
62    (when (> length 0)
63      (dotimes (i (1- length))
64        (declare (type index i))
65        (dump-object (aref object i) stream)
66        (when (> (charpos stream) 80)
67          (%stream-terpri stream))
68        (%stream-write-char #\space stream))
69      (dump-object (aref object (1- length)) stream))
70    (%stream-write-char #\) stream)))
71
72(declaim (ftype (function (t stream) t) dump-instance))
73(defun dump-instance (object stream)
74  (multiple-value-bind (creation-form initialization-form)
75      (make-load-form object)
76    (write-string "#." stream)
77    (if initialization-form
78        (let* ((instance (gensym))
79               load-form)
80          (setf initialization-form
81                (subst instance object initialization-form))
82          (setf initialization-form
83                (subst instance (list 'quote instance) initialization-form
84                       :test #'equal))
85          (setf load-form `(progn
86                             (let ((,instance ,creation-form))
87                               ,initialization-form
88                               ,instance)))
89          (dump-object load-form stream))
90        (dump-object creation-form stream))))
91
92(declaim (ftype (function (symbol) integer) dump-uninterned-symbol-index))
93(defun dump-uninterned-symbol-index (symbol)
94  (let ((index (cdr (assoc symbol *fasl-uninterned-symbols*))))
95    (unless index
96      (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1)))
97      (setq *fasl-uninterned-symbols*
98            (acons symbol index *fasl-uninterned-symbols*)))
99    index))
100
101(declaim (ftype (function (t stream) t) dump-object))
102(defun dump-object (object stream)
103  (cond ((consp object)
104         (dump-cons object stream))
105        ((stringp object)
106         (%stream-output-object object stream))
107        ((bit-vector-p object)
108         (%stream-output-object object stream))
109        ((vectorp object)
110         (dump-vector object stream))
111        ((or (structure-object-p object) ;; FIXME instance-p
112             (standard-object-p object)
113             (java:java-object-p object))
114         (dump-instance object stream))
115        ((and (symbolp object) ;; uninterned symbol
116              (null (symbol-package object)))
117         (write-string "#" stream)
118         (write (dump-uninterned-symbol-index object) :stream stream)
119         (write-string "?" stream))
120        (t
121         (%stream-output-object object stream))))
122
123(declaim (ftype (function (t stream) t) dump-form))
124(defun dump-form (form stream)
125  (let ((*print-fasl* t)
126        (*print-array* t)
127        (*print-base* 10)
128        (*print-case* :upcase)
129        (*print-circle* nil)
130        (*print-escape* t)
131        (*print-gensym* t)
132        (*print-length* nil)
133        (*print-level* nil)
134        (*print-lines* nil)
135        (*print-pretty* nil)
136        (*print-radix* nil)
137#+nil ;; XXX Some types (q.v. (UNSIGNED-BYTE 32)) don't have a
138      ;; readable syntax because they don't roundtrip to the same
139      ;; type, but still return a Lisp object that "works", albeit
140      ;; perhaps inefficiently when READ from their DUMP-FORM
141      ;; representation.
142        (*print-readably* t)
143        (*print-right-margin* nil)
144        (*print-structure* t)
145
146        ;; make sure to write all floats with their exponent marker:
147        ;; the dump-time default may not be the same at load-time
148        (*read-default-float-format* nil)
149
150        ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
151        ;; but not used by our reader/printer, so don't bind them,
152        ;; for efficiency reasons.
153        ;;        (*read-eval* t)
154        ;;        (*read-suppress* nil)
155        ;;        (*print-miser-width* nil)
156        ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
157        ;;        (*read-base* 10)
158        ;;        (*read-default-float-format* 'single-float)
159        ;;        (*readtable* (copy-readtable nil))
160        )
161    (dump-object form stream)))
162
163(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.