/[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.4 by pfdietz, Sun Feb 27 23:08:14 2005 UTC revision 1.5 by pfdietz, Sat Mar 5 17:20:01 2005 UTC
# Line 25  Line 25 
25              (rest-type 'integer)              (rest-type 'integer)
26              (reps 1000)              (reps 1000)
27              (enclosing-the nil)              (enclosing-the nil)
28                (cell t)
29              (test #'regression-test::equalp-with-case))              (test #'regression-test::equalp-with-case))
30    (assert (<= 1 minargs maxargs 20))    (assert (<= 1 minargs maxargs 20))
31    (dotimes (i reps)    (dotimes (i reps)
# Line 76  Line 77 
77                                                                                  (member v '(nil t))))))                                                                                  (member v '(nil t))))))
78                                                    `(quote ,v)                                                    `(quote ,v)
79                                                    v)))))                                                    v)))))
80              (speed (random 4))
81              (space (random 4))
82              (safety #-allegro (random 4)
83                      #+allegro (1+ (random 3)))
84              (debug (random 4))
85              (store-into-cell? (and cell (coin)))
86            (form            (form
87             `(lambda (r ,@params)             `(lambda (,@(when store-into-cell? '(r)) ,@params)
88                (declare (optimize speed (safety 1))                (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space))
89                         (type (simple-array ,upgraded-result-type nil) r)                         ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r)))
90                         ,@ type-decls)                         ,@ type-decls)
91                (setf (aref r)                ,(let ((result-form
92                      ,(if enclosing-the `(the ,result-type ,expr) expr))                        (if enclosing-the `(the ,result-type ,expr) expr)))
93                (values)))                   (if store-into-cell?
94                         `(setf (aref r) ,result-form)
95                       result-form))))
96            (*form* form))            (*form* form))
97       (when *print-random-type-prop-input*       (when *print-random-type-prop-input*
98         (let ((*print-pretty* t)         (let ((*print-pretty* t)
# Line 97  Line 106 
106                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)
107                           (warning #'muffle-warning))                           (warning #'muffle-warning))
108                   (compile nil form)))                   (compile nil form)))
109              (r (make-array nil :element-type upgraded-result-type))              (result (if store-into-cell?
110              (result (progn                          (let ((r (make-array nil :element-type upgraded-result-type)))
111                        ;; (dotimes (i 100) (apply fn r param-vals))                            (apply fn r param-vals)
112                        (apply fn r param-vals)                            (aref r))
113                        (aref r))))                        (apply fn param-vals))))
114         (setq *random-type-prop-result*         (setq *random-type-prop-result*
115               (list :upgraded-result-type upgraded-result-type               (list :upgraded-result-type upgraded-result-type
116                     :form form                     :form form

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

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