/[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.2 by pfdietz, Sun Dec 26 04:12:31 2004 UTC revision 1.3 by pfdietz, Sun Jan 16 03:26:58 2005 UTC
# Line 44  Line 44 
44                              for tp in param-types                              for tp in param-types
45                              when x                              when x
46                              collect `(type ,tp ,p)))                              collect `(type ,tp ,p)))
47            (rval (apply operator vals))            (rval (cl:handler-bind
48                     (#+sbcl (sb-ext::compiler-note #'muffle-warning)
49                             (warning #'muffle-warning))
50                     (eval (cons operator vals))))
51            (result-type (if (and enclosing-the (integerp rval))            (result-type (if (and enclosing-the (integerp rval))
52                             (make-random-type-containing rval)                             (make-random-type-containing rval)
53                           t))                           t))
# Line 86  Line 89 
89                     :vals vals                     :vals vals
90                     :result result                     :result result
91                     :rval rval))                     :rval rval))
92         (unless (equal result rval)         (unless (rt::equalp-with-case result rval)
93           (return *random-type-prop-result*))))))           (return *random-type-prop-result*))))))
94    
95  (defmethod make-random-type-containing ((val integer))  (defmethod make-random-type-containing ((val integer))
# Line 94  Line 97 
97     (2 (let ((tp (random-from-seq '(t number real rational))))     (2 (let ((tp (random-from-seq '(t number real rational))))
98          (if #-allegro (coin) #+allegro nil          (if #-allegro (coin) #+allegro nil
99              (find-class tp) tp)))              (find-class tp) tp)))
100     (1 (random-from-seq '(integer signed-byte)))     (1 (random-from-seq '(integer signed-byte atom)))
101     #- allegro (1 (find-class 'integer))     #- allegro (1 (find-class 'integer))
102     (2 `(eql ,val))     (2 `(eql ,val))
103     (2 (let* ((n1 (random 4))     (2 (let* ((n1 (random 4))
# Line 114  Line 117 
117     (2 (if (>= val 0) `unsigned-byte     (2 (if (>= val 0) `unsigned-byte
118          (make-random-type-containing val)))))          (make-random-type-containing val)))))
119    
120    (defmethod make-random-type-containing ((val character))
121      (rcase
122       (1 `(eql ,val))
123       (1 'character)
124       (1 (if (typep val 'base-char) 'base-char (make-random-type-containing val)))
125       (1 (if (typep val 'standard-char) 'standard-char (make-random-type-containing val)))
126       (1 (if (typep val 'extended-char) 'extended-char (make-random-type-containing val)))
127       (1 (let* ((n1 (random 4))
128                 (n2 (random 4))
129                 (l1 (loop repeat n1 collect (make-random-character)))
130                 (l2 (loop repeat n2 collect (make-random-character))))
131            `(member ,@l1 ,val ,@l2)))
132       (1 (random-from-seq #(t atom)))))
133    
134    (defmethod make-random-type-containing ((val symbol))
135      (rcase
136       (1 `(eql ,val))
137       (3 'symbol)
138       (1 (if (null val) 'null (make-random-type-containing val)))
139       (1 (if (member val '(t nil)) 'boolean (make-random-type-containing val)))
140       (1 (if (keywordp val) 'keyword (make-random-type-containing val)))
141       (1 (let* ((n1 (random 4))
142                 (n2 (random 4))
143                 (l1 (loop repeat n1 collect (make-random-symbol)))
144                 (l2 (loop repeat n2 collect (make-random-symbol))))
145            `(member ,@l1 ,val ,@l2)))
146       (1 (random-from-seq #(t atom)))))
147    
148    (defun make-random-character ()
149      (rcase
150       (2 (random-from-seq +standard-chars+))
151       (2 (or (code-char (random (min 256 char-code-limit)))
152              (make-random-character)))
153       (1 (or (code-char (random (min (ash 1 16) char-code-limit)))
154              (make-random-character)))
155       (1 (or (code-char (random (min (ash 1 24) char-code-limit)))
156              (make-random-character)))))
157    
158    (defmethod make-random-type-containing ((val rational))
159      (rcase
160       (1 `(eql ,val))
161       (1 (let* ((n1 (random 4))
162                 (n2 (random 4))
163                 (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))
164                 (l2 (loop repeat n1 collect (make-random-element-of-type 'rational))))
165            `(member ,@l1 ,val ,@l2)))
166       (1 `(rational ,val))
167       (1 `(rational * ,val))
168       (1 (let ((v (make-random-element-of-type 'rational)))
169            (if (<= v val)
170                `(rational ,v ,val)
171              `(rational ,val ,v))))
172       ))
173    
174                        
           
             
             
             
                   

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

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