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

Last change on this file since 13274 was 13274, checked in by ehuelsmann, 10 years ago

Fix 147: *PRINT-CASE* setting affects COMPILE-FILE.

Found by Dan Corkill.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.1 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 13274 2011-05-04 19:13:32Z 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 (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        (*print-readably* t)
138        (*print-right-margin* nil)
139        (*print-structure* t)
140
141        ;; make sure to write all floats with their exponent marker:
142        ;; the dump-time default may not be the same at load-time
143        (*read-default-float-format* nil)
144
145        ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
146        ;; but not used by our reader/printer, so don't bind them,
147        ;; for efficiency reasons.
148        ;;        (*read-eval* t)
149        ;;        (*read-suppress* nil)
150        ;;        (*print-miser-width* nil)
151        ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
152        ;;        (*read-base* 10)
153        ;;        (*read-default-float-format* 'single-float)
154        ;;        (*readtable* (copy-readtable nil))
155        )
156    (dump-object form stream)))
157
158(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.