... and again a question related to this: Suppose I have :
(defmd kid-test-2 (family)
(a-slot (c-in nil))
:kids (list (make-instance 'my-kid)
(make-instance 'my-kid)))
Now - this completely bypasses the control mechanism inserted into fm-
kid-add - which is not what I wanted ;-)
So, I am asking myself if it would be better to insert the check into
the .kids observer ...
I now have:
(defmodel family (model)
((.kid-slots :cell nil
:initform nil
:accessor kid-slots
:initarg :kid-slots)
(.kids :initform (c-in nil) ;; most useful
:owning t
:accessor kids
:initarg :kids)
(registry? :cell nil
:initform nil
:initarg :registry?
:accessor registry?)
(registry :cell nil
:initform nil
:accessor registry)
;; added: frgo, 2008-10-30
(control-hooks :cell nil
:accessor control-hooks
:initform (make-hash-table :test 'eql)
:initarg :control-hooks)))
(defmethod get-control-hooks ((self family) hook-id)
(gethash hook-id (control-hooks self)))
(defmethod add-hook ((self family) id hook)
(setf (gethash id (control-hooks self)) hook))
(defun call-control-hook (hook self &rest args)
;;; to be completed here
)
(eval-when (:compile-time :load-toplevel)
(proclaim '(inline mklist))
(if (not (fboundp 'mklist))
(defun mklist (obj)
(if (listp obj)
obj
(list obj)))))
(defun run-control-hooks (id self &rest args)
(c-assert (typep self 'family))
(let ((hooks (get-control-hooks self id)))
(if hooks
(loop for hook in (get-control-hooks self id)
collect (call-control-hook hook self args)
into result
finally (return (mklist result)))
(mklist t))))
and
(define-condition cells-adding-kid-not-allowed-error (error)
((text :initarg :text :reader text)))
(defun kid-add-allowed? (fm-parent kid)
(notany #'null (run-control-hooks 'fm-kid-add-control fm-parent
kid)))
(defun fm-kid-add (fm-parent kid &optional before)(c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent kid))))
(c-assert (typep fm-parent 'family))
;; Added: frgo, 2008-10-30
(if (kid-add-allowed? fm-parent kid)
(progn
;; (trc "Adding kid to parent" kid fm-parent)
(setf (fm-parent kid) fm-parent)
(fm-kid-insert kid before))
(error 'cells-adding-kid-not-allowed-error
:text (format nil
"ERROR: Kid ~s not allowed for parent
~s." kid fm-parent))))
- which is incomplete, of course, but shows the basic idea, or so I hope.
Any thoughts if I should use the observer or do some clever slot trickery using MOP ?
Thanks for feedback!
Regards
Frank
Am 30.10.2008 um 13:15 schrieb Frank Goenninger:
* PGP Signed: 10/30/08 at 13:15:51 Hi -I want to control if a kid is added to a parent based on the execution of a check function. The check function is supposed to throw an condition when the check fails.Current use case:Control which classes of kids are added to a parent. I do have a model of class BOM (bill of material) that only can accept classes Assembly and Part as kids.I found two places at which I could insert a call to the check function:function fm-kid-add (higher level interface) function fm-kid-insert (lower level interface) Question now is: Why would one be better than the other? Idea here is based on adding a new slot to class family: (defmodel family (model) ((.kid-slots :cell nil :initform nil :accessor kid-slots :initarg :kid-slots) (.kids :initform (c-in nil) ;; most useful :owning t :accessor kids :initarg :kids) (registry? :cell nil :initform nil :initarg :registry? :accessor registry?) (registry :cell nil :initform nil :accessor registry) ;; added: frgo, 2008-10-30 ----- (kid-add-control-hook :cell nil :initform nil :initarg: kid-add-control-hook)))and then do run the check functions that have been added to the control hook (= list of functions to be funcalled).Right approach? Any comments? (It works but I'd like to know if am on the right track).Thanks for feedback. Cheers Frank * Frank Goenninger <[EMAIL PROTECTED]> * 0xE6BDA9B9:0x6AEA9601 _______________________________________________ cells-devel site list [email protected] http://common-lisp.net/mailman/listinfo/cells-devel * PGP Signed: 10/30/08 at 13:15:51 * text/plain body * Frank Goenninger <[EMAIL PROTECTED]> * 0xE6BDA9B9:0x6AEA9601
PGP.sig
Description: PGP signature
_______________________________________________ cells-devel site list [email protected] http://common-lisp.net/mailman/listinfo/cells-devel
