[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv14757

Modified Files:
	los-closette-compiler.lisp 
Log Message:
Add metaclass read-only-class.


--- /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp	2005/08/24 07:31:47	1.19
+++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp	2007/03/11 22:43:10	1.20
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Aug 29 13:15:11 2002
 ;;;;                
-;;;; $Id: los-closette-compiler.lisp,v 1.19 2005/08/24 07:31:47 ffjeld Exp $
+;;;; $Id: los-closette-compiler.lisp,v 1.20 2007/03/11 22:43:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -551,6 +551,7 @@
 						direct-slots direct-superclasses
 		       &allow-other-keys)
     (declare (dynamic-extent all-keys))
+    (remf all-keys :metaclass)
     (let ((old-class (movitz-find-class name nil)))
       (if (and old-class
 	       (eq metaclass *the-class-standard-class*))
@@ -568,6 +569,9 @@
 			      'movitz-make-instance)
 			     ((eq metaclass (movitz-find-class 'run-time-context-class nil))
 			      'movitz-make-instance)
+                             ((member *the-class-standard-class*
+                                      (class-precedence-list metaclass))
+                              'make-instance-standard-class)
 			     (t (break "Unknown metaclass: ~S" metaclass)
 				#+ignore 'make-instance-built-in-class
 				'movitz-make-instance))
@@ -676,7 +680,7 @@
 						      default-initargs-function
 						      documentation)
     (declare (ignore metaclass documentation))
-    (let ((class (std-allocate-instance *the-class-standard-class*)))
+    (let ((class (std-allocate-instance metaclass)))
       (setf (movitz-class-name class) name)
       (setf (class-direct-subclasses class) ())
       (setf (class-direct-methods class) ())
@@ -684,6 +688,16 @@
       (setf (movitz-slot-value class 'plist)
 	(when default-initargs-function
 	  (list :default-initargs-function default-initargs-function)))
+      (dolist (slot (class-slots (movitz-class-of class)))
+        (let ((slot-name (slot-definition-name slot))
+              (slot-initform (muerte::translate-program (slot-definition-initform slot)
+                                                        '#:muerte.cl '#:cl)))
+          (when slot-initform
+            (warn "init slot: ~S: ~S => ~S"
+                  slot-name
+                  slot-initform
+                  (movitz::eval-form slot-initform))
+            (setf (movitz-slot-value class slot-name) (movitz::eval-form slot-initform)))))
       (std-after-initialization-for-classes class
 					    :direct-slots direct-slots
 					    :direct-superclasses direct-superclasses)
@@ -708,8 +722,10 @@
 	(dolist (writer (slot-definition-writers direct-slot))
 	  (add-writer-method 
 	   class writer (slot-definition-name direct-slot)))))
-    (funcall (if (or (eq (movitz-class-of class) *the-class-standard-class*)
-		     (subclassp (movitz-class-of class) (movitz-find-class 'std-slotted-class)))
+    (funcall (if (or (eq (movitz-class-of class)
+                         *the-class-standard-class*)
+		     (subclassp (movitz-class-of class)
+                                (movitz-find-class 'std-slotted-class)))
 		 #'std-finalize-inheritance
 	       #'finalize-inheritance)
 	     class)