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

Last change on this file since 14176 was 14176, checked in by Mark Evenson, 8 years ago

Refactor PATHNAME implementation details to tighten existing semantics.

None of this should change the behavior of CL:PATHNAME, but it
prepares for that in subsequent patches to address problems in merging
when the defaults points to a JAR-PATHNAME.

Fix COMPILE-FILE to work with source located in jar archive.

Moved Utilities.getFile() to instance method of Pathname which makes
more logical sense. Moved Utilities.getPathnameDirectory() to static
instance classes. These functions no longer merge their argument with
*DEFAULT-PATHNAME-DEFAULTS*, as this should be done explictly at a
higher level in the Lisp calling into Java abstraction.

RENAME-FILE no longer on namestrings, but instead use the result of
TRUENAME invocation, as namestrings will not always roundtrip
exactly back to PATHNAMES.

POPULATE-ZIP-FASL no longer forms its argumentes by merging paths,
instead using MAKE-PATHNAME with controlled defaults.

SYSTEM:NEXT-CLASSFILE-NAME and SYSTEM:COMPUTE-CLASSFILE-NAME changed
to NEXT-CLASSFILE and COMPUTE-CLASSFILE returning PATHNAME objects
rather than namestrings.

Compiler now dumps pathname in alternate form that preserves DEVICE
:UNSPECIFIC.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 10.3 KB
Line 
1;;; dump-form.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
4;;; $Id: dump-form.lisp 14176 2012-10-11 11:33:19Z 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 (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 (pathname stream) t) dump-pathname))
179(defun dump-pathname (pathname stream)
180  (write-string "#P(" stream)
181  (write-string ":HOST " stream)
182  (dump-form (pathname-host pathname) stream)
183  (write-string " :DEVICE " stream)
184  (dump-form (pathname-device pathname) stream)
185  (write-string " :DIRECTORY " stream)
186  (dump-form (pathname-directory pathname) stream)
187  (write-string " :NAME " stream)
188  (dump-form (pathname-name pathname) stream)
189  (write-string " :TYPE " stream)
190  (dump-form (pathname-type pathname) stream)
191  (write-string " :VERSION " stream)
192  (dump-form (pathname-version pathname) stream)
193  (write-string ")" stream))
194
195(declaim (ftype (function (t stream) t) dump-object))
196(defun dump-object (object stream)
197  (unless (df-handle-circularity object stream nil)
198    (cond ((consp object)
199           (dump-cons object stream))
200          ((stringp object)
201           (%stream-output-object object stream))
202          ((pathnamep object)
203           (dump-pathname object stream))
204          ((bit-vector-p object)
205           (%stream-output-object object stream))
206          ((vectorp object)
207           (dump-vector object stream))
208          ((or (structure-object-p object) ;; FIXME instance-p
209               (standard-object-p object)
210               (java:java-object-p object))
211           (dump-instance object stream))
212          ((and (symbolp object) ;; uninterned symbol
213                (null (symbol-package object)))
214           (write-string "#" stream)
215           (write (dump-uninterned-symbol-index object) :stream stream)
216           (write-string "?" stream))
217          (t
218           (%stream-output-object object stream)))))
219
220(defvar *the-fasl-printer-readtable*
221  (copy-readtable (get-fasl-readtable))
222  "This variable holds a copy of the FASL readtable which we need to bind
223below, in order to prevent the current readtable from influencing the content
224being written to the FASL: the READTABLE-CASE setting influences symbol printing.")
225
226(defvar *prevent-fasl-circle-detection* nil)
227
228(declaim (ftype (function (t stream) t) dump-form))
229(defun dump-form (form stream)
230  (let ((*print-fasl* t)
231        (*print-array* t)
232        (*print-base* 10)
233        (*print-case* :upcase)
234        (*print-circle* nil)
235        (*print-escape* t)
236        (*print-gensym* t)
237        (*print-length* nil)
238        (*print-level* nil)
239        (*print-lines* nil)
240        (*print-pretty* nil)
241        (*print-radix* nil)
242#+nil ;; XXX Some types (q.v. (UNSIGNED-BYTE 32)) don't have a
243      ;; readable syntax because they don't roundtrip to the same
244      ;; type, but still return a Lisp object that "works", albeit
245      ;; perhaps inefficiently when READ from their DUMP-FORM
246      ;; representation.
247        (*print-readably* t)
248        (*print-right-margin* nil)
249        (*print-structure* t)
250        (*readtable* *the-fasl-printer-readtable*)
251
252        ;; make sure to write all floats with their exponent marker:
253        ;; the dump-time default may not be the same at load-time
254        (*read-default-float-format* nil)
255
256        ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
257        ;; but not used by our reader/printer, so don't bind them,
258        ;; for efficiency reasons.
259        ;;        (*read-eval* t)
260        ;;        (*read-suppress* nil)
261        ;;        (*print-miser-width* nil)
262        ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
263        ;;        (*read-base* 10)
264        ;;        (*read-default-float-format* 'single-float)
265        ;;        (*readtable* (copy-readtable nil))
266
267        (*circularity* (make-hash-table :test #'eq))
268        (*instance-forms* (make-hash-table :test #'eq))
269        (*circle-counter* 0))
270    (unless *prevent-fasl-circle-detection*
271      (df-check-object form))
272    (dump-object form stream)))
273
274(provide 'dump-form)
Note: See TracBrowser for help on using the repository browser.