/[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.3 by pfdietz, Sun Jan 16 03:26:58 2005 UTC revision 1.4 by pfdietz, Sun Feb 27 23:08:14 2005 UTC
# Line 15  Line 15 
15    (:documentation    (:documentation
16     "Given a value, generate a random type that contains that value."))     "Given a value, generate a random type that contains that value."))
17    
18  (defun do-random-type-prop-tests (&key operator  (declaim (special *param-types* *params* *is-var?* *form*))
19                                         (minargs 2)  
20                                         (maxargs minargs)  (defun do-random-type-prop-tests
21                                         (arg-types nil)    (operator &key
22                                         (rest-type 'integer)              (minargs 2)
23                                         (reps 1000)              (maxargs minargs)
24                                         (enclosing-the nil))              (arg-types nil)
25                (rest-type 'integer)
26                (reps 1000)
27                (enclosing-the nil)
28                (test #'regression-test::equalp-with-case))
29    (assert (<= 1 minargs maxargs 20))    (assert (<= 1 minargs maxargs 20))
30    (loop    (dotimes (i reps)
31     repeat reps      again
32     do      (let* ((param-names
    (let* ((param-names  
33             '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10             '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10
34               p11 p12 p13 p14 p15 p16 p17 p18 p19 p20))               p11 p12 p13 p14 p15 p16 p17 p18 p19 p20))
35            (nargs (+ minargs (random (- maxargs minargs -1))))            (nargs (+ minargs (random (- maxargs minargs -1))))
36            (types (append arg-types            (types (subseq
37                           (make-list (- nargs (length arg-types))                    (append arg-types
38                                      :initial-element rest-type)))                            (make-list (max 0 (- nargs (length arg-types)))
39            (vals (mapcar #'make-random-element-of-type types))                                       :initial-element rest-type))
40                      0 nargs))
41              ; (vals (mapcar #'make-random-element-of-type types))
42              (vals (setq *params*
43                          (or (make-random-arguments types) (go again))))
44            (is-var? (loop repeat (length vals) collect (coin)))            (is-var? (loop repeat (length vals) collect (coin)))
45              (*is-var?* is-var?)
46            (params (loop for x in is-var?            (params (loop for x in is-var?
47                          for p in param-names                          for p in param-names
48                          when x collect p))                          when x collect p))
49            (param-types (mapcar #'make-random-type-containing vals))            (param-types (mapcar #'make-random-type-containing vals))
50              (*param-types* param-types)
51            (type-decls (loop for x in is-var?            (type-decls (loop for x in is-var?
52                              for p in param-names                              for p in param-names
53                              for tp in param-types                              for tp in param-types
# Line 47  Line 56 
56            (rval (cl:handler-bind            (rval (cl:handler-bind
57                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)
58                           (warning #'muffle-warning))                           (warning #'muffle-warning))
59                   (eval (cons operator vals))))                   (let ((eval-form (cons operator (loop for v in vals collect `(quote ,v)))))
60                       ;; (dotimes (i 100) (eval eval-form))
61                       (eval eval-form))))
62            (result-type (if (and enclosing-the (integerp rval))            (result-type (if (and enclosing-the (integerp rval))
63                             (make-random-type-containing rval)                             (make-random-type-containing rval)
64                           t))                           t))
# Line 60  Line 71 
71                                                   (1 (let ((tp (make-random-type-containing v)))                                                   (1 (let ((tp (make-random-type-containing v)))
72                                                        `(the ,tp ,p)))                                                        `(the ,tp ,p)))
73                                                   (1 p))                                                   (1 p))
74                                                v))))                                                (if (or (consp v)
75                                                          (and (symbolp v) (not (or (keywordp v)
76                                                                                    (member v '(nil t))))))
77                                                      `(quote ,v)
78                                                      v)))))
79            (form            (form
80             `(lambda (r ,@params)             `(lambda (r ,@params)
81                (declare (optimize speed (safety 1))                (declare (optimize speed (safety 1))
# Line 68  Line 83 
83                         ,@ type-decls)                         ,@ type-decls)
84                (setf (aref r)                (setf (aref r)
85                      ,(if enclosing-the `(the ,result-type ,expr) expr))                      ,(if enclosing-the `(the ,result-type ,expr) expr))
86                (values))))                (values)))
87              (*form* form))
88       (when *print-random-type-prop-input*       (when *print-random-type-prop-input*
89         (let ((*print-pretty* t)         (let ((*print-pretty* t)
90               (*print-case* :downcase))               (*print-case* :downcase))
# Line 82  Line 98 
98                           (warning #'muffle-warning))                           (warning #'muffle-warning))
99                   (compile nil form)))                   (compile nil form)))
100              (r (make-array nil :element-type upgraded-result-type))              (r (make-array nil :element-type upgraded-result-type))
101              (result (progn (apply fn r param-vals) (aref r))))              (result (progn
102                          ;; (dotimes (i 100) (apply fn r param-vals))
103                          (apply fn r param-vals)
104                          (aref r))))
105         (setq *random-type-prop-result*         (setq *random-type-prop-result*
106               (list :upgraded-result-type upgraded-result-type               (list :upgraded-result-type upgraded-result-type
107                     :form form                     :form form
108                     :vals vals                     :vals vals
109                     :result result                     :result result
110                     :rval rval))                     :rval rval))
111         (unless (rt::equalp-with-case result rval)         (unless (funcall test result rval)
112           (return *random-type-prop-result*))))))           (return *random-type-prop-result*))))))
113    
114    (defun make-random-arguments (types-or-funs)
115      (let ((vals nil))
116        (loop for type-or-fun in types-or-funs
117              for type = (or (typecase type-or-fun
118                               ((and function (not symbol))
119                                (apply type-or-fun vals))
120                               (t type-or-fun))
121                             (return-from make-random-arguments nil) ;; null type
122                             )
123              for val = (make-random-element-of-type type)
124              do (setf vals (nconc vals (list val))))
125        ;; (dolist (v vals) (describe v))
126        vals))
127    
128  (defmethod make-random-type-containing ((val integer))  (defmethod make-random-type-containing ((val integer))
129    (rcase    (rcase
130     (2 (let ((tp (random-from-seq '(t number real rational))))     (2 (let ((tp (random-from-seq '(t number real rational))))
# Line 145  Line 178 
178          `(member ,@l1 ,val ,@l2)))          `(member ,@l1 ,val ,@l2)))
179     (1 (random-from-seq #(t atom)))))     (1 (random-from-seq #(t atom)))))
180    
 (defun make-random-character ()  
   (rcase  
    (2 (random-from-seq +standard-chars+))  
    (2 (or (code-char (random (min 256 char-code-limit)))  
           (make-random-character)))  
    (1 (or (code-char (random (min (ash 1 16) char-code-limit)))  
           (make-random-character)))  
    (1 (or (code-char (random (min (ash 1 24) char-code-limit)))  
           (make-random-character)))))  
   
181  (defmethod make-random-type-containing ((val rational))  (defmethod make-random-type-containing ((val rational))
182    (rcase    (rcase
183     (1 `(eql ,val))     (1 `(eql ,val))
184     (1 (let* ((n1 (random 4))     (1 (let* ((n1 (random 4))
185               (n2 (random 4))               (n2 (random 4))
186               (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))               (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))
187               (l2 (loop repeat n1 collect (make-random-element-of-type 'rational))))               (l2 (loop repeat n2 collect (make-random-element-of-type 'rational))))
188          `(member ,@l1 ,val ,@l2)))          `(member ,@l1 ,val ,@l2)))
189     (1 `(rational ,val))     (1 `(rational ,val))
190     (1 `(rational * ,val))     (1 `(rational * ,val))
# Line 171  Line 194 
194            `(rational ,val ,v))))            `(rational ,val ,v))))
195     ))     ))
196    
             
197    (defmethod make-random-type-containing ((val float))
198      (let ((names (loop for tp in '(short-float single-float double-float long-float)
199                         when (typep val tp)
200                         collect tp)))
201        (rcase
202         (1 `(eql ,val))
203         (1 `(member ,val))
204         (1 (random-from-seq names))
205         (1 (if (>= val 0)
206                `(,(random-from-seq names) ,(float 0 val) ,val)
207              `(,(random-from-seq names) ,val ,(float 0 val)))))))
208    
209    (defun make-random-array-dimension-spec (array dim-index)
210      (assert (<= 0 dim-index))
211      (assert (< dim-index (array-rank array)))
212      (let ((dim (array-dimension array dim-index)))
213        (rcase (1 '*) (1 dim))))
214    
215    (defmethod make-random-type-containing ((val bit-vector))
216      (rcase
217       (1 (let ((root (if (and (coin)
218                               (typep val 'simple-bit-vector))
219                          'simple-bit-vector
220                        'bit-vector)))
221            (rcase (1 root)
222                   (1 `(,root))
223                   (3 `(,root ,(make-random-array-dimension-spec val 0))))))
224       (2 (call-next-method))))
225    
226    (defmethod make-random-type-containing ((val vector))
227      (rcase
228       (2 (let ((root 'vector)
229                (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector))
230                (etype (rcase (1 '*)
231                              (1 (array-element-type val))
232                              ;; Add rule for creating new element types?
233                              )))
234            (rcase (1 alt-root)
235                   (1 `(,alt-root))
236                   (1 `(,root ,etype))
237                   (2 (if (and (simple-vector-p val) (coin))
238                          `(simple-vector ,(make-random-array-dimension-spec val 0))
239                        `(,root ,etype ,(make-random-array-dimension-spec val 0)))))))
240       (3 (call-next-method))))
241    
242    (defmethod make-random-type-containing ((val array))
243      (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array))
244            (etype (rcase (1 (array-element-type val)) (1 '*)))
245            (rank (array-rank val)))
246        (rcase
247         (1 root)
248         (1 `(,root))
249         (1 `(,root ,etype))
250         (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i))))
251         (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i))))
252         (1 `(,root ,etype ,rank)))))
253    
254    (defmethod make-random-type-containing ((val string))
255      (rcase
256       (1 (let ((root (if (and (coin)
257                               (typep val 'simple-string))
258                          'simple-string
259                        'string)))
260            (rcase (1 root)
261                   (1 `(,root))
262                   (3 `(,root ,(make-random-array-dimension-spec val 0))))))
263       (2 (call-next-method))))
264    
265    (defmethod make-random-type-containing ((val cons))
266      (rcase
267       (3 'cons)
268       (2 'list)
269       (1 `(cons ,(make-random-type-containing (car val))))
270       (1 `(cons t ,(make-random-type-containing (cdr val))))
271       (1 t)))
272    
273    (defmethod make-random-type-containing ((val complex))
274      (rcase
275       (1 'complex)
276       (1 'number)
277       #-gcl (1 `(complex ,(upgraded-complex-part-type (type-of (realpart val)))))
278       (1 `(eql ,val))))
279    
280    (defmethod make-random-type-containing ((val generic-function))
281      (rcase
282       (1 'generic-function)
283       (1 (call-next-method))))
284    
285    (defmethod make-random-type-containing ((val function))
286      (rcase
287       (1 'function)
288       (1 (if (typep val 'compiled-function)
289              'compiled-function
290            'function))
291       (1 t)))

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

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