Changeset 13600


Ignore:
Timestamp:
09/19/11 20:49:29 (12 years ago)
Author:
ehuelsmann
Message:

Fix #143: Support circularity in serialized forms

-- this enables compilation of CLOSURE-HTML.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

    r13451 r13600  
    8282(defun %compile-system (&key output-path)
    8383  (let ((*default-pathname-defaults* (pathname *lisp-home*))
    84         (*warn-on-redefinition* nil))
     84        (*warn-on-redefinition* nil)
     85        (*prevent-fasl-circle-detection* t))
    8586    (unless output-path
    8687      (setf output-path *default-pathname-defaults*))

  • trunk/abcl/src/org/armedbear/lisp/dump-form.lisp

    r13516 r13600  
    3434(export '(dump-form dump-uninterned-symbol-index))
    3535
     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 (eq index t)))))))
     124
    36125(declaim (ftype (function (cons stream) t) dump-cons))
    37126(defun dump-cons (object stream)
    … …  
    42131         (%stream-write-char #\( stream)
    43132         (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)))
     133            (dump-object (%car object) stream)
     134            (setf object (%cdr object))
     135            (when (null object)
     136              (return)) ;; escape loop
     137            (%stream-write-char #\space stream)
     138            (when (atom object)
     139              (%stream-write-char #\. stream)
     140              (%stream-write-char #\space stream)
     141              (dump-object object stream)
     142              (return))
     143            (when (df-handle-circularity object stream t)
     144              (return))
     145            (when (> (charpos stream) 80)
     146              (%stream-terpri stream)))
    56147         (%stream-write-char #\) stream))))
    57148
    … …  
    72163(declaim (ftype (function (t stream) t) dump-instance))
    73164(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))))
     165  (write-string "#." stream)
     166  (dump-object (get-instance-form object)))
    91167
    92168(declaim (ftype (function (symbol) integer) dump-uninterned-symbol-index))
    … …  
    101177(declaim (ftype (function (t stream) t) dump-object))
    102178(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))))
     179  (unless (df-handle-circularity object stream nil)
     180    (cond ((consp object)
     181           (dump-cons object stream))
     182          ((stringp object)
     183           (%stream-output-object object stream))
     184          ((bit-vector-p object)
     185           (%stream-output-object object stream))
     186          ((vectorp object)
     187           (dump-vector object stream))
     188          ((or (structure-object-p object) ;; FIXME instance-p
     189               (standard-object-p object)
     190               (java:java-object-p object))
     191           (dump-instance object stream))
     192          ((and (symbolp object) ;; uninterned symbol
     193                (null (symbol-package object)))
     194           (write-string "#" stream)
     195           (write (dump-uninterned-symbol-index object) :stream stream)
     196           (write-string "?" stream))
     197          (t
     198           (%stream-output-object object stream)))))
    122199
    123200(defvar *the-fasl-printer-readtable*
    … …  
    126203below, in order to prevent the current readtable from influencing the content
    127204being written to the FASL: the READTABLE-CASE setting influences symbol printing.")
     205
     206(defvar *prevent-fasl-circle-detection* nil)
    128207
    129208(declaim (ftype (function (t stream) t) dump-form))
    … …  
    165244        ;;        (*read-default-float-format* 'single-float)
    166245        ;;        (*readtable* (copy-readtable nil))
    167         )
     246
     247        (*circularity* (make-hash-table :test #'eq))
     248        (*instance-forms* (make-hash-table :test #'eq))
     249        (*circle-counter* 0))
     250    (unless *prevent-fasl-circle-detection*
     251      (df-check-object form))
    168252    (dump-object form stream)))
    169253

  • trunk/abcl/src/org/armedbear/lisp/read-circle.lisp

    r12216 r13600  
    125125(defvar *sharp-sharp-alist* ())
    126126
    127 (defun sharp-equal (stream ignore label)
    128   (declare (ignore ignore))
     127(defun sharp-equal (stream label readtable)
    129128  (when *read-suppress* (return-from sharp-equal (values)))
    130129  (unless label
    … …  
    140139  (let* ((tag (gensym))
    141140         (*sharp-sharp-alist* (cons (list label tag nil) *sharp-sharp-alist*))
    142          (obj (read stream t nil t)))
     141         (obj (let ((*readtable* readtable))
     142                (read stream t nil t))))
    143143    (when (eq obj tag)
    144144      (error 'reader-error
    … …  
    151151        (circle-subst *sharp-equal-alist* obj)))
    152152    obj))
     153
     154()
    153155
    154156(defun sharp-sharp (stream ignore label)
    … …  
    169171          (second pair)))))
    170172
    171 (set-dispatch-macro-character #\# #\= #'sharp-equal +standard-readtable+)
     173(set-dispatch-macro-character #\# #\= #'(lambda (stream ignore label)
     174                                          (declare (ignore ignore))
     175                                          (sharp-equal stream label
     176                                                       *readtable*))
     177                              +standard-readtable+)
    172178(set-dispatch-macro-character #\# #\# #'sharp-sharp +standard-readtable+)
    173179
     180(set-dispatch-macro-character #\# #\= #'(lambda (stream ignore label)
     181                                          (declare (ignore ignore))
     182                                          (sharp-equal stream label
     183                                                       (get-fasl-readtable)))
     184                              (get-fasl-readtable))
     185(set-dispatch-macro-character #\# #\# #'sharp-sharp (get-fasl-readtable))
     186
Note: See TracChangeset for help on using the changeset viewer.