/[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.13 by pfdietz, Mon Jul 4 13:18:15 2005 UTC revision 1.14 by pfdietz, Sat Jul 16 15:27:03 2005 UTC
# Line 5  Line 5 
5    
6  (in-package :cl-test)  (in-package :cl-test)
7    
8  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel)
9      (compile-and-load "random-aux.lsp")
10    (compile-and-load "random-int-form.lsp"))    (compile-and-load "random-int-form.lsp"))
11    
12  (defvar *print-random-type-prop-input* nil)  (defvar *print-random-type-prop-input* nil)
13  (defparameter *random-type-prop-result* nil)  (defparameter *random-type-prop-result* nil)
14    
15  (defgeneric make-random-type-containing (val)  (defgeneric make-random-type-containing (val)
16    (:documentation    (:method-combination randomized)
17     "Given a value, generate a random type that contains that value."))    (:documentation "Given a value, generate a random type that contains that value."))
18    
19  (declaim (special *param-types* *params* *is-var?* *form*))  (declaim (special *param-types* *params* *is-var?* *form*))
20    
# Line 232  Line 233 
233      ;; (dolist (v vals) (describe v))      ;; (dolist (v vals) (describe v))
234      vals))      vals))
235    
236  ;; Default method  (defmacro defmethods (name &rest bodies)
237  (defmethod make-random-type-containing ((val t)) t)    `(progn
238         ,@(mapcar
239  (defmethod make-random-type-containing ((val standard-class))          #'(lambda (body) `(defmethod ,name ,@body))
240    (random-from-seq #(standard-class class t)))          bodies)))
241    
242  (defmethod make-random-type-containing ((val structure-class))  (defmethods make-random-type-containing
243    (random-from-seq #(structure-class class t)))    (4 ((val t))
244         (rcase
245  (defmethod make-random-type-containing ((val integer))        (1 t)
246    (rcase        (1 (if (consp val) 'cons 'atom))
247     (2 (let ((tp (random-from-seq '(t number real rational))))        (1 `(eql ,val))
248          (if #-allegro (coin) #+allegro nil        (1 (let* ((n1 (random 4))
249              (find-class tp) tp)))                  (n2 (random 4))
250     (1 (random-from-seq '(integer signed-byte atom)))                  ;; Replace these calls with (make-random-element-of-type t)
251     #- allegro (1 (find-class 'integer))                  ;; at some point
252     (2 `(eql ,val))                  (l1 (loop repeat n1 collect (random-leaf)))
253     (2 (let* ((n1 (random 4))                  (l2 (loop repeat n2 collect (random-leaf))))
254               (n2 (random 4))             `(member ,@l1 ,val ,@l2)))))
255               (l1 (loop repeat n1 collect (make-random-integer)))  
256               (l2 (loop repeat n2 collect (make-random-integer))))    (1 ((val standard-object)) 'standard-object)
257          `(member ,@l1 ,val ,@l2)))    (1 ((val class)) 'class)
258     (4 (let ((lo (abs (make-random-integer))))    (1 ((val standard-class)) 'standard-class)
259          `(integer ,(- val lo))))    (1 ((val structure-class)) 'structure-class)
260     (4 (let ((lo (abs (make-random-integer))))    (1 ((val number)) 'number)
261          `(integer ,(- val lo) *)))    (1 ((val real)) 'real)
262     (4 (let ((hi (abs (make-random-integer))))    (1 ((val ratio)) 'ratio)
263          `(integer * ,(+ val hi))))  
264     (8 (let ((lo (abs (make-random-integer)))    (1 ((val integer))
265              (hi (abs (make-random-integer))))       (rcase
266          `(integer ,(- val lo) ,(+ val hi))))        (1 'integer)
267     (2 (if (>= val 0) `unsigned-byte        (1 'signed-byte)
268          (make-random-type-containing val)))))        (1 (let* ((n1 (random 4))
269                    (n2 (random 4))
270  (defmethod make-random-type-containing ((val character))                  (l1 (loop repeat n1 collect (make-random-integer)))
271    (rcase                  (l2 (loop repeat n2 collect (make-random-integer))))
272     (1 `(eql ,val))             `(member ,@l1 ,val ,@l2)))
273     (1 'character)        (1 (let ((lo (abs (make-random-integer))))
274     (1 (if (typep val 'base-char) 'base-char (make-random-type-containing val)))             `(integer ,(- val lo))))
275     (1 (if (typep val 'standard-char) 'standard-char (make-random-type-containing val)))        (2 (let ((lo (abs (make-random-integer))))
276     (1 (if (typep val 'extended-char) 'extended-char (make-random-type-containing val)))             `(integer ,(- val lo) *)))
277     (1 (let* ((n1 (random 4))        (2 (let ((hi (abs (make-random-integer))))
278               (n2 (random 4))             `(integer * ,(+ val hi))))
279               (l1 (loop repeat n1 collect (make-random-character)))        (4 (let ((lo (abs (make-random-integer)))
280               (l2 (loop repeat n2 collect (make-random-character))))                 (hi (abs (make-random-integer))))
281          `(member ,@l1 ,val ,@l2)))             `(integer ,(- val lo) ,(+ val hi))))
282     (1 (random-from-seq #(t atom)))))        (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil)))))
283    
284  (defmethod make-random-type-containing ((val symbol))    (2 ((val character))
285    (rcase       (rcase
286     (1 `(eql ,val))        (1 'character)
287     (3 'symbol)        (1 (if (typep val 'base-char) 'base-char
288     (1 (if (null val) 'null (make-random-type-containing val)))             #-sbcl 'extended-char
289     (1 (if (member val '(t nil)) 'boolean (make-random-type-containing val)))             #+sbcl (throw 'fail nil)
290     (1 (if (keywordp val) 'keyword (make-random-type-containing val)))             ))
291     (1 (let* ((n1 (random 4))        (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil)))
292               (n2 (random 4))        (1 (let* ((n1 (random 4))
293               (l1 (loop repeat n1 collect (make-random-symbol)))                  (n2 (random 4))
294               (l2 (loop repeat n2 collect (make-random-symbol))))                  (l1 (loop repeat n1 collect (make-random-character)))
295          `(member ,@l1 ,val ,@l2)))                  (l2 (loop repeat n2 collect (make-random-character))))
296     (1 (random-from-seq #(t atom)))))             `(member ,@l1 ,val ,@l2)))))
297    
298  (defmethod make-random-type-containing ((val rational))    (1 ((val null)) 'null)
299    (rcase  
300     (1 `(eql ,val))    (2 ((val symbol))
301     (1 (let* ((n1 (random 4))       (rcase
302               (n2 (random 4))        (1 'symbol)
303               (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))        (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil))))
304               (l2 (loop repeat n2 collect (make-random-element-of-type 'rational))))        (1 (let* ((n1 (random 4))
305          `(member ,@l1 ,val ,@l2)))                  (n2 (random 4))
306     (1 `(rational ,val))                  (l1 (loop repeat n1 collect (make-random-symbol)))
307     (1 `(rational * ,val))                  (l2 (loop repeat n2 collect (make-random-symbol))))
308     (1 (let ((v (make-random-element-of-type 'rational)))             `(member ,@l1 ,val ,@l2)))))
309          (if (<= v val)  
310              `(rational ,v ,val)    (1 ((val rational))
311            `(rational ,val ,v))))       (rcase
312     ))        (1 'rational)
313          (1 (let* ((n1 (random 4))
314  (defmethod make-random-type-containing ((val float))                  (n2 (random 4))
315    (let ((names (loop for tp in '(short-float single-float double-float long-float)                  (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))
316                       when (typep val tp)                  (l2 (loop repeat n2 collect (make-random-element-of-type 'rational))))
317                       collect tp)))             `(member ,@l1 ,val ,@l2)))
318      (rcase        (1 `(rational ,val))
319       (1 `(eql ,val))        (1 `(rational * ,val))
320       (1 `(member ,val))        (1 (let ((v (make-random-element-of-type 'rational)))
321       (1 (random-from-seq names))             (if (<= v val)
322       (1 (if (>= val 0)                 `(rational ,v ,val)
323              `(,(random-from-seq names) ,(float 0 val) ,val)               `(rational ,val ,v))))))
324            `(,(random-from-seq names) ,val ,(float 0 val)))))))    
325      (1 ((val float))
326         (rcase
327          (1 (let* ((n1 (random 4))
328                    (n2 (random 4))
329                    (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val)))))
330                    (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val))))))
331               `(member ,@l1 ,val ,@l2)))
332          (1 (let ((names (float-types-containing val)))
333               (random-from-seq names)))
334          (1 (let ((name (random-from-seq (float-types-containing val))))
335               (if (>= val 0)
336                   `(,name ,(coerce 0 name) ,val)
337                 `(,name ,val ,(coerce 0 name)))))))
338      )
339    
340    (defun float-types-containing (val)
341      (loop for n in '(short-float single-float double-float long-float float)
342            when (typep val n)
343            collect n))    
344    
345  (defun make-random-array-dimension-spec (array dim-index)  (defun make-random-array-dimension-spec (array dim-index)
346    (assert (<= 0 dim-index))    (assert (<= 0 dim-index))
# Line 328  Line 348 
348    (let ((dim (array-dimension array dim-index)))    (let ((dim (array-dimension array dim-index)))
349      (rcase (1 '*) (1 dim))))      (rcase (1 '*) (1 dim))))
350    
351  (defmethod make-random-type-containing ((val bit-vector))  ;;; More methods
352    (rcase  (defmethods make-random-type-containing
353     (1 (let ((root (if (and (coin)    (3 ((val bit-vector))
354                             (typep val 'simple-bit-vector))       (let ((root (if (and (coin)
355                        'simple-bit-vector                            (typep val 'simple-bit-vector))
356                      'bit-vector)))                       'simple-bit-vector
357          (rcase (1 root)                     'bit-vector)))
358                 (1 `(,root))         (rcase (1 root)
359                 (3 `(,root ,(make-random-array-dimension-spec val 0))))))                (1 `(,root))
360     (2 (call-next-method))))                (3 `(,root ,(make-random-array-dimension-spec val 0))))))
361    
362  (defmethod make-random-type-containing ((val vector))    (3 ((val vector))
363    (rcase       (let ((root 'vector)
    (2 (let ((root 'vector)  
364              (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector))              (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector))
365              (etype (rcase (1 '*)              (etype (rcase (1 '*)
366                            (1 (array-element-type val))                            (1 (array-element-type val))
# Line 353  Line 372 
372                 (2 (if (and (simple-vector-p val) (coin))                 (2 (if (and (simple-vector-p val) (coin))
373                        `(simple-vector ,(make-random-array-dimension-spec val 0))                        `(simple-vector ,(make-random-array-dimension-spec val 0))
374                      `(,root ,etype ,(make-random-array-dimension-spec val 0)))))))                      `(,root ,etype ,(make-random-array-dimension-spec val 0)))))))
    (3 (call-next-method))))  
375    
376  (defmethod make-random-type-containing ((val array))    (3 ((val array))
377    (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array))       (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array))
378          (etype (rcase (1 (array-element-type val)) (1 '*)))          (etype (rcase (1 (array-element-type val)) (1 '*)))
379          (rank (array-rank val)))          (rank (array-rank val)))
380      (rcase         (rcase
381       (1 root)          (1 root)
382       (1 `(,root))          (1 `(,root))
383       (1 `(,root ,etype))          (1 `(,root ,etype))
384       (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i))))          (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i))))
385       (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i))))          (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i))))
386       #-ecl (1 `(,root ,etype ,rank))          #-ecl (1 `(,root ,etype ,rank)))))
387       (4 (call-next-method))  
388       )))    (3 ((val string))
389         (let ((root (cond
390  (defmethod make-random-type-containing ((val string))                    ((and (coin)
391    (rcase                          (typep val 'base-string))
392     (1 (let ((root (cond                     (cond
393                     ((and (coin)                      ((and (coin) (typep val 'simple-base-string))
394                           (typep val 'base-string))                       'simple-base-string)
395                      (cond                      (t 'base-string)))
396                       ((and (coin) (typep val 'simple-base-string))                    ((and (coin)
397                        'simple-base-string)                          (typep val 'simple-string))
398                       (t 'base-string)))                     'simple-string)
399                     ((and (coin)                    (t 'string))))
400                           (typep val 'simple-string))         (rcase (1 root)
401                      'simple-string)                (1 `(,root))
402                     (t 'string))))                (3 `(,root ,(make-random-array-dimension-spec val 0))))))
403          (rcase (1 root)  
404                 (1 `(,root))    (1 ((val list)) 'list)
405                 (3 `(,root ,(make-random-array-dimension-spec val 0))))))  
406     (2 (call-next-method))))    (1 ((val cons))
407         (rcase
408  (defmethod make-random-type-containing ((val cons))        (1 'cons)
409    (rcase        (2 `(cons ,(make-random-type-containing (car val))
410     (2 'cons)                  ,(make-random-type-containing (cdr val))))
411     (2 'list)        (1 `(cons ,(make-random-type-containing (car val))
412     (1 `(cons ,(make-random-type-containing (car val))))                  ,(random-from-seq #(t *))))
413     (1 `(cons ,(make-random-type-containing (car val))        (1 `(cons ,(make-random-type-containing (car val))))
414               ,(random-from-seq #(t *))))        (1 `(cons ,(random-from-seq #(t *))
415     (2 `(cons ,(random-from-seq #(t *))                  ,(make-random-type-containing (cdr val))
416               ,(make-random-type-containing (cdr val))))                  ))))
417     (2 `(cons ,(make-random-type-containing (car val))  
418               ,(make-random-type-containing (cdr val))))    (1 ((val complex))
419     (1 t)))       (rcase
420          (1 'complex)
421  (defmethod make-random-type-containing ((val complex))        #-gcl
422    (rcase        (1 (let* ((t1 (type-of (realpart val)))
423     (1 'complex)                  (t2 (type-of (imagpart val)))
424     (1 'number)                  (part-type
425     #-gcl (1                   (cond
426            (let* ((t1 (type-of (realpart val)))                    ((subtypep t1 t2) (upgraded-complex-part-type t2))
427                   (t2 (type-of (imagpart val)))                    ((subtypep t2 t1) (upgraded-complex-part-type t1))
428                   (part-type                    ((and (subtypep t1 'rational)
429                    (cond                          (subtypep t2 'rational))
430                     ((subtypep t1 t2) (upgraded-complex-part-type t2))                     'rational)
431                     ((subtypep t2 t1) (upgraded-complex-part-type t1))                    (t
432                     ((and (subtypep t1 'rational)                     (upgraded-complex-part-type `(or ,t1 ,t2))))))
433                           (subtypep t2 'rational))             (if (subtypep 'real part-type)
434                      'rational)                 '(complex real)
435                     (t               `(complex ,part-type))))))
436                      (upgraded-complex-part-type `(or ,t1 ,t2))))))  
437              (if (subtypep 'real part-type)    (1 ((val generic-function)) 'generic-function)
438                  '(complex real)    (1 ((val function))
439                `(complex ,part-type))))       (rcase
440     (1 `(eql ,val))))        (1 'function)
441          (1 (if (typep val 'compiled-function)
442  (defmethod make-random-type-containing ((val generic-function))               'compiled-function
443    (rcase             'function))))
444     (1 'generic-function)    )
    (1 (call-next-method))))  
   
 (defmethod make-random-type-containing ((val function))  
   (rcase  
    (1 'function)  
    (1 (if (typep val 'compiled-function)  
           'compiled-function  
         'function))  
    (1 t)))  
   
 (defmethod make-random-type-containing ((val sequence))  
   (rcase  
    (1 'sequence)  
    (2 (call-next-method))))  
445    
446  ;;; Macro for defining random type prop tests  ;;; Macro for defining random type prop tests
447    

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14

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