/[gcl]/gcl/ansi-tests/random-type-prop.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-type-prop.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by pfdietz, Sun Mar 6 20:32:35 2005 UTC revision 1.7 by pfdietz, Wed Mar 9 02:27:06 2005 UTC
# Line 28  Line 28 
28              (reps *default-reps*)              (reps *default-reps*)
29              (enclosing-the nil)              (enclosing-the nil)
30              (cell *default-cell*)              (cell *default-cell*)
31                (ignore nil)
32              (test #'regression-test::equalp-with-case))              (test #'regression-test::equalp-with-case))
33    (assert (<= 1 minargs maxargs 20))    (assert (<= 1 minargs maxargs 20))
34    (prog1
35    (dotimes (i reps)    (dotimes (i reps)
36      again      again
37        (handler-bind
38         #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again)))))
39         #+lispworks ()
40      (let* ((param-names      (let* ((param-names
41             '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10             '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10
42               p11 p12 p13 p14 p15 p16 p17 p18 p19 p20))               p11 p12 p13 p14 p15 p16 p17 p18 p19 p20))
# Line 110  Line 115 
115                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)
116                           (warning #'muffle-warning))                           (warning #'muffle-warning))
117                   (compile nil form)))                   (compile nil form)))
118              (result (if store-into-cell?              (result
119                          (let ((r (make-array nil :element-type upgraded-result-type)))               (if store-into-cell?
120                            (apply fn r param-vals)                   (let ((r (make-array nil :element-type upgraded-result-type)))
121                            (aref r))                     (apply fn r param-vals)
122                        (apply fn param-vals))))                     (aref r))
123                   (apply fn param-vals))))
124         (setq *random-type-prop-result*         (setq *random-type-prop-result*
125               (list :upgraded-result-type upgraded-result-type               (list :upgraded-result-type upgraded-result-type
126                     :form form                     :form form
# Line 122  Line 128 
128                     :result result                     :result result
129                     :rval rval))                     :rval rval))
130         (unless (funcall test result rval)         (unless (funcall test result rval)
131           (return *random-type-prop-result*))))))           (return *random-type-prop-result*))))
132      #+allegro (excl::gc t)
133      ))))
134    
135  (defun make-random-arguments (types-or-funs)  (defun make-random-arguments (types-or-funs)
136    (let ((vals nil))    (let ((vals nil))
# Line 316  Line 324 
324            'compiled-function            'compiled-function
325          'function))          'function))
326     (1 t)))     (1 t)))
327    
328    ;;; Macro for defining random type prop tests
329    
330    (defmacro def-type-prop-test (name &body args)
331      `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP."
332                                      (string name))
333                         (find-package :cl-test))
334         (do-random-type-prop-tests ,@args)
335         nil))

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26