[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv19745

Modified Files:
	los-closette.lisp 
Log Message:
Changed structure-class and defstruct so as to be better integrated
with the MOP. This means that the slot-value accessor should now work
on structure-objects.

Date: Mon Apr 19 18:38:27 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.8 movitz/losp/muerte/los-closette.lisp:1.9
--- movitz/losp/muerte/los-closette.lisp:1.8	Mon Apr 19 11:06:32 2004
+++ movitz/losp/muerte/los-closette.lisp	Mon Apr 19 18:38:27 2004
@@ -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.8 2004/04/19 15:06:32 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.9 2004/04/19 22:38:27 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1129,7 +1129,14 @@
 (defclass structure-class (class)
   ((slots
     :initarg :slots
-    :accessor structure-slots)))
+    :reader class-slots)))
+
+(defclass structure-slot-definition (slot-definition)
+  ((name
+    :initarg :name)
+   (location
+    :initarg :location
+    :reader structure-slot-location)))
 
 (defclass structure-object (t) () (:metaclass structure-class))
 
@@ -1303,14 +1310,14 @@
 	(values (slot-missing class object slot-name 'slot-value))
       (slot-value-using-class class object slot))))
 
-(defmethod slot-value-using-class ((class standard-class) object (slot standard-effective-slot-definition))
+(defmethod slot-value-using-class ((class standard-class) object
+				   (slot standard-effective-slot-definition))
   (let ((x (standard-instance-access object (slot-definition-location slot))))
     (if (eq x (load-global-constant unbound-value))
 	(slot-unbound class object (slot-definition-name slot))
       x)))
 
-(defmethod slot-value-using-class ((class funcallable-standard-class)
-				   object
+(defmethod slot-value-using-class ((class funcallable-standard-class) object
 				   (slot standard-effective-slot-definition))
   (let* ((location (slot-definition-location slot))
          (slots (std-gf-instance-slots object))
@@ -1319,6 +1326,9 @@
 	(slot-unbound class object (slot-definition-name slot))        
       val)))
 
+(defmethod slot-value-using-class ((class structure-class) object slot)
+  (structure-ref object (structure-slot-location slot)))
+
 (defun (setf slot-value) (new-value object slot-name)
   (let* ((class (class-of object))
 	 (slot (find-slot class slot-name)))
@@ -1339,6 +1349,9 @@
 	(slots (std-gf-instance-slots object)))
     (setf (svref slots location) new-value)))
 
+(defmethod (setf slot-value-using-class) (new-value (class structure-class) object slot)
+  (setf (structure-ref object (structure-slot-location slot)) new-value))
+
 (defun slot-boundp (object slot-name)
   (let* ((class (class-of object))
 	 (slot (find-slot class slot-name)))
@@ -1676,13 +1689,12 @@
   object)
 
 (defmethod print-object ((object structure-object) stream)
-  (let* ((class (class-of object))
-	 (slots (mapcar #'car (slot-value class 'slots)))
-	 (position 0))
+  (let* ((class (class-of object)))
     (format stream "#S(~S" (class-name class))
-    (dolist (slot slots)
-      (format stream " :~A ~S" slot (structure-ref object position))
-      (incf position))
+    (dolist (slot (class-slots class))
+      (format stream " :~A ~S"
+	      (symbol-name (slot-definition-name slot))
+	      (structure-ref object (structure-slot-location slot))))
     (write-string ")" stream))
   object)