r3629: *** empty log message ***

[hyperobject.git] / mop.lisp

diff --git a/mop.lisp b/mop.lisp
index 543221aa6a91442e1252ff4db19a986ebabe2c84..46d45141a8147edae11581d77de185c16063bf68 100644 (file)
--- 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