/[cells-gtk]/cells/test.lisp
ViewVC logotype

Contents of /cells/test.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed Jun 7 16:23:31 2006 UTC (7 years, 10 months ago) by pdenno
Branch: MAIN
CVS Tags: HEAD
new files
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
2 ;;;
3 ;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
4 ;;;
5 ;;; Permission is hereby granted, free of charge, to any person obtaining a copy
6 ;;; of this software and associated documentation files (the "Software"), to deal
7 ;;; in the Software without restriction, including without limitation the rights
8 ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 ;;; copies of the Software, and to permit persons to whom the Software is furnished
10 ;;; to do so, subject to the following conditions:
11 ;;;
12 ;;; The above copyright notice and this permission notice shall be included in
13 ;;; all copies or substantial portions of the Software.
14 ;;;
15 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
20 ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
21 ;;; IN THE SOFTWARE.
22
23 #| do list
24
25 -- can we lose the special handling of the .kids slot?
26
27 -- test drifters (and can they be handled without creating a special
28 subclass for them?)
29
30 |#
31
32 (eval-when (compile load)
33 (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
34
35 (in-package :cells)
36
37 (defparameter *cell-tests* nil)
38
39 #+go
40 (test-cells)
41
42 (defun test-cells ()
43 (loop for test in (reverse *cell-tests*)
44 do (cell-test-init test)
45 (funcall test)))
46
47 (defun cell-test-init (name)
48 (print (make-string 40 :initial-element #\!))
49 (print `(starting test ,name))
50 (print (make-string 40 :initial-element #\!))
51 (cell-reset))
52
53 (defmacro def-cell-test (name &rest body)
54 `(progn
55 (pushnew ',name *cell-tests*)
56 (defun ,name ()
57 ,@body)))
58
59 (defmacro ct-assert (form &rest stuff)
60 `(progn
61 (print `(attempting ,',form))
62 (assert ,form () "Error stuff ~a" (list ,@stuff))))
63
64 (defmodel m-null ()
65 ((aa :initform nil :cell nil :initarg :aa :accessor aa)))
66
67 (def-cell-test m-null
68 (let ((m (make-be 'm-null :aa 42)))
69 (ct-assert (= 42 (aa m)))
70 (ct-assert (= 21 (decf (aa m) 21)))
71 (ct-assert (= 21 (aa m)))
72 :okay-m-null))
73
74 (defmodel m-var ()
75 ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a)
76 (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b)))
77
78 (def-c-output m-var-b ()
79 (print `(output m-var-b ,self ,new-value ,old-value)))
80
81 (def-cell-test m-var
82 (let ((m (make-be 'm-var :m-var-a (c-in 42) :m-var-b 1951)))
83 (ct-assert (= 42 (m-var-a m)))
84 (ct-assert (= 21 (decf (m-var-a m) 21)))
85 (ct-assert (= 21 (m-var-a m)))
86 :okay-m-var))
87
88 (defmodel m-var-output ()
89 ((cbb :initform nil :initarg :cbb :accessor cbb)
90 (aa :cell nil :initform nil :initarg :aa :accessor aa)))
91
92 (def-c-output cbb ()
93 (trc "output cbb" self)
94 (setf (aa self) (- new-value (if old-value-boundp
95 old-value 0))))
96
97 (def-cell-test m-var-output
98 (let ((m (make-be 'm-var-output :cbb (c-in 42))))
99 (ct-assert (eql 42 (cbb m)))
100 (ct-assert (eql 42 (aa m)))
101 (ct-assert (eql 27 (decf (cbb m) 15)))
102 (ct-assert (eql 27 (cbb m)))
103 (ct-assert (eql -15 (aa m)))
104 (list :okay-m-var (aa m))))
105
106 (defmodel m-var-linearize-setf ()
107 ((ccc :initform nil :initarg :ccc :accessor ccc)
108 (ddd :initform nil :initarg :ddd :accessor ddd)))
109
110 (def-c-output ccc ()
111 (with-deference
112 (setf (ddd self) (- new-value (if old-value-boundp
113 old-value 0)))))
114
115 (def-cell-test m-var-linearize-setf
116 (let ((m (make-be 'm-var-linearize-setf
117 :ccc (c-in 42)
118 :ddd (c-in 1951))))
119
120 (ct-assert (= 42 (ccc m)))
121 (ct-assert (= 42 (ddd m)))
122 (ct-assert (= 27 (decf (ccc m) 15)))
123 (ct-assert (= 27 (ccc m)))
124 (ct-assert (= -15 (ddd m)))
125 :okay-m-var))
126
127 ;;; -------------------------------------------------------
128
129 (defmodel m-ruled ()
130 ((eee :initform nil :initarg :eee :accessor eee)
131 (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff)))
132
133 (def-c-output eee ()
134 (print `(output> eee ,new-value old ,old-value)))
135
136 (def-c-output fff ()
137 (print `(output> eee ,new-value old ,old-value)))
138
139 (def-cell-test m-ruled
140 (let ((m (make-be 'm-ruled
141 :eee (c-in 42)
142 :fff (c? (floor (^eee) 2)))))
143 (trc "___Initial TOBE done____________________")
144 (print `(pulse ,*data-pulse-id*))
145 (ct-assert (= 42 (eee m)))
146 (ct-assert (= 21 (fff m)))
147 (ct-assert (= 36 (decf (eee m) 6)))
148 (print `(pulse ,*data-pulse-id*))
149 (ct-assert (= 36 (eee m)))
150 (ct-assert (= 18 (fff m)) m)
151 :okay-m-ruled))
152
153 (defmodel m-worst-case ()
154 ((wc-x :accessor wc-x :initform (c-input () 2))
155 (wc-a :accessor wc-a :initform (c? (when (oddp (wc-x self))
156 (wc-c self))))
157 (wc-c :accessor wc-c :initform (c? (evenp (wc-x self))))
158 (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self))))))
159
160 (def-cell-test m-worst-case
161 (let ((m (make-be 'm-worst-case)))
162 (trc "___Initial TOBE done____________________")
163 (ct-assert (eql t (wc-c m)))
164 (ct-assert (eql nil (wc-a m)))
165 (ct-assert (eql t (wc-h m)))
166 (ct-assert (eql 3 (incf (wc-x m))))))
167

  ViewVC Help
Powered by ViewVC 1.1.5