Use MAKE-LOAD-FORM to compile constants that do not have a readable printed representation (Brian Spilsbury)

src/CHANGELOG

@@ -108,6 +108,11 @@ ECL 0.9i
    OpenBSD & Ubuntu. You may need to supply appropiate LDFLAGS & CFLAGS for the
    configuration to detect the headers.
 
+ - ECL now can compile files with constants that do not print readably, such as
+   CLOS objects. In those cases, MAKE-LOAD-FORM is used to recreate these
+   constants. The only case where this fail is when the "unreadable" constant
+   is part of a circular structure (contributed by Brian Spilsbury).
+
 * MOP compatibility:
 
  - SLOT-VALUE, SLOT-BOUNDP, etc, together with MOP SLOT*-USING-CLASS generic

src/clos/print.lsp

@@ -12,6 +12,11 @@
 ;;; ----------------------------------------------------------------------
 ;;; Load forms
 ;;;
+;;; ECL extends the ANSI specification by allowing to use MAKE-LOAD-FORM on any
+;;; kind of lisp object. The only caveats is that ECL currently does not
+;;; support circularity when the object has to be externalized using lisp
+;;; forms. For instance something like #1=(#<a class> #1#).
+;;;
 
 (defun make-load-form-saving-slots (object &key slot-names environment)
   (declare (ignore environment))
@@ -32,42 +37,66 @@
 	      initialization)))))
 
 (defun need-to-make-load-form-p (object)
-  (typecase object
-    ((or character number symbol pathname string bit-vector)
-     nil)
-    ((array)
-     (unless (subtypep (array-element-type object) '(or character number))
-       (dotimes (i (array-total-size object) nil)
-	 (when (need-to-make-load-form-p (row-major-aref object i))
-	   (return-from need-to-make-load-form-p t)))))
-    ((cons)
-     (or (need-to-make-load-form-p (car object))
-	 (and (cdr object)
-	      (need-to-make-load-form-p (cdr object)))))
-    (t
-     t)))
+  "Return T if the object cannot be externalized using the lisp
+printer and we should rather use MAKE-LOAD-FORM."
+  (let ((*load-form-cache* nil))
+    (declare (special *load-form-cache*))
+    (labels ((recursive-test (object)
+	       ;; For simple, atomic objects we just return NIL. There is no need to
+	       ;; call MAKE-LOAD-FORM on them
+	       (when (typep object '(or character number symbol pathname string bit-vector))
+		 (return-from recursive-test nil))
+	       ;; For complex objects we set up a cache and run through the
+	       ;; objects content looking for data that might require
+	       ;; MAKE-LOAD-FORM to be externalized.  The cache is used to
+	       ;; solve the problem of circularity and of EQ references.  The
+	       ;; solution is however bad: we cannot have circular structrures
+	       ;; and at the same time use MAKE-LOAD-FORM.
+	       (let ((output 'null))
+		 (if *load-form-cache*
+		     (setf output (gethash object *load-form-cache* 'null))
+		     (setf *load-form-cache* (make-hash-table :size 128 :test #'eql)))
+		 (cond ((eq output nil)
+			(return-from recursive-test nil))
+		       ((eq output t)
+			(error "MAKE-LOAD-FORM cannot handle circular structures")
+			(return-from recursive-test t))
+		       ((typep object 'array)
+			(unless (subtypep (array-element-type object) '(or character number))
+			  (dotimes (i (array-total-size object) (setf output nil))
+			    (when (need-to-make-load-form-p (row-major-aref object i))
+			      (setf output t)
+			      (return)))))
+		       ((consp object)
+			(setf output (or (recursive-test (car object))
+					 (and (cdr object) (recursive-test (cdr object))))))
+		       (t
+			(setf output t)))
+		 (setf (gethash object *load-form-cache*) output)
+		 output)))
+      (recursive-test object))))
 
 (defmethod make-load-form ((object t) &optional environment)
   (unless (need-to-make-load-form-p object)
     (return-from make-load-form (if (consp object) `',object object)))
   (typecase object
     (array
-     `(make-array ,(array-dimensions object)
-		  :element-type ,(array-element-type object)
-		  :adjustable ,(array-adjustable-p object)
-		  :initial-data
-		  ,(loop for i from 0 by (array-total-size object)
+     `(make-array ',(array-dimensions object)
+		  :element-type ',(array-element-type object)
+		  :adjustable ',(adjustable-array-p object)
+		  :initial-contents
+		  ',(loop for i from 0 below (array-total-size object)
 			 collect (make-load-form (row-major-aref object i)))))
     (cons
-     (do* ((x object)
+     (do* ((x object (rest x))
 	   (out '()))
 	 ((atom x)
 	  (progn
-	    (setf out (mapcar #'make-load-form (nreverse out)))
+	    (setf out (mapcar #'(lambda (form) `',form) (nreverse out)))
 	    (if x
-		`(list* ,out ,(make-load-form x))
-	      `(list ,out))))
-       (push x out)))
+		`(list* ,@out ',x)
+		`(list ,@out))))
+       (push (first x) out)))
     (hash-table
      (values
       `(make-hash-table :size ,(hash-table-size object)

src/cmp/cmpct.lsp

@@ -13,7 +13,7 @@
 
 (defvar +optimizable-constant+ '())
 
-(defun c1constant-value (val always-p)
+(defun c1constant-value (val &key always only-small-values)
   (cond
    ((let ((x (assoc val +optimizable-constant+)))
       (and x (c1expr (cdr x)))))
@@ -30,9 +30,10 @@
    ((typep val 'SHORT-FLOAT)
     (make-c1form* 'LOCATION :type 'SHORT-FLOAT
 		  :args (list 'SHORT-FLOAT-VALUE val (add-object val))))
-   (always-p
+   (always
     (make-c1form* 'LOCATION :type (object-type val)
 		  :args (list 'VV (add-object val))))
+   (only-small-values nil)
    (t nil)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

src/cmp/cmpdefs.lsp

@@ -445,6 +445,8 @@ coprocessor).")
 
 ;;; --cmptop.lsp--
 ;;;
+(defvar *compiler-phase* nil)
+
 (defvar *volatile*)
 (defvar *setjmps* 0)
 
@@ -463,6 +465,7 @@ lines are inserted, but the order is preserved")
 					; or *temporary-objects*
 (defvar *permanent-objects* nil)	; holds { ( object (VV vv-index) ) }*
 (defvar *temporary-objects* nil)	; holds { ( object (VV vv-index) ) }*
+(defvar *load-objects* nil)		; hash with association object -> vv-location
 (defvar *load-time-values* nil)		; holds { ( vv-index form ) }*,
 ;;;  where each vv-index should be given an object before
 ;;;  defining the current function during loading process.
@@ -480,6 +483,9 @@ lines are inserted, but the order is preserved")
 (defvar *linking-calls* nil)		; holds { ( global-fun-name fun symbol c-fun-name var-name ) }*
 (defvar *local-funs* nil)		; holds { fun }*
 (defvar *top-level-forms* nil)		; holds { top-level-form }*
+(defvar *make-forms* nil)		; holds { top-level-form }*
+(defvar *init-forms* nil)		; holds { top-level-form }*
+
 ;;;
 ;;;     top-level-form:
 ;;;	  ( 'DEFUN'     fun-name cfun lambda-expr doc-vv sp )

src/cmp/cmpenv.lsp

@@ -17,12 +17,16 @@
 ;;; included in the compiled code.  The default value is OFF.
 
 (defun init-env ()
+  (setq *compiler-phase* 't1)
   (setq *callbacks* nil)
   (setq *max-temp* 0)
   (setq *temp* 0)
   (setq *next-cmacro* 0)
   (setq *next-cfun* 0)
   (setq *last-label* 0)
+  (setq *load-objects* (make-hash-table :size 128 :test #'eql))
+  (setq *make-forms* nil)
+  (setq *init-forms* nil)
   (setq *permanent-objects* nil)
   (setq *temporary-objects* nil)
   (setq *local-funs* nil)

src/cmp/cmpeval.lsp

@@ -24,7 +24,7 @@
 		  (make-c1form* 'LOCATION :type (object-type form)
 				:args (add-symbol form)))
 		 ((constantp form)
-		  (or (c1constant-value (symbol-value form) nil)
+		  (or (c1constant-value (symbol-value form) :only-small-values t)
 		      (c1var form)))
 		 (t (c1var form))))
 	  ((consp form)
@@ -34,7 +34,7 @@
 		   ((and (consp fun) (eq (car fun) 'LAMBDA))
 		    (c1funcall form))
 		   (t (cmperr "~s is not a legal function name." fun)))))
-	  (t (c1constant-value form t)))))
+	  (t (c1constant-value form :always t)))))
   (if (eq form '*cmperr-tag*)
       (c1nil)
       form))

src/cmp/cmpspecial.lsp

@@ -15,7 +15,7 @@
 
 (defun c1quote (args)
   (check-args-number 'QUOTE args 1 1)
-  (c1constant-value (car args) t))
+  (c1constant-value (car args) :always t))
 
 (defun c1declare (args)
   (cmperr "The declaration ~s was found in a bad place." (cons 'DECLARE args)))

src/cmp/cmptop.lsp

@@ -157,8 +157,10 @@
       (wt-nl "memcpy(VV, data->vector.self.t, VM*sizeof(cl_object));}"))
     (wt-nl "VVtemp = Cblock->cblock.temp_data;")
 
+    (setq *compiler-phase* 't2)
+
     ;; useless in initialization.
-    (dolist (form *top-level-forms*)
+    (dolist (form (append (nreverse *make-forms*) (nreverse *init-forms*) *top-level-forms*))
       (let ((*compile-to-linking-call* nil)
 	    (*env* 0) (*level* 0) (*temp* 0))
 	  (t2expr form))
@@ -207,6 +209,8 @@
       (wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)"
 	      "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}")))
 
+  (setq *compiler-phase* 't3)
+
   ;;; Callbacks
   (when *callbacks*
     (wt-h "#include <ecl/internal.h>")
@@ -445,6 +449,18 @@
     (c2expr form)
     (wt-label *exit*)))
 
+(defun t2make-form (vv-loc form)
+  (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
+         (*destination* vv-loc))
+    (c2expr form)
+    (wt-label *exit*)))
+
+(defun t2init-form (vv-loc form)
+  (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
+         (*destination* 'TRASH))
+    (c2expr form)
+    (wt-label *exit*)))
+
 (defun t2decl-body (decls body)
   (let ((*safety* *safety*)
 	(*space* *space*)
@@ -669,4 +685,6 @@
 (put-sysprop 'PROGN 'T2 #'t2progn)
 (put-sysprop 'ORDINARY 'T2 #'t2ordinary)
 (put-sysprop 'LOAD-TIME-VALUE 'T2 't2load-time-value)
+(put-sysprop 'MAKE-FORM 'T2 't2make-form)
+(put-sysprop 'INIT-FORM 'T2 't2init-form)
 (put-sysprop 'SI:FSET 'C2 'c2fset)

src/cmp/cmptype.lsp

@@ -201,7 +201,7 @@
 				 (long-float . 0.0L1) (short-float . 0.0S1))
 			       :test #'subtypep))))
     (if new-value
-	(c1constant-value new-value nil)
+	(c1constant-value new-value :only-small-values t)
         (c1nil))))
 
 ;;----------------------------------------------------------------------

src/cmp/cmpwt.lsp

@@ -126,8 +126,13 @@
 	    *temporary-objects* (make-array 128 :adjustable t :fill-pointer 0))))
 
 (defun data-get-all-objects ()
-  (nconc (map 'list #'first *permanent-objects*)
-	 (map 'list #'first *temporary-objects*)))
+  ;; We collect all objects that are to be externalized, but filter out
+  ;; those which will be created by a lisp form.
+  (loop for i in (nconc (map 'list #'first *permanent-objects*)
+			(map 'list #'first *temporary-objects*))
+	collect (if (gethash i *load-objects*)
+		    0
+		    i)))
 
 (defun data-dump (stream &optional as-lisp-file &aux must-close)
   (etypecase stream
@@ -181,6 +186,20 @@
 (defun data-empty-loc ()
   (add-object 0 :duplicate t :permanent t))
 
+(defun add-load-form (object location)
+  (when (and (not (gethash object *load-objects*))
+	     (clos::need-to-make-load-form-p object))
+    (if (not (eq *compiler-phase* 't1))
+	(cmperr "Unable to internalize complex object ~A in ~a phase" object *compiler-phase*)
+	(multiple-value-bind (make-form init-form) (make-load-form object)
+	  (setf (gethash object *load-objects*) location)
+	  (let* ((make (and make-form
+			    (make-c1form* 'MAKE-FORM :args location (c1expr make-form))))
+		 (init (and init-form
+			    (make-c1form* 'INIT-FORM :args location (c1expr init-form)))))
+	    (push make *make-forms*)
+	    (push init *init-forms*))))))
+
 (defun add-object (object &key (duplicate nil)
 		   (permanent (or (symbolp object) *permanent-data*)))
   (when (and (not *compiler-constants*) (typep object '(or function package)))
@@ -207,6 +226,8 @@
 	  (t
 	   (setq x (list vv next-ndx))
 	   (vector-push-extend (list object x next-ndx) array)
+	   (unless *compiler-constants*
+	     (add-load-form object x))
 	   x))))
 
 (defun add-symbol (symbol)