1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Slot and Class rules
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: rules.lisp,v 1.39 2003/05/14 05:29:48 kevin Exp $
12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
15 (in-package :hyperobject)
17 (eval-when (:compile-toplevel :execute)
18 (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
20 ;;; Slot accessor and class rules
23 ((name :initarg :name :initform nil :accessor name)
24 (dependants :initarg :dependants :initform nil :accessor dependants)
25 (volatile :initarg :volatile :initform nil :accessor volatile)
26 (access-slots :initarg :access-slots :initform nil :accessor access-slots)
27 (source-code :initarg :source-code :initform nil :accessor source-code)
28 (func :initform nil :initarg :func :accessor func)))
30 (defun compile-rule (source-code dependants volatile cl)
31 (let ((access (appendnew dependants volatile)))
35 (when (every #'(lambda (x) (slot-boundp obj x))
37 (with-slots ,access obj
40 (defun finalize-rules (cl)
41 (let* ((direct-rules (direct-rules cl))
43 (dolist (rule direct-rules)
44 (destructuring-bind (name (&key dependants volatile) &rest source-code)
46 (setf dependants (mklist dependants)
47 volatile (mklist volatile))
49 (make-instance 'rule :name name :dependants dependants
50 :volatile volatile :source-code source-code
51 :access-slots (appendnew dependants volatile)
53 source-code dependants volatile cl))
55 (setf (rules cl) (nreverse rules))))
58 (defun fire-class-rules (cl obj slot)
59 "Fire all class rules. Called after a slot is modified."
60 (let ((name (slot-definition-name slot)))
61 (dolist (rule (rules cl))
62 (when (find name (dependants rule))
63 (cmsg-c :debug "firing rule: ~W" (source-code rule))
64 (funcall (func rule) obj)))))
68 (defmethod (setf slot-value-using-class) :around
69 (new-value (cl hyperobject-class) obj (slot hyperobject-esd))
72 (cmsg-c :verbose "Setf slot value: class: ~s, obj: ~s, slot: ~s, value: ~s" cl (class-of obj) slot new-value)
74 (let ((func (when (slot-boundp slot 'value-constraint)
75 (esd-value-constraint slot))))
77 ((and func (not (funcall func new-value)))
78 (warn "Rejected change to value of slot ~a of object ~a"
79 (slot-definition-name slot) obj)
80 (slot-value obj (slot-definition-name slot)))
84 (when (direct-rules cl)
85 (fire-class-rules cl obj slot)))))))