/usr/share/common-lisp/source/hyperobject/rules.lisp is in cl-hyperobject 2.12.0-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: rules.lisp
;;;; Purpose: Slot and Class rules
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; $Id$
;;;;
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
(in-package #:hyperobject)
;;; Slot accessor and class rules
(defclass rule ()
((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)
(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)))))))
(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))))))
(defun fire-class-rules (cl obj slot)
"Fire all class rules. Called after a slot is modified."
(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)))))
#+ho-svuc
(defmethod (setf slot-value-using-class) :around
(new-value (cl hyperobject-class) obj (slot hyperobject-esd))
#+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-value obj (slot-definition-name slot)))
(t
(prog1
(call-next-method)
(when (direct-rules cl)
(fire-class-rules cl obj slot)))))))
|