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

Last change on this file since 12650 was 12650, checked in by ehuelsmann, 11 years ago

Fix #79: Equally named -but different- uninterned symbols coalesced into
one in FASLs.

This commit removes the *FASL-ANONYMOUS-PACKAGE*: it's replaced by
*FASL-UNINTERNED-SYMBOLS* and a dispatch macro function which resolves
symbols by index instead of by name.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 5.2 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 12650 2010-05-02 19:58:56Z 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)
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 (t stream) t) dump-object))
93(defun dump-object (object stream)
94  (cond ((consp object)
95         (dump-cons object stream))
96        ((stringp object)
97         (%stream-output-object object stream))
98        ((bit-vector-p object)
99         (%stream-output-object object stream))
100        ((vectorp object)
101         (dump-vector object stream))
102        ((or (structure-object-p object) ;; FIXME instance-p
103             (standard-object-p object)
104             (java:java-object-p object))
105         (dump-instance object stream))
106        ((and (symbolp object) ;; uninterned symbol
107              (null (symbol-package object)))
108         (let ((index (cdr (assoc object *fasl-uninterned-symbols*))))
109           (unless index
110             (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1)))
111             (setq *fasl-uninterned-symbols*
112                   (acons object index *fasl-uninterned-symbols*)))
113           (write-string "#" stream)
114           (write index :stream stream)
115           (write-string "?" stream)))
116        (t
117         (%stream-output-object object stream))))
118
119(declaim (ftype (function (t stream) t) dump-form))
120(defun dump-form (form stream)
121  (let ((*print-fasl* t)
122        (*print-level* nil)
123        (*print-length* nil)
124        (*print-circle* nil)
125        (*print-structure* t)
126        ;; make sure to write all floats with their exponent marker:
127        ;; the dump-time default may not be the same at load-time
128        (*read-default-float-format* nil))
129    (dump-object form stream)))
130
131(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.