/[gcl]/gcl/ansi-tests/random-int-form.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-int-form.lsp

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

revision 1.52 by pfdietz, Wed Dec 1 00:25:31 2004 UTC revision 1.53 by pfdietz, Sun Jan 16 03:30:21 2005 UTC
# Line 108  Line 108 
108  (defvar *random-int-form-catch-tags* nil)  (defvar *random-int-form-catch-tags* nil)
109  (defvar *go-tags* nil)  (defvar *go-tags* nil)
110    
111  (defvar *maximum-random-int-bits* 45)  (defvar *maximum-random-int-bits* 36)
112    
113  (defvar *random-vals-list-bound* 10)  (defvar *random-vals-list-bound* 10)
114    
# Line 267  Line 267 
267  (defparameter *flet-names* nil)  (defparameter *flet-names* nil)
268    
269  (defun make-random-integer ()  (defun make-random-integer ()
270    (let ((r (ash 1 (1+ (random 32)))))    (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
271      (- (random r) (floor (/ r 2)))))      (rcase
272         (6 (- (random r) (floor (/ r 2))))
273         (1 (- r (random (min 10 r))))
274         (1 (+ (floor (/ r 2)) (random (min 10 r)))))))
275    
276  (defun make-random-rational ()  (defun make-random-rational ()
277    (let* ((r (ash 1 (1+ (random 32))))    (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
278           (n (random r))           (n (random r)))
279           (d (loop for x = (random r) unless (zerop x) do (return x))))      (assert (>= r 2))
280      (if (coin) (/ n d) (- (/ n d)))))      (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
281          (if (coin) (/ n d) (- (/ n d))))))
282    
283  (defun make-random-float ()  (defun make-random-float ()
284    (rcase    (rcase
# Line 283  Line 287 
287     (1 (random most-positive-double-float))     (1 (random most-positive-double-float))
288     (1 (random most-positive-long-float))))     (1 (random most-positive-long-float))))
289    
290    (defun make-random-symbol ()
291      (rcase
292       (3 (random-from-seq #(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
293       (2 (random-from-seq *cl-symbols-vector*))
294       (1 (gensym))))
295    
296  (defun random-var-desc ()  (defun random-var-desc ()
297    (loop    (loop
298     (let* ((pos (random (length *vars*)))     (let* ((pos (random (length *vars*)))
# Line 342  Line 352 
352    
353       ;; flet call       ;; flet call
354       ;; #-(or armedbear)       ;; #-(or armedbear)
355       (30 ;; 5       (10
356        (make-random-integer-flet-call-form size))        (make-random-integer-flet-call-form size))
357    
358       (5 (make-random-aref-form size))       (5 (make-random-aref-form size))
# Line 353  Line 363 
363                                       rational rationalize                                       rational rationalize
364                                       numerator denominator                                       numerator denominator
365                                       identity progn floor                                       identity progn floor
366                                       #-(or armedbear) ignore-errors                                       ;; #-(or armedbear)
367                                         ignore-errors
368                                       cl:handler-case                                       cl:handler-case
369                                       restart-case                                       restart-case
370                                       ceiling truncate round realpart imagpart                                       ceiling truncate round realpart imagpart
# Line 368  Line 379 
379       (5 (make-random-integer-mapping-form size))       (5 (make-random-integer-mapping-form size))
380    
381       ;; prog1, multiple-value-prog1       ;; prog1, multiple-value-prog1
      #-(or armedbear)  
382       (4       (4
383        (let* ((op (random-from-seq #(prog1 multiple-value-prog1)))        (let* ((op (random-from-seq #(prog1 multiple-value-prog1)))
384               (nforms (random 4))               (nforms (random 4))
# Line 384  Line 394 
394            
395       (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))       (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))
396    
397       (2 `(the integer ,(make-random-integer-form (1- size))))       ;; #-armedbear
398         (10 `(the integer ,(make-random-integer-form (1- size))))
399                
400       (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size))))       (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size))))
401       (1 `(restart-bind nil ,(make-random-integer-form (1- size))))       (1 `(restart-bind nil ,(make-random-integer-form (1- size))))
402       #-armedbear (1 `(macrolet () ,(make-random-integer-form (1- size))))       #-armedbear
403         (1 `(macrolet () ,(make-random-integer-form (1- size))))
404         #-armedbear
405         (1 `(symbol-macrolet () ,(make-random-integer-form (1- size))))
406    
407       ;; dotimes       ;; dotimes
408       #-allegro       #-allegro
# Line 447  Line 461 
461                            
462       ;; Binary op       ;; Binary op
463       (30       (30
464        (let* ((op (random-from-seq       (let* ((op (random-from-seq
465                    '(+ - *  logand min max gcd                    '(+ - *  logand min max gcd
466                        lcm                        lcm
467                        #-:allegro                        #-:allegro
# Line 480  Line 494 
494       (40       (40
495        (let* ((op (random-from-seq #(+ - * logand min max        (let* ((op (random-from-seq #(+ - * logand min max
496                                        logior values lcm gcd logxor)))                                        logior values lcm gcd logxor)))
497               (nmax (case op ((* lcm gcd) 10) (t 20)))               (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40)))))
498               (nargs (1+ (min (random nmax) (random nmax) (random nmax))))               (nargs (1+ (min (random nmax) (random nmax))))
499               (sizes (random-partition (1- size) nargs))               (sizes (random-partition (1- size) nargs))
500               (args (mapcar #'make-random-integer-form sizes)))               (args (mapcar #'make-random-integer-form sizes)))
501          `(,op ,@args)))          `(,op ,@args)))
# Line 503  Line 517 
517       (5 (make-random-tagbody-and-progn size))       (5 (make-random-tagbody-and-progn size))
518    
519       ;; conditionals       ;; conditionals
520       (100       (30
521        (let* ((cond-size (random (max 1 (floor size 2))))        (let* ((cond-size (random (max 1 (floor size 2))))
522               (then-size (random (- size cond-size)))               (then-size (random (- size cond-size)))
523               (else-size (- size 1 cond-size then-size))               (else-size (- size 1 cond-size then-size))
# Line 526  Line 540 
540              ,(make-random-byte-spec-form s1)              ,(make-random-byte-spec-form s1)
541              ,(make-random-integer-form s2))))              ,(make-random-integer-form s2))))
542    
543       (20 (make-random-integer-binding-form size))       (50 (make-random-integer-binding-form size))
544    
545       ;; progv       ;; progv
546       #-(or armedbear)       #-(or armedbear)
# Line 539  Line 553 
553               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
554          `(block ,name ,(make-random-integer-form (1- size)))))          `(block ,name ,(make-random-integer-form (1- size)))))
555    
      #-armedbear  
556       (20       (20
557        (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))        (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))
558               (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))               (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
559          `(catch ,tag ,(make-random-integer-form (1- size)))))          `(catch ,tag ,(make-random-integer-form (1- size)))))
560            
561       (20 ;; setq and similar       (10 ;; setq and similar
562        (make-random-integer-setq-form size))        (make-random-integer-setq-form size))
563    
564       (10 (make-random-integer-case-form size))       (10 (make-random-integer-case-form size))
# Line 730  Line 743 
743               '(cons integer integer)))))               '(cons integer integer)))))
744       e1)))       e1)))
745    
746    (defun random2 (n)
747      (min (random n) (random n)))
748    
749    (defun random-from-seq2 (seq)
750      (elt seq (random2 (length seq))))
751    
752  (defun make-random-integer-binding-form (size)  (defun make-random-integer-binding-form (size)
753    (destructuring-bind (s1 s2) (random-partition (1- size) 2)    (destructuring-bind (s1 s2) (random-partition (1- size) 2)
754      (let* ((var (rcase      (let* ((var (random-from-seq2 (rcase
755                   (2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))                                     (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))
756                   (2 (random-from-seq *random-special-vars*))))                                     (2 *random-special-vars*))))
757             (e1 (make-random-integer-form s1))             (e1 (make-random-integer-form s1))
758             (type (multiple-value-bind (type2 e)             (type (multiple-value-bind (type2 e)
759                       (make-random-type-for-var var e1)                       (make-random-type-for-var var e1)
# Line 750  Line 769 
769          (rcase          (rcase
770           (8 `(,op ((,var ,e1))           (8 `(,op ((,var ,e1))
771                    ,@(rcase (1 `((declare (dynamic-extent ,var))))                    ,@(rcase (1 `((declare (dynamic-extent ,var))))
772                             (1 nil))                             (3 nil))
773                    ,e2))                    ,e2))
774           (2 `(multiple-value-bind (,var) ,e1 ,e2)))))))           (2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
775    
# Line 804  Line 823 
823                    ,@(mapcar #'make-random-integer-form sizes))                    ,@(mapcar #'make-random-integer-form sizes))
824                   ,@keyargs)))                   ,@keyargs)))
825       #-(or armedbear)       #-(or armedbear)
826       (1       (1      
827        (destructuring-bind (size1 size2) (random-partition (1- size) 2)        (destructuring-bind (size1 size2) (random-partition (1- size) 2)
828          (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6))          (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6))
829                 (var1 (random-from-seq vars))                 (var1 (random-from-seq vars))
# Line 1105  Line 1124 
1124     ((consp type)     ((consp type)
1125      (let ((type-op (first type)))      (let ((type-op (first type)))
1126        (ecase type-op        (ecase type-op
1127            (or
1128             (assert (cdr type))
1129             (make-random-element-of-type (random-from-seq (cdr type))))
1130          (integer          (integer
1131           (let ((lo (let ((lo (cadr type)))           (let ((lo (let ((lo (cadr type)))
1132                       (cond                       (cond
# Line 1145  Line 1167 
1167                   (assert (and (integerp bits) (>= bits 1)))                   (assert (and (integerp bits) (>= bits 1)))
1168                   (make-random-element-of-type                   (make-random-element-of-type
1169                    `(integer 0 ,(1- (ash 1 bits)))))))))                    `(integer 0 ,(1- (ash 1 bits)))))))))
1170            (eql
1171             (assert (= (length type) 2))
1172             (cadr type))
1173            (member
1174             (assert (cdr type))
1175             (random-from-seq (cdr type)))
1176          )))          )))
1177     (t     (t
1178      (ecase type      (ecase type
# Line 1153  Line 1181 
1181        (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))        (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
1182        (unsigned-byte (random-from-interval        (unsigned-byte (random-from-interval
1183                        (1+ (ash 1 (random *maximum-random-int-bits*))) 0))                        (1+ (ash 1 (random *maximum-random-int-bits*))) 0))
1184          (rational (locally (declare (notinline make-random-rational)) (make-random-rational)))
1185        (integer (let ((x (ash 1 (random *maximum-random-int-bits*))))        (integer (let ((x (ash 1 (random *maximum-random-int-bits*))))
1186                   (random-from-interval (1+ x) (- x))))                   (random-from-interval (1+ x) (- x))))
1187        ))))        ))))
# Line 1177  Line 1206 
1206  (defvar *compile-using-defun*  (defvar *compile-using-defun*
1207    #-(or allegro lispworks) nil    #-(or allegro lispworks) nil
1208    #+(or allegro lispworks) t)    #+(or allegro lispworks) t)
1209    
1210    (defvar *compile-using-defgeneric* nil
1211      "If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form
1212       for the function and compile that.")
1213    
1214  (defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1)  (defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1)
1215  (defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2)  (defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2)
1216    
# Line 1195  Line 1229 
1229              (cl:handler-bind              (cl:handler-bind
1230               (#+sbcl (sb-ext::compiler-note #'muffle-warning)               (#+sbcl (sb-ext::compiler-note #'muffle-warning)
1231                       (warning #'muffle-warning)                       (warning #'muffle-warning)
1232                       (error #'(lambda (c)                       ((or error serious-condition)
1233                          #'(lambda (c)
1234                                  (format t "Compilation failure~%~A~%"                                  (format t "Compilation failure~%~A~%"
1235                                          (format nil "~S" form))                                          (format nil "~S" form))
1236                                  (finish-output *standard-output*)                                  (finish-output *standard-output*)
# Line 1211  Line 1246 
1246                                                (with-output-to-string                                                (with-output-to-string
1247                                                  (s)                                                  (s)
1248                                                  (prin1 c s))))))))                                                  (prin1 c s))))))))
1249               (let ((start-time (get-universal-time)))               (let ((start-time (get-universal-time))
1250                       (clf (cdr lambda-form)))
1251                 (prog1                 (prog1
1252                     (if *compile-using-defun*                     (cond
1253                         (progn                      (*compile-using-defun*
1254                           (eval `(defun ,opt-defun-name                       (fmakunbound opt-defun-name)
1255                                    ,@(cdr lambda-form)))                       (eval `(defun ,opt-defun-name ,@clf))
1256                           (compile opt-defun-name)                       (compile opt-defun-name)
1257                           (symbol-function opt-defun-name))                       (symbol-function opt-defun-name))
1258                       (compile nil lambda-form))                      (*compile-using-defgeneric*
1259                         (fmakunbound opt-defun-name)
1260                         (eval `(defgeneric ,opt-defun-name ,(car clf)))
1261                         (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf))
1262                                  ,@(cdr clf)))
1263                         (compile opt-defun-name)
1264                         (symbol-function opt-defun-name))
1265                        (t (compile nil lambda-form)))
1266                   (let* ((stop-time (get-universal-time))                   (let* ((stop-time (get-universal-time))
1267                          (total-time (- stop-time start-time)))                          (total-time (- stop-time start-time)))
1268                     (when (> total-time *max-compile-time*)                     (when (> total-time *max-compile-time*)

Legend:
Removed from v.1.52  
changed lines
  Added in v.1.53

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