From 715a81d8541f2191738f14d84c386c11d2822dd9 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Sat, 14 Dec 2002 18:51:56 +0000
Subject: [PATCH] r3629: *** empty log message ***

---
 examples/person.lisp |  4 ++--
 mop.lisp             | 26 +++++++++++++++++++-------
 2 files changed, 21 insertions(+), 9 deletions(-)

diff --git a/examples/person.lisp b/examples/person.lisp
index 7a00fc1..a91008b 100644
--- 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 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
-- 
2.34.1