[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

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

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


--- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp	2006/04/10 11:52:21	1.36
+++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp	2007/03/11 22:43:14	1.37
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.36 2006/04/10 11:52:21 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.37 2007/03/11 22:43:14 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -154,8 +154,7 @@
 
 (defun std-gf-instance-class (instance)
   (check-type instance standard-gf-instance)
-  (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-class))
-  #+ignore (movitz-accessor instance movitz-funobj-standard-gf standard-gf-class))
+  (memref instance (movitz-type-slot-offset 'movitz-funobj-standard-gf 'standard-gf-class)))
 
 (defun std-gf-instance-slots (instance)
   (check-type instance standard-gf-instance)
@@ -198,8 +197,6 @@
   (setf (memref funcallable-instance (movitz-type-slot-offset 'movitz-funobj-standard-gf
 							      'standard-gf-function))
     function)
-;;;  (setf-movitz-accessor (funcallable-instance movitz-funobj-standard-gf standard-gf-function)
-;;;			function)
   (values))
 
 (defun funcallable-instance-function (funcallable-instance)
@@ -1679,7 +1676,10 @@
 
 (defmethod print-object ((object class) stream)
   (print-unreadable-object (object stream :identity nil :type t)
-    (write (class-name object) :stream stream))
+    (write (if (slot-boundp object 'name)
+               (class-name object)
+               "[unnamed]")
+     :stream stream))
   object)
 
 (defmethod print-object ((object standard-object) stream)
@@ -1799,32 +1799,40 @@
 	(real-gf-mc #'generic-function-method-combination)
 	(real-amsd #'accessor-method-slot-definition))
     (with-alternative-fdefinitions
-	((slow-method-lookup #'bootstrap-slow-method-lookup)
+	((slow-method-lookup
+          #'bootstrap-slow-method-lookup)
 	 (slot-definition-name
-	  (lambda (slot) (bootstrap-slot-definition-access slot 'name)))
+	  (lambda (slot)
+            (bootstrap-slot-definition-access slot 'name)))
 	 (slot-definition-location
-	  (lambda (slot) (bootstrap-slot-definition-access slot 'location)))
+	  (lambda (slot)
+            (bootstrap-slot-definition-access slot 'location)))
 	 (class-slots
-	  (lambda (class) (bootstrap-slot-definition-access class 'effective-slots)))
+	  (lambda (class)
+            (bootstrap-slot-definition-access class 'effective-slots)))
 	 (class-precedence-list
 	  (lambda (class)
 	    (std-slot-value class 'class-precedence-list)))
 	 (method-specializers
-	  (lambda (m) (std-slot-value m 'specializers)))
+	  (lambda (m)
+            (std-slot-value m 'specializers)))
 	 (method-qualifiers
-	  (lambda (m) (std-slot-value m 'qualifiers)))
+	  (lambda (m)
+            (std-slot-value m 'qualifiers)))
 	 (method-function
-	  (lambda (m) (std-slot-value m 'function)))
+	  (lambda (m)
+            (std-slot-value m 'function)))
 	 (generic-function-methods
-	  (lambda (gf) (std-gf-slot-value gf 'methods)))
+	  (lambda (gf)
+            (std-gf-slot-value gf 'methods)))
 	 (generic-function-method-combination
-	  (lambda (gf) (declare (ignore gf)) nil))
+	  (lambda (gf)
+            (declare (ignore gf)) nil))
 	 (accessor-method-slot-definition
 	  (lambda (method)
 	    (std-slot-value method 'slot-definition)))
 	 (compute-applicable-methods-using-classes
 	  (lambda (gf classes)
-	    ;; (warn "camuc of: ~S" (funobj-name gf))
 	    (with-alternative-fdefinitions
 		((method-function
 		  (lambda (method)
@@ -1898,4 +1906,28 @@
       (setf (get 'clos-bootstrap 'have-bootstrapped) t)
       (values))))
 
+;;;
+
+(defclass read-only-class (standard-class)
+  ((instances
+    :initform (make-hash-table :test 'equal)
+    :reader read-only-class-instances
+    )))
+
+(defmethod (setf slot-value-using-class) (new-value (class read-only-class) object slot)
+  (when (slot-boundp-using-class  class object slot)
+    (cerror "Set the slot ~S of read-only object ~S to ~S anyway."
+            "Trying to set the slot ~S of read-only object ~S to ~S."
+            (slot-definition-name slot) object new-value))
+  (call-next-method))
+
+(defmethod make-instance ((class read-only-class) &rest initargs)
+  (declare (dynamic-extent initargs))
+  (let ((defaulted-initargs (compute-defaulted-initargs class initargs)))
+    (or (gethash defaulted-initargs (read-only-class-instances class))
+        (setf (gethash (copy-list defaulted-initargs)
+                       (read-only-class-instances class))
+              (apply 'initialize-instance
+                     (apply 'allocate-instance class defaulted-initargs)
+                     defaulted-initargs)))))