From b8d27be483036a031d397145c1dc7ae956cfbde2 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Tue, 20 Jan 2004 08:53:24 +0000
Subject: [PATCH] Dummy implementation of MAKE-LOAD-FORM and
 MAKE-LOAD-FORM-SAVING-SLOTS. Supports for normal lisp objects and structures
 is missing.

---
 src/clos/boot.lsp     |  4 ++--
 src/clos/builtin.lsp  |  3 +++
 src/clos/defclass.lsp | 17 ++++++++++++++---
 src/clos/method.lsp   |  2 +-
 src/clos/print.lsp    | 31 +++++++++++++++++++++++++++++++
 src/clos/standard.lsp |  4 ++--
 6 files changed, 53 insertions(+), 8 deletions(-)

diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp
index 2f2c35f87..1cf802608 100644
--- a/src/clos/boot.lsp
+++ b/src/clos/boot.lsp
@@ -118,7 +118,7 @@
 	 (if index
 	     (si:sl-boundp (si:instance-ref self (the fixnum index)))
 	     (slot-missing (si:instance-class class) class slot-name
-			   'SLOT-VALUE)))))
+			   'SLOT-BOUNDP)))))
 
     (defmethod (setf slot-value) (val (self class) slot-name)
       (ensure-up-to-date-instance self)
@@ -128,7 +128,7 @@
 	(if index
 	    (si:instance-set self (the fixnum index) val)
 	    (slot-missing (si:instance-class self) self slot-name
-			  'SLOT-VALUE)))
+			  'SETF val)))
       val)
 
     (defmethod slot-missing ((class t) object slot-name operation 
diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp
index 3b67bf2f7..13511e0ee 100644
--- a/src/clos/builtin.lsp
+++ b/src/clos/builtin.lsp
@@ -129,6 +129,9 @@
 (defclass structure-object (t) ()
   (:metaclass structure-class))
 
+(defmethod make-load-form ((object structure-object) &optional environment)
+  (make-load-form-saving-slots object))
+
 (defmethod print-object ((obj structure-object) stream)
   (let* ((class (si:instance-class obj))
 	 (slotds (class-slots class)))
diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp
index c0cb22dd8..7e15f23c2 100644
--- a/src/clos/defclass.lsp
+++ b/src/clos/defclass.lsp
@@ -95,9 +95,20 @@
 ;;; ENSURE-CLASS
 ;;;
 (defun ensure-class (name &rest initargs)
-  (let ((class (apply #'ensure-class-using-class (find-class name nil) name
-		      initargs)))
-    (when name (setf (find-class name) class))))
+  (let* ((old-class nil)
+	 new-class)
+    ;; Only classes which have a PROPER name are redefined. If a class
+    ;; with the same name is register, but the name of the class does not
+    ;; correspond to the registered name, a new class is returned.
+    ;; [Hyperspec 7.7 for DEFCLASS]
+    (when name
+      (when (and (setf old-class (find-class name nil))
+		 (not (eq (class-name old-class) name)))
+	(setf old-class nil)))
+    (setf new-class (apply #'ensure-class-using-class old-class name initargs))
+    (when name (setf (find-class name) new-class))
+    new-class))
+
 (eval-when (compile)
   (defun ensure-class (name &rest initargs)
     (warn "Ignoring definition for class ~S" name)))
diff --git a/src/clos/method.lsp b/src/clos/method.lsp
index b09aa115c..663b41a38 100644
--- a/src/clos/method.lsp
+++ b/src/clos/method.lsp
@@ -735,7 +735,7 @@
 (setf (symbol-function 'SLOT-INDEX) (symbol-function 'GETHASH))
 (put-sysprop 'SLOT-INDEX ':INLINE-ALWAYS
 	     '(((T T) FIXNUM NIL NIL "fix(gethash(#0,#1))")
-	       ((T T) T NIL NIL "(gethash(#0,#1))")))
+	       ((T T) T NIL NIL "gethash_safe(#0,#1,Cnil)")))
 
 (defun reduce-constant (old)
   (let ((new (eval old)))
diff --git a/src/clos/print.lsp b/src/clos/print.lsp
index 01a04abf2..85e5a4d6f 100644
--- a/src/clos/print.lsp
+++ b/src/clos/print.lsp
@@ -9,6 +9,37 @@
 
 (in-package "CLOS")
 
+;;; ----------------------------------------------------------------------
+;;; Load forms
+;;;
+
+(defun make-load-form-saving-slots (object &key slot-names environment)
+  (declare (ignore environment))
+  (do* ((class (class-of object))
+	(initialization (list 'progn))
+	(slots (class-slots class) (cdr slots)))
+      ((endp slots)
+       (values `(allocate-instance ,class) (nreverse initialization)))
+    (let* ((slot (first slots))
+	   (slot-name (slotd-name slot)))
+      (when (or (and (null slot-names)
+		     (eq (slotd-allocation slot) :instance))
+		(member slot-name slot-names))
+	(push (if (slot-boundp object slot-name)
+		  `(setf (slot-value ,object ',slot-name)
+			 ',(slot-value object slot-name))
+		  `(slot-makunbound ,object ',slot-name))
+	      initialization)))))
+
+(defmethod make-load-form ((object standard-object) &optional environment)
+  (make-load-form-saving-slots object))
+
+(defmethod make-load-form ((class class) &optional environment)
+  (let ((name (class-name class)))
+    (if (and name (eq (find-class name) class))
+	`(find-class ',name)
+	(error "Cannot externalize anonymous class ~A" class))))
+
 ;;; ----------------------------------------------------------------------
 ;;; Printing
 ;;; ----------------------------------------------------------------------
diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp
index 765e7e058..d952daf11 100644
--- a/src/clos/standard.lsp
+++ b/src/clos/standard.lsp
@@ -357,7 +357,7 @@ because it contains a reference to the undefined class~%  ~A"
 			   (let ((value (si:instance-ref self index)))
 			     (if (si:sl-boundp value)
 				 value
-				 (slot-unbound self slot-name))))
+				 (values (slot-unbound (class-of self) self slot-name)))))
 		setter #'(lambda (value self)
 			   (si:instance-set self index value))
 		i (1+ i))
@@ -517,7 +517,7 @@ because it contains a reference to the undefined class~%  ~A"
 	    ;; else it is a shared slot
 	    (setf (svref (class-shared-slots (car index)) (cdr index)) val))
 	(slot-missing (si:instance-class instance) instance slot-name
-		      'SLOT-VALUE))
+		      'SETF val))
     val))
 
 ;;; ----------------------------------------------------------------------