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@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)