Commit f75eaeac authored by Peter Hildebrandt's avatar Peter Hildebrandt
Browse files

moved propagation test to test-propagation.lisp

parent 5d46ac00
......@@ -39,7 +39,8 @@
(:file "md-utilities")
(:file "family")
(:file "fm-utilities")
(:file "family-values")))
(:file "family-values")
(:file "test-propagation")))
(defmethod perform ((o load-op) (c (eql (find-system :cells))))
(pushnew :cells *features*))
......
......@@ -25,72 +25,72 @@ See the Lisp Lesser GNU Public License for more details.
(setf (get ',class :cell-types) nil)
(setf (get ',class 'slots-excluded-from-persistence)
',(loop for slotspec in slotspecs
unless (and (getf (cdr slotspec) :ps t)
(getf (cdr slotspec) :persistable t))
collect (car slotspec))))
unless (and (getf (cdr slotspec) :ps t)
(getf (cdr slotspec) :persistable t))
collect (car slotspec))))
;; define slot macros before class so they can appear in
;; initforms and default-initargs
,@(delete nil
(loop for slotspec in slotspecs
nconcing (destructuring-bind
(slotname &rest slotargs
&key (cell t) owning (accessor slotname) reader
&allow-other-keys)
slotspec
(loop for slotspec in slotspecs
nconcing (destructuring-bind
(slotname &rest slotargs
&key (cell t) owning (accessor slotname) reader
&allow-other-keys)
slotspec
(declare (ignorable slotargs owning))
(list
(when cell
(let* ((reader-fn (or reader accessor))
(deriver-fn (intern$ "^" (symbol-name reader-fn))))
`(eval-when (:compile-toplevel :execute :load-toplevel)
(unless (macro-function ',deriver-fn)
(defmacro ,deriver-fn ()
`(,',reader-fn self))))))))))
(declare (ignorable slotargs owning))
(list
(when cell
(let* ((reader-fn (or reader accessor))
(deriver-fn (intern$ "^" (symbol-name reader-fn))))
`(eval-when (:compile-toplevel :execute :load-toplevel)
(unless (macro-function ',deriver-fn)
(defmacro ,deriver-fn ()
`(,',reader-fn self))))))))))
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
;
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
;
(progn
(defclass ,class ,(or directsupers '(model-object));; now we can def the class
,(mapcar (lambda (s)
(list* (car s)
(let ((ias (cdr s)))
(remf ias :persistable)
(remf ias :ps)
;; We handle accessor below
(when (getf ias :cell t)
(remf ias :reader)
(remf ias :writer)
(remf ias :accessor))
(remf ias :cell)
(remf ias :owning)
(remf ias :unchanged-if)
ias))) (mapcar #'copy-list slotspecs))
(:documentation
,@(or (cdr (find :documentation options :key #'car))
'("chya")))
(:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
,@(cdr (find :default-initargs options :key #'car)))
(:metaclass ,(or (cadr (find :metaclass options :key #'car))
'standard-class)))
(defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
,(mapcar (lambda (s)
(list* (car s)
(let ((ias (cdr s)))
(remf ias :persistable)
(remf ias :ps)
;; We handle accessor below
(when (getf ias :cell t)
(remf ias :reader)
(remf ias :writer)
(remf ias :accessor))
(remf ias :cell)
(remf ias :owning)
(remf ias :unchanged-if)
ias))) (mapcar #'copy-list slotspecs))
(:documentation
,@(or (cdr (find :documentation options :key #'car))
'("chya")))
(:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
,@(cdr (find :default-initargs options :key #'car)))
(:metaclass ,(or (cadr (find :metaclass options :key #'car))
'standard-class)))
(defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
(declare (ignore slot-names iargs))
,(when (and directsupers (not (member 'model-object directsupers)))
`(unless (typep self 'model-object)
(error "If no superclass of ~a inherits directly
`(unless (typep self 'model-object)
(error "If no superclass of ~a inherits directly
or indirectly from model-object, model-object must be included as a direct super-class in
the defmodel form for ~a" ',class ',class))))
;
; slot accessors once class is defined...
;
;
; slot accessors once class is defined...
;
,@(mapcar (lambda (slotspec)
(destructuring-bind
(slotname &rest slotargs
&key (cell t) owning unchanged-if (accessor slotname) reader writer type
&allow-other-keys)
(slotname &rest slotargs
&key (cell t) owning unchanged-if (accessor slotname) reader writer type
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
......@@ -102,24 +102,24 @@ the defmodel form for ~a" ',class ',class))))
(setf (md-slot-cell-type ',class ',slotname) ,cell)
,(when owning
`(setf (md-slot-owning ',class ',slotname) ,owning))
`(setf (md-slot-owning ',class ',slotname) ,owning))
,(when reader-fn
`(defmethod ,reader-fn ((self ,class))
(md-slot-value self ',slotname)))
`(defmethod ,reader-fn ((self ,class))
(md-slot-value self ',slotname)))
,(when writer-fn
`(defmethod (setf ,writer-fn) (new-value (self ,class))
(setf (md-slot-value self ',slotname)
,(if type
`(coerce new-value ',type)
'new-value))))
`(defmethod (setf ,writer-fn) (new-value (self ,class))
(setf (md-slot-value self ',slotname)
,(if type
`(coerce new-value ',type)
'new-value))))
,(when unchanged-if
`(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
`(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
)
))
))
slotspecs)
slotspecs)
(find-class ',class))))
(defun defmd-canonicalize-slot (slotname
......
......@@ -264,39 +264,7 @@ See the Lisp Lesser GNU Public License for more details.
(funcall f)
*the-unpropagated*)))
(defmd tcp ()
(left (c-in 0))
(top (c-in 0))
(right (c-in 0))
(bottom (c-in 0))
(area (c? (trc "area running")
(* (- (^right)(^left))
(- (^top)(^bottom))))))
(defobserver area ()
(TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*))
(defun tcprop ()
(untrace)
(test-prep)
(LET ((box (make-instance 'tcp)))
(trc "changing top to 10" *data-pulse-id*)
(setf (top box) 10)
(trc "not changing top" *data-pulse-id*)
(setf (top box) 10)
(trc "changing right to 10" *data-pulse-id*)
(setf (right box) 10)
(trc "not changing right" *data-pulse-id*)
(setf (right box) 10)
(trc "changing bottom to -1" *data-pulse-id*)
(decf (bottom box))
(with-client-propagation ()
(loop repeat 20 do
(trc "changing bottom by -1" *data-pulse-id*)
(decf (bottom box))
(decf (left box))))))
(in-package :cells)
(defmd tcp ()
(left (c-in 0))
(top (c-in 0))
(right (c-in 0))
(bottom (c-in 0))
(area (c? (trc "area running")
(* (- (^right)(^left))
(- (^top)(^bottom))))))
(defobserver area ()
(TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*))
(defun tcprop ()
(untrace)
(test-prep)
(LET ((box (make-instance 'tcp)))
(trc "changing top to 10" *data-pulse-id*)
(setf (top box) 10)
(trc "not changing top" *data-pulse-id*)
(setf (top box) 10)
(trc "changing right to 10" *data-pulse-id*)
(setf (right box) 10)
(trc "not changing right" *data-pulse-id*)
(setf (right box) 10)
(trc "changing bottom to -1" *data-pulse-id*)
(decf (bottom box))
(with-client-propagation ()
(loop repeat 20 do
(trc "changing bottom by -1" *data-pulse-id*)
(decf (bottom box))
(decf (left box))))))
......@@ -23,23 +23,23 @@ See the Lisp Lesser GNU Public License for more details.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro export! (&rest symbols)
`(eval-when ( :compile-toplevel :load-toplevel :execute)
#+sbssscl (export (list ,@(mapcar #'(lambda (x) (list 'quote x)) symbols)))
#-sbclss (export ',symbols))))
`(eval-when ( :compile-toplevel :load-toplevel :execute)
(export ',symbols))))
(defmacro define-constant (name value &optional docstring)
"Define a constant properly. If NAME is unbound, DEFCONSTANT
(eval-now!
(defmacro define-constant (name value &optional docstring)
"Define a constant properly. If NAME is unbound, DEFCONSTANT
it to VALUE. If it is already bound, and it is EQUAL to VALUE,
reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again,
resulting in implementation-specific behavior."
`(defconstant ,name
(if (not (boundp ',name))
,value
(let ((value ,value))
(if (equal value (symbol-value ',name))
(symbol-value ',name)
value)))
,@(when docstring (list docstring))))
`(defconstant ,name
(if (not (boundp ',name))
,value
(let ((value ,value))
(if (equal value (symbol-value ',name))
(symbol-value ',name)
value)))
,@(when docstring (list docstring)))))
(export! exe-path exe-dll font-path)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment