1 ;;;-*- Mode: Lisp; Package: LIFT -*-
5 (pushnew :cases
*deftest-clauses
*)
9 (lambda () (def :cases
))
10 '((setf (def :cases
) (cleanup-parsed-parameter value
)))
13 (defun build-cases-method ()
14 (when (atom (car (def :cases
)))
15 (setf (def :cases
) (list (def :cases
))))
17 (let ((cases (standardize-cases-form (def :cases
))))
18 `(defmethod initialize-prototypes :after
((test ,(def :testsuite-name
)))
19 (setf (prototypes test
)
20 (rest (process-cases-form
22 ,@(mapcar (lambda (a) `',a
) (rest cases
))))))))
24 ;; goal is spec := (<tag> <spec>+)
25 ;; spec := (<var value>+)
26 (defun standardize-cases-form (cases)
27 (cond ((atom (first cases
))
28 (cond ((valid-tag-p (first cases
))
29 `(,(first cases
) ,@(mapcar #'standardize-cases-form
(rest cases
))))
32 ((and (length-1-list-p cases
)
34 (valid-tag-p (first (first cases
))))
35 (standardize-cases-form (first cases
)))
37 `(:cross
,@(mapcar #'standardize-cases-form cases
)))))
39 ;;; ---------------------------------------------------------------------------
41 (defun check-subcases (cases)
42 (cond ((not (valid-tag-p (first cases
)))
43 `(,(default-cases-tag) ,@(mapcar #'standardize-cases-form cases
)))
45 (mapcar #'standardize-cases-form cases
))))
47 ;;; ---------------------------------------------------------------------------
49 (defun default-cases-tag ()
52 ;;; ---------------------------------------------------------------------------
54 (defun valid-tag-p (tag)
55 (member tag
'(:map
:cross
)))
57 ;;; ---------------------------------------------------------------------------
59 (defmethod process-cases-form :around
((type t
) &rest forms
)
60 (apply #'call-next-method type
(if (atom (car forms
))
63 ;;; ---------------------------------------------------------------------------
65 (defmethod process-cases-form ((type t
) &rest forms
)
66 (cond ((atom (first type
))
67 (apply #'process-cases-form
(first type
) (append (rest type
) forms
)))
68 (t (apply #'process-cases-form
:cross
(append type forms
)))))
71 (defmethod process-cases-form ((type (eql :map
)) &rest forms
)
72 (let ((vars (mapcar #'car forms
))
73 (values (mapcar #'rest forms
)))
74 `(let (,@(mapcar (lambda (var value
) `(,var
,@value
))
77 (list ,@(mapcar (lambda (var) `(cons ',var
,var
)) vars
)))
80 ;;; ---------------------------------------------------------------------------
82 (defmethod process-cases-form ((type (eql :map
)) &rest forms
)
83 (let ((vars (ensure-list (flatten (vars-from-assignment forms
))))
84 (values (values-from-assignment forms
)))
85 `(:b
,@(apply #'mapcar
87 (mapcar (lambda (var value
)
92 ;;; ---------------------------------------------------------------------------
94 (defmethod process-cases-form ((type (eql :cross
)) &rest forms
)
95 (let ((vars (ensure-list (flatten (vars-from-assignment forms
))))
96 (values (values-from-assignment forms
))
99 (mapcar #'length values
)
102 (mapcar (lambda (name var index
)
103 (push (cons name
(elt var index
)) datum
))
107 (push (nreverse datum
) result
)))
109 `(:b
,@(nreverse result
))))
111 ;;; ---------------------------------------------------------------------------
113 (defun vars-from-assignment (assignment)
114 (cond ((is-binding-p assignment
)
115 (mapcar #'car
(second assignment
)))
116 ((metatilities:dotted-pair-p assignment
)
118 ((atom (car assignment
))
120 ((length-1-list-p assignment
)
121 (vars-from-assignment (first assignment
)))
122 (t (loop for assignment in assignment collect
123 (vars-from-assignment assignment
)))))
125 ;;; ---------------------------------------------------------------------------
127 (defun values-from-assignment (assignment)
128 (cond ((is-binding-p assignment
)
129 (apply #'mapcar
(lambda (&rest bindings
)
130 (mapcar (lambda (binding)
134 ((dotted-pair-p assignment
)
136 ((atom (car assignment
))
137 (list (eval (first (rest assignment
)))))
139 (loop for assignment in assignment nconc
140 (ensure-list (values-from-assignment assignment
))))))
142 ;;; ---------------------------------------------------------------------------
144 (defun is-binding-p (assignment)
145 (eq (first assignment
) :b
))
151 (export '(map-prototypes-of
156 ;;; ---------------------------------------------------------------------------
158 ;;; ---------------------------------------------------------------------------
160 (defgeneric map-prototypes-of
(fn thing
)
163 ;;; ---------------------------------------------------------------------------
165 (defgeneric prototypes-of
(thing)
168 ;;; ---------------------------------------------------------------------------
170 (defgeneric prototype-of
(thing)
173 ;;; ---------------------------------------------------------------------------
175 (defgeneric prototype-exists-p
(thing)
178 ;;; ---------------------------------------------------------------------------
180 ;;; ---------------------------------------------------------------------------
182 (defmethod map-prototypes-of :around
(fn thing
)
183 (declare (ignore fn
))
184 (when (prototype-exists-p thing
)
187 ;;; ---------------------------------------------------------------------------
189 (defmethod map-prototypes-of (fn (thing standard-class
))
190 (map-subclass-prototypes fn thing
))
192 ;;; ---------------------------------------------------------------------------
194 (defmethod map-prototypes-of (fn (thing built-in-class
))
195 (map-subclass-prototypes fn thing
))
197 ;;; ---------------------------------------------------------------------------
199 (defun map-subclass-prototypes (fn thing
)
200 (mopu:map-subclasses thing
202 (when (prototype-exists-p subclass
)
203 (funcall fn
(prototype-of subclass
)))))
206 ;;; ---------------------------------------------------------------------------
208 (defmethod prototypes-of (thing)
209 (containers:collect-using
'map-prototypes-of nil thing
))
211 ;;; ---------------------------------------------------------------------------
213 (defmethod prototype-exists-p (thing)
214 ;; the expensive way to see if a prototype exists is to try and make one
215 ;; and see if it works...
217 (let ((creator-method (compute-applicable-methods #'prototype-of
(list thing
))))
219 (let ((x (prototype-of thing
)))
220 (declare (optimize (safety 3) (debug 3) (speed 0) (space 0)))
223 (error (c) (inspect c
) nil
)))
225 ;;; ---------------------------------------------------------------------------
227 (defmethod prototype-of ((thing standard-class
))
228 (allocate-instance thing
))
230 ;;; ---------------------------------------------------------------------------
232 (defmethod prototype-of ((thing (eql 'fixnum
)))
233 (variates:integer-random variates
:*random-generator
* -
10 10))
240 (defmethod more-prototypes-p :before
((testsuite test-mixin
))
241 (setf (current-step testsuite
) 'more-prototypes-p
))
243 ;;; ---------------------------------------------------------------------------
245 (defmethod initialize-prototypes :before
((testsuite test-mixin
))
246 (setf (current-step testsuite
) 'initialize-prototypes
))
248 ;;; ---------------------------------------------------------------------------
250 (defmethod next-prototype :before
((testsuite test-mixin
))
251 (setf (current-step testsuite
) 'next-prototype
))
253 ;;; ---------------------------------------------------------------------------
255 (defmethod testsuite-teardown :before
((testsuite test-mixin
))
256 (setf (current-step testsuite
) 'testsuite-teardown
))
258 ;;; ---------------------------------------------------------------------------
260 (defmethod start-test :before
261 ((result test-result
) (testsuite test-mixin
) method-name
)
262 (declare (ignore method-name
))
263 (setf (current-step testsuite
) 'start-test
))
265 ;;; ---------------------------------------------------------------------------
267 (defmethod end-test :before
268 ((result test-result
) (testsuite test-mixin
) method-name
)
269 (declare (ignore method-name
))
270 (setf (current-step testsuite
) 'end-test
))
272 ;;; ---------------------------------------------------------------------------
274 (defmethod setup-test :before
((testsuite test-mixin
))
275 (setf (current-step testsuite
) 'setup-test
))
277 ;;; ---------------------------------------------------------------------------
280 (defmethod teardown-test :before
((testsuite test-mixin
))
281 (setf (current-step testsuite
) 'teardown-test
))