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

Last change on this file since 11566 was 11566, checked in by ehuelsmann, 13 years ago

Make sure to dump all floats with exponent marker, because when loaded, the default may differ.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 4.7 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 11566 2009-01-18 21:04:07Z 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        (t
107         (%stream-output-object object stream))))
108
109(declaim (ftype (function (t stream) t) dump-form))
110(defun dump-form (form stream)
111  (let ((*print-fasl* t)
112        (*print-level* nil)
113        (*print-length* nil)
114        (*print-circle* nil)
115        (*print-structure* t)
116        ;; make sure to write all floats with their exponent marker:
117        ;; the dump-time default may not be the same at load-time
118        (*read-default-float-format* nil))
119    (dump-object form stream)))
120
121(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.