r3629: *** empty log message ***

diff --git a/examples/person.lisp b/examples/person.lisp
index 7a00fc1c946e550f2151b3d9d3fbb99ddd820393..a91008b39774e3eec97d2f99ceffd4809c57d389 100644 (file)
--- a/examples/person.lisp
+++ b/examples/person.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; A simple example file for hyperobjects
 ;;;;
-;;;; $Id: person.lisp,v 1.4 2002/12/14 02:30:58 kevin Exp $
+;;;; $Id: person.lisp,v 1.5 2002/12/14 18:51:56 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -37,7 +37,7 @@
   (:description "A Person")
   (:direct-rules
    (:rule-1 (:dependants (last-name first-name) :volatile full-name)
-             (setf full-name (concatentate 'string first-name " " last-name)))))
+             (setf full-name (concatenate 'string first-name " " last-name)))))
 
 (defun format-date (ut)
   (when (typep ut 'integer)

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