[armedbear-cvs] r13600 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Mon Sep 19 20:49:31 UTC 2011
Author: ehuelsmann
Date: Mon Sep 19 13:49:29 2011
New Revision: 13600
Log:
Fix #143: Support circularity in serialized forms
-- this enables compilation of CLOSURE-HTML.
Modified:
trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
trunk/abcl/src/org/armedbear/lisp/dump-form.lisp
trunk/abcl/src/org/armedbear/lisp/read-circle.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Mon Sep 19 13:44:03 2011 (r13599)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Mon Sep 19 13:49:29 2011 (r13600)
@@ -81,7 +81,8 @@
(defun %compile-system (&key output-path)
(let ((*default-pathname-defaults* (pathname *lisp-home*))
- (*warn-on-redefinition* nil))
+ (*warn-on-redefinition* nil)
+ (*prevent-fasl-circle-detection* t))
(unless output-path
(setf output-path *default-pathname-defaults*))
(flet ((do-compile (file)
Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Mon Sep 19 13:44:03 2011 (r13599)
+++ trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Mon Sep 19 13:49:29 2011 (r13600)
@@ -33,6 +33,95 @@
(export '(dump-form dump-uninterned-symbol-index))
+(declaim (special *circularity* *circle-counter* *instance-forms*))
+
+
+(defun get-instance-form (object)
+ (multiple-value-bind
+ (value presence)
+ (gethash object *instance-forms*)
+ (cond
+ (presence value)
+ (t
+ (multiple-value-bind (creation-form initialization-form)
+ (make-load-form object)
+ (if initialization-form
+ (let* ((instance (gensym))
+ load-form)
+ (setf initialization-form
+ (subst instance object initialization-form))
+ (setf initialization-form
+ (subst instance (list 'quote instance) initialization-form
+ :test #'equal))
+ (setf load-form `(progn
+ (let ((,instance ,creation-form))
+ ,initialization-form
+ ,instance)))
+ (setf (gethash object *instance-forms*) load-form))
+ (setf (gethash object *instance-forms*) creation-form)))))))
+
+(defun df-register-circularity (object)
+ (setf (gethash object *circularity*)
+ (if (gethash object *circularity*)
+ :circular
+ t)))
+
+(defun df-check-cons (object)
+ (loop
+ (df-check-object (car object))
+ (setf object (cdr object))
+ (when (atom object)
+ (df-check-object object)
+ (return))
+ (when (null object)
+ (return-from df-check-cons))
+ (df-register-circularity object)))
+
+(defun df-check-vector (object)
+ (dotimes (index (length object))
+ (df-check-object (aref object index))))
+
+(defun df-check-instance (object)
+ (df-check-object (get-instance-form object)))
+
+(defun df-check-object (object)
+ (unless (eq :circular (df-register-circularity object))
+ (cond
+ ((consp object) (df-check-cons object))
+ ((vectorp object) (df-check-vector object))
+ ((or (structure-object-p object)
+ (standard-object-p object)
+ (java:java-object-p object))
+ (df-check-instance object)))))
+
+(defun df-handle-circularity (object stream within-list)
+ (let ((index (gethash object *circularity*)))
+ (cond
+ ((eq index :circular)
+ (setf index
+ (incf *circle-counter*))
+ (setf (gethash object *circularity*) index)
+ (when within-list
+ (write-string " . " stream))
+ (%stream-write-char #\# stream)
+ (write index :stream stream)
+ (%stream-write-char #\= stream)
+ (when within-list
+ (dump-cons object stream) ;; ### *cough*
+ (return-from df-handle-circularity t))
+ (return-from df-handle-circularity))
+ ((integerp index)
+ (when within-list
+ (write-string " . " stream))
+ (%stream-write-char #\# stream)
+ (write index :stream stream)
+ (%stream-write-char #\# stream)
+ (%stream-write-char #\Space stream)
+ (return-from df-handle-circularity t))
+ (t
+ (unless *prevent-fasl-circle-detection*
+ (assert (eq index t)))))))
+
(declaim (ftype (function (cons stream) t) dump-cons))
(defun dump-cons (object stream)
(cond ((and (eq (car object) 'QUOTE) (= (length object) 2))
@@ -41,18 +130,20 @@
(t
(%stream-write-char #\( stream)
(loop
- (dump-object (%car object) stream)
- (setf object (%cdr object))
- (when (null object)
- (return))
- (when (> (charpos stream) 80)
- (%stream-terpri stream))
- (%stream-write-char #\space stream)
- (when (atom object)
- (%stream-write-char #\. stream)
- (%stream-write-char #\space stream)
- (dump-object object stream)
- (return)))
+ (dump-object (%car object) stream)
+ (setf object (%cdr object))
+ (when (null object)
+ (return)) ;; escape loop
+ (%stream-write-char #\space stream)
+ (when (atom object)
+ (%stream-write-char #\. stream)
+ (%stream-write-char #\space stream)
+ (dump-object object stream)
+ (return))
+ (when (df-handle-circularity object stream t)
+ (return))
+ (when (> (charpos stream) 80)
+ (%stream-terpri stream)))
(%stream-write-char #\) stream))))
(declaim (ftype (function (t stream) t) dump-vector))
@@ -71,23 +162,8 @@
(declaim (ftype (function (t stream) t) dump-instance))
(defun dump-instance (object stream)
- (multiple-value-bind (creation-form initialization-form)
- (make-load-form object)
- (write-string "#." stream)
- (if initialization-form
- (let* ((instance (gensym))
- load-form)
- (setf initialization-form
- (subst instance object initialization-form))
- (setf initialization-form
- (subst instance (list 'quote instance) initialization-form
- :test #'equal))
- (setf load-form `(progn
- (let ((,instance ,creation-form))
- ,initialization-form
- ,instance)))
- (dump-object load-form stream))
- (dump-object creation-form stream))))
+ (write-string "#." stream)
+ (dump-object (get-instance-form object)))
(declaim (ftype (function (symbol) integer) dump-uninterned-symbol-index))
(defun dump-uninterned-symbol-index (symbol)
@@ -100,25 +176,26 @@
(declaim (ftype (function (t stream) t) dump-object))
(defun dump-object (object stream)
- (cond ((consp object)
- (dump-cons object stream))
- ((stringp object)
- (%stream-output-object object stream))
- ((bit-vector-p object)
- (%stream-output-object object stream))
- ((vectorp object)
- (dump-vector object stream))
- ((or (structure-object-p object) ;; FIXME instance-p
- (standard-object-p object)
- (java:java-object-p object))
- (dump-instance object stream))
- ((and (symbolp object) ;; uninterned symbol
- (null (symbol-package object)))
- (write-string "#" stream)
- (write (dump-uninterned-symbol-index object) :stream stream)
- (write-string "?" stream))
- (t
- (%stream-output-object object stream))))
+ (unless (df-handle-circularity object stream nil)
+ (cond ((consp object)
+ (dump-cons object stream))
+ ((stringp object)
+ (%stream-output-object object stream))
+ ((bit-vector-p object)
+ (%stream-output-object object stream))
+ ((vectorp object)
+ (dump-vector object stream))
+ ((or (structure-object-p object) ;; FIXME instance-p
+ (standard-object-p object)
+ (java:java-object-p object))
+ (dump-instance object stream))
+ ((and (symbolp object) ;; uninterned symbol
+ (null (symbol-package object)))
+ (write-string "#" stream)
+ (write (dump-uninterned-symbol-index object) :stream stream)
+ (write-string "?" stream))
+ (t
+ (%stream-output-object object stream)))))
(defvar *the-fasl-printer-readtable*
(copy-readtable (get-fasl-readtable))
@@ -126,6 +203,8 @@
below, in order to prevent the current readtable from influencing the content
being written to the FASL: the READTABLE-CASE setting influences symbol printing.")
+(defvar *prevent-fasl-circle-detection* nil)
+
(declaim (ftype (function (t stream) t) dump-form))
(defun dump-form (form stream)
(let ((*print-fasl* t)
@@ -164,7 +243,12 @@
;; (*read-base* 10)
;; (*read-default-float-format* 'single-float)
;; (*readtable* (copy-readtable nil))
- )
+
+ (*circularity* (make-hash-table :test #'eq))
+ (*instance-forms* (make-hash-table :test #'eq))
+ (*circle-counter* 0))
+ (unless *prevent-fasl-circle-detection*
+ (df-check-object form))
(dump-object form stream)))
(provide 'dump-form)
Modified: trunk/abcl/src/org/armedbear/lisp/read-circle.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/read-circle.lisp Mon Sep 19 13:44:03 2011 (r13599)
+++ trunk/abcl/src/org/armedbear/lisp/read-circle.lisp Mon Sep 19 13:49:29 2011 (r13600)
@@ -124,8 +124,7 @@
(defvar *sharp-sharp-alist* ())
-(defun sharp-equal (stream ignore label)
- (declare (ignore ignore))
+(defun sharp-equal (stream label readtable)
(when *read-suppress* (return-from sharp-equal (values)))
(unless label
(error 'reader-error
@@ -139,7 +138,8 @@
:format-arguments (list label)))
(let* ((tag (gensym))
(*sharp-sharp-alist* (cons (list label tag nil) *sharp-sharp-alist*))
- (obj (read stream t nil t)))
+ (obj (let ((*readtable* readtable))
+ (read stream t nil t))))
(when (eq obj tag)
(error 'reader-error
:stream stream
@@ -151,6 +151,8 @@
(circle-subst *sharp-equal-alist* obj)))
obj))
+()
+
(defun sharp-sharp (stream ignore label)
(declare (ignore ignore))
(when *read-suppress* (return-from sharp-sharp nil))
@@ -168,6 +170,17 @@
(setf (third pair) t)
(second pair)))))
-(set-dispatch-macro-character #\# #\= #'sharp-equal +standard-readtable+)
+(set-dispatch-macro-character #\# #\= #'(lambda (stream ignore label)
+ (declare (ignore ignore))
+ (sharp-equal stream label
+ *readtable*))
+ +standard-readtable+)
(set-dispatch-macro-character #\# #\# #'sharp-sharp +standard-readtable+)
+(set-dispatch-macro-character #\# #\= #'(lambda (stream ignore label)
+ (declare (ignore ignore))
+ (sharp-equal stream label
+ (get-fasl-readtable)))
+ (get-fasl-readtable))
+(set-dispatch-macro-character #\# #\# #'sharp-sharp (get-fasl-readtable))
+
More information about the armedbear-cvs
mailing list