X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=rules.lisp;h=00d64b55e3d8c5baf512bcf935afe69d86eab867;hp=dad93ad91278d862fc1998d333a0536945b551ad;hb=HEAD;hpb=fa179cd84c44d2f0e4ea231537afc8a6733c406e diff --git a/rules.lisp b/rules.lisp index dad93ad..00d64b5 100644 --- a/rules.lisp +++ b/rules.lisp @@ -11,7 +11,7 @@ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) ;;; Slot accessor and class rules @@ -28,26 +28,26 @@ (declare (ignore cl)) (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))))))) - + (eval + `(lambda (obj) + (when (every #'(lambda (x) (slot-boundp obj x)) + (quote ,dependants)) + (with-slots ,access obj + ,@source-code))))))) + (defun finalize-rules (cl) (setf (rules cl) (loop for rule in (direct-rules cl) - collect - (destructuring-bind (name (&key dependants volatile) &rest source-code) - rule - (setf dependants (mklist dependants) - volatile (mklist volatile)) - (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)))))) + collect + (destructuring-bind (name (&key dependants volatile) &rest source-code) + rule + (setf dependants (mklist dependants) + volatile (mklist volatile)) + (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)))))) (defun fire-class-rules (cl obj slot) @@ -55,8 +55,8 @@ (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))))) + (cmsg-c :debug "firing rule: ~W" (source-code rule)) + (funcall (func rule) obj))))) #+ho-svuc @@ -65,15 +65,15 @@ #+ignore (cmsg-c :verbose "Setf slot value: class: ~s, obj: ~s, slot: ~s, value: ~s" cl (class-of obj) slot new-value) - + (let ((func (esd-value-constraint slot))) (cond ((and func (not (funcall func new-value))) (warn "Rejected change to value of slot ~a of object ~a" - (slot-definition-name slot) obj) + (slot-definition-name slot) obj) (slot-value obj (slot-definition-name slot))) (t (prog1 - (call-next-method) - (when (direct-rules cl) - (fire-class-rules cl obj slot))))))) + (call-next-method) + (when (direct-rules cl) + (fire-class-rules cl obj slot)))))))