From c5886d2471bc694c22f6ea6664cb152c40ad6604 Mon Sep 17 00:00:00 2001
From: Juanjo Garcia-Ripoll <jjgarcia@users.sourcerforge.net>
Date: Fri, 5 Oct 2012 15:14:55 +0200
Subject: [PATCH] Add functionality to MAKE-EMTPY-SSTANDARD-CLASS

---
 src/clos/boot.lsp | 25 +++++++++++++------------
 1 file changed, 13 insertions(+), 12 deletions(-)

diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp
index 418c63805..d9f46821e 100644
--- a/src/clos/boot.lsp
+++ b/src/clos/boot.lsp
@@ -87,7 +87,7 @@
 ;;; We cannot use the functions CREATE-STANDARD-CLASS and others because SLOTS,
 ;;; DIRECT-SLOTS, etc are empty and therefore SLOT-VALUE does not work.
 
-(defun make-empty-standard-class (name metaclass)
+(defun make-empty-standard-class (name metaclass direct-superclasses direct-slots)
   (declare (si::c-local))
   (let ((class (or (gethash name si::*class-name-hash-table*)
 		   (si:allocate-raw-instance nil metaclass
@@ -107,6 +107,14 @@
 	  (class-dependents          class) nil
 	  (class-valid-initargs      class) nil
 	  )
+    (let ((superclasses (loop for name in direct-superclasses
+			   for parent = (find-class name)
+			   do (push class (class-direct-subclasses parent))
+			   collect parent)))
+      (setf (class-direct-superclasses class) superclasses
+	    (class-precedence-list class)
+	    (compute-clos-class-precedence-list class superclasses)))
+    (add-slots class direct-slots)
     class))
 
 (defun add-slots (class slots)
@@ -131,18 +139,11 @@
 ;; itself as metaclass. MAKE-EMPTY-STANDARD-CLASS takes care of that.
 ;;
 (let ((all-classes 
-       (loop with standard-class = (make-empty-standard-class 'standard-class nil)
+       (loop with standard-class = (make-empty-standard-class 'standard-class nil nil nil)
 	  for c in '#.+class-hierarchy+
-	  for name = (first c)
-	  for class = (make-empty-standard-class name standard-class)
-	  for superclasses = (loop for name in (getf (rest c) :direct-superclasses)
-				for parent = (find-class name)
-				do (push class (class-direct-subclasses parent))
-				collect parent)
-	  do (setf (class-direct-superclasses class) superclasses
-		   (class-precedence-list class)
-		   (compute-clos-class-precedence-list class superclasses))
-	  do (add-slots class (getf (rest c) :direct-slots))
+	  for class = (make-empty-standard-class name standard-class
+						 (getf (rest c) :direct-superclasses)
+						 (getf (rest c) :direct-slots))
 	  collect class)))
   ;;
   ;; 2) Class T had its metaclass wrong. Fix it.