/[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.19 by pfdietz, Sat Oct 11 16:00:14 2003 UTC revision 1.20 by pfdietz, Sun Oct 19 14:41:38 2003 UTC
# Line 127  Line 127 
127                (y (- (random b) b2)))                (y (- (random b) b2)))
128            (list (min x y) (max x y)))))))            (list (min x y) (max x y)))))))
129    
130    (defun fn-arg-name (fn-name arg-index)
131      (intern (concatenate 'string
132                           (subseq (symbol-name fn-name) 1)
133                           (format nil "-~D" arg-index))
134              (symbol-package fn-name)))                  
135    
136  (defparameter *flet-names* nil)  (defparameter *flet-names* nil)
137    
138  (defun make-random-integer-form (size)  (defun make-random-integer-form (size)
# Line 137  Line 143 
143        (rcase        (rcase
144         (10 (let ((r (ash 1 (1+ (random 32)))))         (10 (let ((r (ash 1 (1+ (random 32)))))
145               (- (random r) (floor (/ r 2)))))               (- (random r) (floor (/ r 2)))))
146         (9 (var-desc-name (random-from-seq  *vars*)))         (9 (if *vars* (var-desc-name (random-from-seq  *vars*))
147         (1 (if *flet-names* (list (random-from-seq *flet-names*))              (make-random-integer-form size)))
148              (var-desc-name (random-from-seq *vars*)))))         (1 (if *flet-names*
149                  (let* ((flet-entry (random-from-seq *flet-names*))
150                         (flet-name (car flet-entry))
151                         (flet-nargs (cadr flet-entry))
152                         (args (loop repeat flet-nargs
153                                     collect (make-random-integer-form 1))))
154                    `(,flet-name ,@args))
155                (make-random-integer-form size))))
156      ;; (> size 1)      ;; (> size 1)
157      (rcase      (rcase
158         ;; flet call
159         (5
160          (if *flet-names*
161              (let* ((flet-entry (random-from-seq *flet-names*))
162                     (flet-name (car flet-entry))
163                     (flet-nargs (cadr flet-entry)))
164                (if (> flet-nargs 0)
165                    (let* ((arg-sizes (random-partition (1- size) flet-nargs))
166                           (args (mapcar #'make-random-integer-form arg-sizes)))
167                      `(,flet-name ,@args))
168                  (make-random-integer-form size)))
169            (make-random-integer-form size)))
170    
171       ;; Unary ops       ;; Unary ops
172       (40       (40
173        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor ignore-errors
174                                         handler-case restart-case
175                                       ceiling truncate round realpart imagpart                                       ceiling truncate round realpart imagpart
176                                       integer-length logcount values multiple-value-prog1                                       integer-length logcount values multiple-value-prog1
177                                       prog1 unwind-protect))))                                       prog1 unwind-protect locally))))
178          `(,op ,(make-random-integer-form (1- size)))))          `(,op ,(make-random-integer-form (1- size)))))
179        
180       (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))       (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))
181    
182         (2 `(the integer ,(make-random-integer-form (1- size))))
183         (1 `(handler-bind nil ,(make-random-integer-form (1- size))))
184         (1 `(macrolet () ,(make-random-integer-form (1- size))))
185    
186         ;; load-time-value
187         #-gcl
188         (4
189          (let ((arg (let ((*flet-names* nil)
190                           (*vars* nil)
191                           (*random-int-form-blocks* nil))
192                       (make-random-integer-form (1- size)))))
193            (rcase
194             (2 `(load-time-value ,arg t))
195             (1 `(load-time-value ,arg))
196             (1 `(load-time-value ,arg nil)))))          
197    
198         #-(or cmu allegro)
199       (2       (2
200        (destructuring-bind (s1 s2)        (destructuring-bind (s1 s2)
201            (random-partition (- size 2) 2)            (random-partition (- size 2) 2)
# Line 171  Line 216 
216                          ,(make-random-integer-form s2))))))                          ,(make-random-integer-form s2))))))
217                            
218       ;; Binary op       ;; Binary op
219       (60       (30
220        (let* ((op (random-from-seq        (let* ((op (random-from-seq
221                    '(+ - * * logand min max min max ;; gcd lcm                    '(+ - *  logand min max gcd ;; lcm
222                        ;; #-:allegro                        #-:allegro
223                        logandc1                        logandc1
224                        logandc2 logeqv logior lognand lognor                        logandc2 logeqv logior lognand lognor
225                        ;; #-:allegro                        #-:allegro
226                        logorc1                        logorc1
227                        logorc2 logxor))))                        logorc2
228                          #-:allegro
229                          logxor
230                          ))))
231          (destructuring-bind (leftsize rightsize)          (destructuring-bind (leftsize rightsize)
232              (random-partition (1- size) 2)              (random-partition (1- size) 2)
233            (let ((e1 (make-random-integer-form leftsize))            (let ((e1 (make-random-integer-form leftsize))
234                  (e2 (make-random-integer-form rightsize)))                  (e2 (make-random-integer-form rightsize)))
235              `(,op ,e1 ,e2)))))              `(,op ,e1 ,e2)))))
236    
237         ;; n-ary ops
238         (30
239          (let* ((op (random-from-seq #(+ - * logand min max logior
240                                          #-:allegro
241                                          logxor)))
242                 (nargs (1+ (random 8)))
243                 (sizes (random-partition (1- size) nargs))
244                 (args (mapcar #'make-random-integer-form sizes)))
245            `(,op ,@args)))
246        
247       ;; conditionals       ;; conditionals
248       (20       (20
249        (let* ((cond-size (random (max 1 (floor size 2))))        (let* ((cond-size (random (max 1 (floor size 2))))
# Line 200  Line 259 
259            ,(make-random-integer-form s1)            ,(make-random-integer-form s1)
260            ,(make-random-byte-spec-form s2)            ,(make-random-byte-spec-form s2)
261            ,(make-random-integer-form s3))))            ,(make-random-integer-form s3))))
262       ;; #-:allegro       #-:allegro
263       (10       (10
264        (destructuring-bind (s1 s2) (random-partition (1- size) 2)        (destructuring-bind (s1 s2) (random-partition (1- size) 2)
265            `(,(random-from-seq '(ldb mask-field))            `(,(random-from-seq '(ldb mask-field))
# Line 224  Line 283 
283               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))               (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
284          `(block ,name ,(make-random-integer-form (1- size)))))          `(block ,name ,(make-random-integer-form (1- size)))))
285       (4 ;; setq       (4 ;; setq
286        (let* ((vdesc (random-from-seq *vars*))        (if *vars*
287               (var (var-desc-name vdesc))            (let* ((vdesc (random-from-seq *vars*))
288               (type (var-desc-type vdesc)))                   (var (var-desc-name vdesc))
289          (cond                   (type (var-desc-type vdesc)))
290           ((equal type '(integer * *))              (cond
291            `(setq ,var ,(make-random-integer-form (1- size))))               ((equal type '(integer * *))
292           ((and (consp type)                `(setq ,var ,(make-random-integer-form (1- size))))
293                 (eq (car type) 'integer)               ((and (consp type)
294                 (integerp (second type))                     (eq (car type) 'integer)
295                 (integerp (third type)))                     (integerp (second type))
296            `(setq ,var ,(random-from-interval (1+ (third type)) (second type))))                     (integerp (third type)))
297           (t (make-random-integer-form size)))))                `(setq ,var ,(random-from-interval (1+ (third type)) (second type))))
298                 (t (make-random-integer-form size))))
299            (make-random-integer-form size)))
300    
301       (3 (make-random-integer-case-form size))       (3 (make-random-integer-case-form size))
302       (3       (3
# Line 291  Line 352 
352     and a single binding per form."     and a single binding per form."
353    (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10    (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10
354                                    %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))))                                    %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))))
355      (if (member fname *flet-names* :test #'eq)      (if (assoc fname *flet-names*)
356          (make-random-integer-form size)          (make-random-integer-form size)
357        (destructuring-bind (s1 s2) (random-partition (max 2 (1- size)) 2)        (destructuring-bind (s1 s2) (random-partition (max 2 (1- size)) 2)
358          (let ((op (random-from-seq #(flet labels)))          (let* ((op (random-from-seq #(flet labels)))
359                (form1                 (nargs (random 4))
360                 ;; Allow return-from of the flet/labels function                 (arg-names (loop for i from 1 to nargs
361                 (let ((*random-int-form-blocks*                                  collect (fn-arg-name fname i)))
362                        (cons fname *random-int-form-blocks*)))                 (form1
363                   (make-random-integer-form s1)))                  ;; Allow return-from of the flet/labels function
364                (form2 (let ((*flet-names* (cons fname *flet-names*)))                  (let ((*random-int-form-blocks*
365                         (make-random-integer-form s2))))                         (cons fname *random-int-form-blocks*))
366            `(,op ((,fname () ,form1)) ,form2))))))                        (*vars* (nconc (loop for var in arg-names
367                                               collect (make-var-desc :name var
368                                                                      :type '(integer * *)))
369                                         *vars*)))
370                      (make-random-integer-form s1)))
371                   (form2 (let ((*flet-names* (cons (list fname nargs)
372                                                    *flet-names*)))
373                            (make-random-integer-form s2))))
374              `(,op ((,fname ,arg-names ,form1)) ,form2))))))
375    
376  (defun make-random-pred-form (size)  (defun make-random-pred-form (size)
377    "Make a random form whose value is to be used as a generalized boolean."    "Make a random form whose value is to be used as a generalized boolean."
# Line 451  Line 520 
520       (declare (optimize (debug 0)))       (declare (optimize (debug 0)))
521       ,form))       ,form))
522    
523    (defvar *compile-using-defun* #-(or allegro lispworks) nil #+(or allegro lispworks) t)
524    (defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1)
525    (defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2)
526    
527  (defun test-int-form (form vars var-types vals-list)  (defun test-int-form (form vars var-types vals-list)
528    ;; Try to compile FORM with associated VARS, and if it compiles    ;; Try to compile FORM with associated VARS, and if it compiles
529    ;; check for equality of the two compiled forms.    ;; check for equality of the two compiled forms.
# Line 462  Line 535 
535            *optimized-fn-src* optimized-fn-src            *optimized-fn-src* optimized-fn-src
536            *unoptimized-fn-src* unoptimized-fn-src)            *unoptimized-fn-src* unoptimized-fn-src)
537      (flet ((%compile      (flet ((%compile
538              (lambda-form)              (lambda-form opt-defun-name)
539              (handler-bind              (handler-bind
540               (#+sbcl (sb-ext::compiler-note #'muffle-warning)               (#+sbcl (sb-ext::compiler-note #'muffle-warning)
541                       (warning #'muffle-warning)                       (warning #'muffle-warning)
# Line 479  Line 552 
552                                                  (*standard-output*)                                                  (*standard-output*)
553                                                  (let ((*print-escape* t))                                                  (let ((*print-escape* t))
554                                                    (prin1 c)))))))))                                                    (prin1 c)))))))))
555               (prog1 (compile nil lambda-form)               (prog1
556                     (if *compile-using-defun*
557                         (progn
558                           (eval `(defun ,opt-defun-name
559                                    ,@(cdr lambda-form)))
560                           (compile opt-defun-name)
561                           (symbol-function opt-defun-name))
562                       (compile nil lambda-form))
563                 #+:ecl (si:gc t)                 #+:ecl (si:gc t)
564                 ))))                 ))))
565        (let ((optimized-compiled-fn   (%compile optimized-fn-src))        (let ((optimized-compiled-fn (%compile optimized-fn-src
566                                                 *name-to-use-in-optimized-defun*))
567              (unoptimized-compiled-fn              (unoptimized-compiled-fn
568               (if *compile-unoptimized-form*               (if *compile-unoptimized-form*
569                   (%compile unoptimized-fn-src)                   (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*)
570                 (eval `(function ,unoptimized-fn-src)))))                 (eval `(function ,unoptimized-fn-src)))))
571          (declare (type function optimized-compiled-fn unoptimized-compiled-fn))          (declare (type function optimized-compiled-fn unoptimized-compiled-fn))
572          (dolist (vals vals-list)          (dolist (vals vals-list)
# Line 582  Line 663 
663            (try -1)            (try -1)
664            (prune-fn form try-fn))            (prune-fn form try-fn))
665                    
666           ((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect)           ((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect
667                   ignore-errors handler-case restart-case locally)
668              (mapc #'try args)
669              (prune-fn form try-fn))
670    
671             ((load-time-value)
672              (let ((arg (first args)))
673                (try arg)
674                (cond
675                 ((cdr args)
676                  (try `(load-time-value ,arg))
677                  (prune arg
678                         #'(lambda (form)
679                             (try `(load-time-value ,form ,(second args))))))
680                 (t
681                  (prune arg
682                         #'(lambda (form)
683                             (try `(load-time-value ,form))))))))
684    
685             ((the macrolet handler-bind)
686              (assert (= (length args) 2))
687              (try (second args))
688              (prune (second args)
689                     #'(lambda (form) (try `(the ,(first args) ,form)))))
690            
691             ((not eq eql equal)
692              (when (every #'constantp args)
693                (try (eval form)))
694            (mapc #'try args)            (mapc #'try args)
695            (prune-fn form try-fn))            (prune-fn form try-fn))
696                    
697           ((- + * min max logand logior logxor logeqv           ((- + * min max logand logior logxor logeqv
698               and or not eq eql equal = < > <= >= /=)               and or = < > <= >= /=)
699            (when (every #'constantp args)            (when (every #'constantp args)
700              (try (eval form)))              (try (eval form)))
701            (mapc #'try args)            (mapc #'try args)
702              (prune-nary-fn form try-fn)
703            (prune-fn form try-fn))            (prune-fn form try-fn))
704                    
705           ((if)           ((if)
# Line 792  Line 901 
901                    #'(lambda (cases)                    #'(lambda (cases)
902                        (try `(,op ,expr ,@cases)))))))                        (try `(,op ,expr ,@cases)))))))
903    
904    (defun prune-nary-fn (form try-fn)
905      ;; Attempt to reduce the number of arguments to the fn
906      ;; Do not reduce below 1
907      (let* ((op (car form))
908             (args (cdr form))
909             (nargs (length args)))
910        (when (> nargs 1)
911          (loop for i from 1 to nargs
912                do (funcall try-fn `(,op ,@(subseq args 0 (1- i))
913                                         ,@(subseq args i)))))))
914    
915  (defun prune-fn (form try-fn)  (defun prune-fn (form try-fn)
916    "Attempt to simplify a function call form.  It is considered    "Attempt to simplify a function call form.  It is considered
917     acceptable to replace the call by one of its argument forms."     acceptable to replace the call by one of its argument forms."
# Line 902  Line 1022 
1022               #'(lambda (form2)               #'(lambda (form2)
1023                   (funcall try-fn                   (funcall try-fn
1024                            `(,@(butlast form) ,form2)))))))                            `(,@(butlast form) ,form2)))))))
1025    
1026    ;;;;;;;;;;;;;;;;;;;;;;
1027    ;;; Convert pruned results to test cases
1028    
1029    (defun produce-test-cases (instances &key
1030                                         (stream *standard-output*)
1031                                         (prefix "MISC.")
1032                                         (index 1))
1033      (dolist (inst instances)
1034        (let* (;; (vars (getf inst :vars))
1035               (vals (getf inst :vals))
1036               (optimized-lambda-form (getf inst :optimized-lambda-form))
1037               (unoptimized-lambda-form (getf inst :unoptimized-lambda-form))
1038               (name (intern
1039                      (concatenate 'string prefix (format nil "~D" index))
1040                      "CL-TEST"))
1041               (test-form
1042                `(deftest ,name
1043                   (let* ((fn1 ',optimized-lambda-form)
1044                          (fn2 ',unoptimized-lambda-form)
1045                          (vals ',vals)
1046                          (v1 (apply (compile nil fn1) vals))
1047                          (v2 (apply (compile nil fn2) vals)))
1048                     (if (eql v1 v2)
1049                         :good
1050                       (list v1 v2)))
1051                   :good)))
1052          (print test-form stream)
1053          (terpri stream)
1054          (incf index)))
1055      (values))
1056    
1057                        
1058    
1059    
1060        
1061                    
1062      
1063                                        

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.20

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