X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=496bc56c3ae7977205f3a3d34e24051b9701f2f7;hb=5a20b2bd0d0859d58da60fd22ab37658673ef291;hp=543221aa6a91442e1252ff4db19a986ebabe2c84;hpb=e1b34d8009ffcaf4881205c08bf94b09255a7f6a;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index 543221a..496bc56 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: mop.lisp,v 1.14 2002/12/14 02:30:58 kevin Exp $
+;;;; $Id: mop.lisp,v 1.16 2002/12/14 21:52:48 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -379,13 +379,19 @@
   ((name :initarg :name :initform nil :accessor name)
    (dependants :initarg :dependants :initform nil :accessor dependants)
    (volatile :initarg :volatile :initform nil :accessor volatile)
+   (access-slots :initarg :access-slots :initform nil :accessor access-slots)
    (source-code :initarg :source-code :initform nil :accessor source-code)
    (func :initform nil :initarg :func :accessor func)))
 
 (defun compile-rule (source-code dependants volatile cl)
-  #'(lambda (obj)
-      `(with-slots ,(append dependants volatile) obj
-	,@source-code)))
+  (let ((access (appendnew dependants volatile)))
+    (compile nil
+	     (eval
+	      `(lambda (obj)
+		 (when (every #'(lambda (x) (slot-boundp obj x))
+			      (quote ,dependants))
+		   (with-slots ,access obj
+		     ,@source-code)))))))
   
 (defun finalize-rules (cl)
   (let* ((direct-rules (direct-rules cl))
@@ -398,6 +404,7 @@
 	(push
 	 (make-instance 'rule :name name :dependants dependants
 			:volatile volatile :source-code source-code
+			:access-slots (appendnew dependants volatile)
 			:func (compile-rule
 			       source-code dependants volatile cl))
 	 rules)))
@@ -406,8 +413,18 @@
 
 (defun fire-class-rules (cl obj slot)
   "Fire all class rules. Called after a slot is modified."
-  (dolist (rule (direct-rules cl))
-    (cmsg "firing rule: ~a" rule)))
+  (let ((name (slot-definition-name slot)))
+    (dolist (rule (rules cl))
+      (when (find name (dependants rule))
+	(cmsg-c :debug "firing rule: ~W" (source-code rule))
+	(funcall (func rule) obj)))))
+
+
+#+ignore
+(defmethod (setf slot-value-using-class) 
+    :around (new-value (cl hyperobject-class) obj
+		       (slot standard-effective-slot-definition))
+    (call-next-method))
 
 (defmethod (setf slot-value-using-class) 
     :around (new-value (cl hyperobject-class) obj
@@ -423,7 +440,8 @@
 	 (slot-value obj (slot-definition-name slot)))
 	(t
 	 (call-next-method)
-	 (fire-class-rules cl obj slot)
+	 (when (direct-rules cl)
+	   (fire-class-rules cl obj slot))
 	 new-value))))
 
 #+ignore