X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=mop.lisp;h=46d45141a8147edae11581d77de185c16063bf68;hp=543221aa6a91442e1252ff4db19a986ebabe2c84;hb=715a81d8541f2191738f14d84c386c11d2822dd9;hpb=e1b34d8009ffcaf4881205c08bf94b09255a7f6a

diff --git a/mop.lisp b/mop.lisp
index 543221a..46d4514 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.15 2002/12/14 18:51:56 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -379,13 +379,20 @@
   ((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 +405,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 +414,11 @@
 
 (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 "firing rule: ~a" rule)
+	(funcall (func rule) obj)))))
 
 (defmethod (setf slot-value-using-class) 
     :around (new-value (cl hyperobject-class) obj
@@ -423,7 +434,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