/[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.22 by pfdietz, Mon Nov 10 00:25:13 2003 UTC revision 1.23 by pfdietz, Sun Nov 16 00:51:17 2003 UTC
# Line 55  Line 55 
55       (when x       (when x
56         (setq $x (append $x x))         (setq $x (append $x x))
57         (setq x (prune-results x))         (setq x (prune-results x))
58         (terpri) (print x)         (terpri) (print x) (finish-output *standard-output*)
59         (setq $y (append $y x)))         (setq $y (append $y x)))
60       (terpri))))       (terpri))))
61    
# Line 94  Line 94 
94        
95    (loop for i from 1 to n    (loop for i from 1 to n
96          do (when (= (mod i 100) 0)          do (when (= (mod i 100) 0)
97               #+sbcl (sb-ext::gc)               #+sbcl (sb-ext::gc :full t)
98               (prin1 i) (princ " ") (finish-output *standard-output*))               (prin1 i) (princ " ") (finish-output *standard-output*))
99          nconc (let ((result (test-random-integer-form size nvars)))          nconc (let ((result (test-random-integer-form size nvars)))
100                  (when result                  (when result
# Line 177  Line 177 
177        
178    (if (<= size 1)    (if (<= size 1)
179        ;; Leaf node -- generate a variable, constant, or flet function call        ;; Leaf node -- generate a variable, constant, or flet function call
180        (rcase        (loop
181         (10 (make-random-integer))         when
182         (9 (if *vars* (var-desc-name (random-from-seq  *vars*))         (rcase
183              (make-random-integer-form size)))          (10 (make-random-integer))
184         (1 (if *flet-names*          (9 (if *vars* (var-desc-name (random-from-seq  *vars*))
185                (let* ((flet-entry (random-from-seq *flet-names*))               nil))
186                       (flet-name (car flet-entry))          (2 (if *flet-names*
187                       (flet-minargs (cadr flet-entry))                 (let* ((flet-entry (random-from-seq *flet-names*))
188                       (flet-maxargs (caddr flet-entry))                        (flet-name (car flet-entry))
189                       (nargs (random-from-interval (1+ flet-maxargs) flet-minargs))                        (flet-minargs (cadr flet-entry))
190                       (args (loop repeat nargs                        (flet-maxargs (caddr flet-entry))
191                                   collect (make-random-integer-form 1))))                        (nargs (random-from-interval (1+ flet-maxargs) flet-minargs))
192                  `(,flet-name ,@args))                        (args (loop repeat nargs
193              (make-random-integer-form size))))                                    collect (make-random-integer-form 1))))
194                     `(,flet-name ,@args))
195                 nil)))
196           return it)
197      ;; (> size 1)      ;; (> size 1)
198      (rcase      (rcase
199       ;; flet call       ;; flet call
200       (5       (30 ;; 5
201        (if *flet-names*        (if *flet-names*
202            (let* ((flet-entry (random-from-seq *flet-names*))            (let* ((flet-entry (random-from-seq *flet-names*))
203                   (flet-name (car flet-entry))                   (flet-name (car flet-entry))
# Line 208  Line 211 
211                       (args (mapcar #'make-random-integer-form arg-sizes)))                       (args (mapcar #'make-random-integer-form arg-sizes)))
212                  (rcase                  (rcase
213                   (1 `(,flet-name ,@args))                   (1 `(,flet-name ,@args))
214                   (1 `(multiple-value-call #',flet-name (values ,@args))))))                   (1 `(multiple-value-call #',flet-name (values ,@args)))
215                     (1 `(funcall (function ,flet-name) ,@args))
216                     (1 (let ((r (random (1+ (length args)))))
217                          `(apply (function ,flet-name)
218                                  ,@(subseq args 0 r)
219                                  (list ,@(subseq args r))))))))
220               (t (make-random-integer-form size))))               (t (make-random-integer-form size))))
221          (make-random-integer-form size)))          (make-random-integer-form size)))
222    
# Line 367  Line 375 
375          ;; No blocks -- try again          ;; No blocks -- try again
376          (make-random-integer-form size)))          (make-random-integer-form size)))
377    
378       (10 (make-random-flet-form size))       (50 ;; 10
379          (make-random-flet-form size))
380                                    
381       )))       )))
382    
# Line 616  Line 625 
625                       (error #'(lambda (c)                       (error #'(lambda (c)
626                                  (format t "Compilation failure~%")                                  (format t "Compilation failure~%")
627                                  (print form)                                  (print form)
628                                    (finish-output *standard-output*)
629                                  (return-from test-int-form                                  (return-from test-int-form
630                                    (list (list :vars vars                                    (list (list :vars vars
631                                                :form form                                                :form form
# Line 655  Line 665 
665            (flet ((%eval-error            (flet ((%eval-error
666                    (kind)                    (kind)
667                    (print form)                    (print form)
668                      (finish-output *standard-output*)
669                    (return                    (return
670                     (list (list :vars vars                     (list (list :vars vars
671                                 :vals vals                                 :vals vals
# Line 689  Line 700 
700    
701  ;;; Interface to the form pruner  ;;; Interface to the form pruner
702    
703  (defun prune-int-form (form vars var-types vals-list)  (declaim (special *prune-table*))
704    "Conduct tests on selected simplified versions of FORM.  Return the  
705    (defun prune-int-form (input-form vars var-types vals-list)
706      "Conduct tests on selected simplified versions of INPUT-FORM.  Return the
707     minimal form that still causes some kind of failure."     minimal form that still causes some kind of failure."
708    (flet ((%try-fn (new-form)    (loop do
709                    (when (test-int-form new-form vars var-types vals-list)          (let ((form input-form))
710                      (setf form new-form)            (flet ((%try-fn (new-form)
711                      (throw 'success nil))))                            (when (test-int-form new-form vars var-types vals-list)
712      (loop                              (setf form new-form)
713       (catch 'success                              (throw 'success nil))))
714         (prune form #'%try-fn)              (let ((*prune-table* (make-hash-table :test #'eq)))
715         (return form)))))                (loop
716                   (catch 'success
717                     (prune form #'%try-fn)
718                     (return form)))))
719              (when (equal form input-form) (return form))
720              (setq input-form form))))
721    
722  (defun prune-results (result-list)  (defun prune-results (result-list)
723    "Given a list of test results, prune their forms down to a minimal set."    "Given a list of test results, prune their forms down to a minimal set."
# Line 731  Line 749 
749  ;;;  ;;;
750  (defun prune (form try-fn)  (defun prune (form try-fn)
751    (declare (type function try-fn))    (declare (type function try-fn))
752      (when (gethash form *prune-table*)
753        (return-from prune nil))
754    (flet ((try (x) (funcall try-fn x)))    (flet ((try (x) (funcall try-fn x)))
755      (when (consp form)      (when (consp form)
756        (let* ((op (car form))        (let* ((op (car form))
# Line 748  Line 768 
768                    
769           ((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect           ((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect
770                 ignore-errors cl:handler-case restart-case locally)                 ignore-errors cl:handler-case restart-case locally)
771            (mapc #'try args)            (mapc try-fn args)
772            (prune-fn form try-fn))            (prune-fn form try-fn))
773    
774           ((typep)           ((typep)
# Line 773  Line 793 
793           ((the macrolet cl:handler-bind)           ((the macrolet cl:handler-bind)
794            (assert (= (length args) 2))            (assert (= (length args) 2))
795            (try (second args))            (try (second args))
796            (prune (second args) #'try))            (prune (second args) try-fn))
797                    
798           ((not eq eql equal)           ((not eq eql equal)
799            (when (every #'constantp args)            (when (every #'constantp args)
800              (try (eval form)))              (try (eval form)))
801            (mapc #'try args)            (mapc try-fn args)
802            (prune-fn form try-fn))            (prune-fn form try-fn))
803                    
804           ((- + * min max logand logior logxor logeqv           ((- + * min max logand logior logxor logeqv
805               and or = < > <= >= /=)               and or = < > <= >= /=)
806            (when (every #'constantp args)            (when (every #'constantp args)
807              (try (eval form)))              (try (eval form)))
808            (mapc #'try args)            (mapc try-fn args)
809            (prune-nary-fn form try-fn)            (prune-nary-fn form try-fn)
810            (prune-fn form try-fn))            (prune-fn form try-fn))
811    
# Line 796  Line 816 
816                (when (and (consp arg1) (consp arg2)                (when (and (consp arg1) (consp arg2)
817                           (eql (first arg1) 'function)                           (eql (first arg1) 'function)
818                           (eql (first arg2) 'values))                           (eql (first arg2) 'values))
819                  (mapc #'try (rest arg2))                  (mapc try-fn (rest arg2))
820                  (let ((fn (second arg1)))                  (let ((fn (second arg1)))
821                    (when (symbolp fn)                    (when (symbolp fn)
822                      (try `(,fn ,@(rest arg2)))))                      (try `(,fn ,@(rest arg2)))))
# Line 806  Line 826 
826                              #'(lambda (args)                              #'(lambda (args)
827                                  (try `(multiple-value-call ,arg1 (values ,@args)))))                                  (try `(multiple-value-call ,arg1 (values ,@args)))))
828                  )))                  )))
829            (mapc #'try (rest args)))            (mapc try-fn (rest args)))
830            
831           ((if)           ((if)
832            (let (;; (pred (first args))            (let (;; (pred (first args))
833                  (then (second args))                  (then (second args))
# Line 956  Line 976 
976                             (try                             (try
977                              `(,op ,form1 (,(first form2) ,(second form2)                              `(,op ,form1 (,(first form2) ,(second form2)
978                                            ,form)))))))))                                            ,form)))))))))
979    
980             ((funcall)
981              (let ((fn (second form))
982                    (fn-args (cddr form)))
983                (mapc try-fn fn-args)
984                (when (and (consp fn)
985                           (eql (car fn) 'function)
986                           (symbolp (cadr fn)))
987                  (try `(,(cadr fn) ,@fn-args)))
988                (prune-list fn-args
989                            #'prune
990                            #'(lambda (args)
991                                (funcall try-fn `(funcall ,fn ,@args))))))
992    
993             ((apply)
994              (let ((fn (second form))
995                    (fn-args (butlast (cddr form)))
996                    (list-arg (car (last form))))
997                (mapc try-fn fn-args)
998                (when (and (consp list-arg)
999                           (eq (car list-arg) 'list))
1000                  (mapc try-fn (cdr list-arg)))
1001                (prune-list fn-args
1002                            #'prune
1003                            #'(lambda (args)
1004                                (funcall try-fn `(apply ,fn ,@args ,list-arg))))
1005                (when (and (consp list-arg)
1006                           (eq (car list-arg) 'list))
1007                  (prune-list (cdr list-arg)
1008                            #'prune
1009                            #'(lambda (args)
1010                                (funcall try-fn `(apply ,fn ,@fn-args
1011                                                        (list ,@args))))))))
1012                    
1013           (otherwise           (otherwise
1014            (prune-fn form try-fn))            (prune-fn form try-fn))
1015           )))))           ))))
1016      (setf (gethash form *prune-table*) t)
1017      nil)
1018    
1019  (defun find-in-tree (value tree)  (defun find-in-tree (value tree)
1020    "Return true if VALUE is eql to a node in TREE."    "Return true if VALUE is eql to a node in TREE."
# Line 1076  Line 1131 
1131                   (not (rest body)))                   (not (rest body)))
1132          (let ((binding (first binding-list)))          (let ((binding (first binding-list)))
1133            (unless (or (consp (second binding))            (unless (or (consp (second binding))
1134                          (has-binding-to-var (first binding) body)
1135                        (has-assignment-to-var (first binding) body))                        (has-assignment-to-var (first binding) body))
1136              (funcall try-fn `(let ()              (funcall try-fn `(let ()
1137                                 ,@(subst (second binding)                                 ,@(subst (second binding)
# Line 1086  Line 1142 
1142                            `(,@(butlast form) ,form2)))))))                            `(,@(butlast form) ,form2)))))))
1143    
1144  (defun has-assignment-to-var (var form)  (defun has-assignment-to-var (var form)
1145    (when (consp form)    (find-if-subtree
1146      (or (and (member (car form) '(setq setf))     #'(lambda (form)
1147               (eq (cadr form) var))         (and (consp form)
1148          (loop for subform in form              (member (car form) '(setq setf) :test #'eq)
1149                thereis (has-assignment-to-var var subform)))))                    (eq (cadr form) var)))
1150       form))
1151    
1152    (defun has-binding-to-var (var form)
1153      (find-if-subtree
1154       #'(lambda (form)
1155           (and (consp form)
1156                (member (car form) '(let let*) :test #'eq)
1157                (loop for binding in (cadr form)
1158                      thereis (eq (car binding) var))))
1159       form))
1160    
1161    (defun find-if-subtree (pred tree)
1162      (declare (type function pred))
1163      (cond
1164       ((funcall pred tree) tree)
1165       ((consp tree)
1166        (or (find-if-subtree pred (car tree))
1167            (find-if-subtree pred (cdr tree))))
1168       (t nil)))
1169    
1170  (defun prune-flet (form try-fn)  (defun prune-flet (form try-fn)
1171    "Attempt to simplify a FLET form."    "Attempt to simplify a FLET form."

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.23

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