/[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.9 by pfdietz, Mon Mar 14 13:00:20 2005 UTC revision 1.10 by pfdietz, Sat Mar 19 14:44:30 2005 UTC
# Line 19  Line 19 
19    
20  (defparameter *default-reps* 1000)  (defparameter *default-reps* 1000)
21  (defparameter *default-cell* nil)  (defparameter *default-cell* nil)
22    (defparameter *default-ignore* 'arithmetic-error)
23    (defparameter *default-arg-the* t)
24    
25    ;;;
26    ;;; The random type prop tester takes three required arguments:
27    ;;;
28    ;;;  operator  A lisp operator (either a symbol or a lambda form)
29    ;;;  arg-types A list consisting either of certain kinds of lisp types
30    ;;;            (that make-random-element-of-type understands) and/or
31    ;;;            functions that yield types.
32    ;;;  minargs   Minimum number of arguments to be given to the operator.
33    ;;;            Must be a positive integer <= maxargs.
34    ;;;
35    ;;; There are also keyword arguments, some with defaults given by special
36    ;;; variables.
37    ;;;
38    ;;; The random type prop tester generates between minargs and maxargs
39    ;;; (maxargs defaults to minargs) random arguments.  The type of each
40    ;;; argument is given by the corresponding type in arg-types (or by rest-type,
41    ;;; if there aren't enough elements of arg-types).  If the element of arg-types
42    ;;; is a function, the type for the parameter is produced by calling the function
43    ;;; with the previously generated actual parameters as its arguments.
44    ;;;
45    ;;; The list of parameters is stored into the special variable *params*.
46    ;;;
47    ;;; The tester evaluates (operator . arguments), and also builds a lambda
48    ;;; form to be compiled and called on (a subset of) the parameters.  The lambda
49    ;;; form is stored in the special variable *form*.
50    ;;;
51    ;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests
52    ;;; in a deftest form.  See random-type-prop-tests.lsp (and subfiles) for examples
53    ;;; of its use testing CL builtin operators.  To use it:
54    ;;;
55    ;;; (load "gclload1.lsp")
56    ;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles
57    ;;; (compile-and-load "random-type-prop.lsp")
58    ;;; (in-package :cl-test)
59    ;;; #+sbcl (setq *default-arg-the* nil)   ;; This reduces the rate at which the sbcl IR2 type check bug occurs
60    ;;; (let (*catch-errors*) (do-test '<testname>))
61    ;;; or (let (*catch-errors*) (do-tests))
62    ;;;
63    ;;; Running all the tests may take a while, particularly on lisps with slow compilers.
64    ;;;
65    ;;;
66    ;;; Keyword arguments to do-random-type-prop-tests:
67    ;;;
68    ;;;  Argument    Default         Meaning
69    ;;;
70    ;;;  maxargs     minargs         Maximum number of actual parameters to generate (max 20).
71    ;;;  rest-type   t               Type of arguments beyond those specified in arg-types
72    ;;;  reps        *default-reps*  Number of repetitions to try before stopping.
73    ;;;                              The default is controlled by a special variable that
74    ;;;                              is initially 1000.
75    ;;;  enclosing-the nil           If true, with prob 1/2 randomly generate an enclosing
76    ;;;                              (THE ...) form around the form invoking the operator.
77    ;;;  arg-the     *default-arg-the*   If true (which is the initial value of the default
78    ;;;                              special variable), with probability 1/2 randomly generate
79    ;;;                              a (THE ...) form around each actual parameter.
80    ;;;  cell        *default-cell*  If true (default is NIL), store the result into a rank-0
81    ;;;                              array of specialized type.  This enables one to test
82    ;;;                              forms where the result will be unboxed.  Otherwise, just
83    ;;;                              return the values.
84    ;;;  ignore      nil             Ignore conditions that are elements of IGNORE.  For example,
85    ;;;                              one might bind this to ARITHMETIC-ERROR if you want to
86    ;;;                              ignore possible floating errors (say).
87    ;;;  test        rt::equalp-with-case   The test function used to compare outputs.  It's
88    ;;;                              also handy to use #'approx= to handle approximate equality
89    ;;;                              when testing floating point computations, where compiled code
90    ;;;                              may have different roundoff errors.
91    ;;;  replicate   nil             Cause arguments to be copied (preserving sharing in conses
92    ;;;                              and arrays) before applying the operator.  This is used to test
93    ;;;                              destructive operators.
94    ;;;
95    ;;;
96                                
97  (defun do-random-type-prop-tests  (defun do-random-type-prop-tests
98    (operator arg-types minargs    (operator arg-types minargs
99              &key              &key
# Line 27  Line 101 
101              (rest-type t)              (rest-type t)
102              (reps *default-reps*)              (reps *default-reps*)
103              (enclosing-the nil)              (enclosing-the nil)
104                (arg-the *default-arg-the*)
105              (cell *default-cell*)              (cell *default-cell*)
106              (ignore nil)              (ignore *default-ignore*)
107              (test #'regression-test::equalp-with-case))              (test #'regression-test::equalp-with-case)
108                (replicate nil))
109    (assert (<= 1 minargs maxargs 20))    (assert (<= 1 minargs maxargs 20))
110  (prog1  (prog1
111    (dotimes (i reps)    (dotimes (i reps)
# Line 49  Line 125 
125            ; (vals (mapcar #'make-random-element-of-type types))            ; (vals (mapcar #'make-random-element-of-type types))
126            (vals (setq *params*            (vals (setq *params*
127                        (or (make-random-arguments types) (go again))))                        (or (make-random-arguments types) (go again))))
128              (vals (if replicate (mapcar #'replicate vals) vals))
129            (is-var? (loop repeat (length vals) collect (coin)))            (is-var? (loop repeat (length vals) collect (coin)))
130            (*is-var?* is-var?)            (*is-var?* is-var?)
131            (params (loop for x in is-var?            (params (loop for x in is-var?
# Line 64  Line 141 
141            (rval (cl:handler-bind            (rval (cl:handler-bind
142                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)                   (#+sbcl (sb-ext::compiler-note #'muffle-warning)
143                           (warning #'muffle-warning))                           (warning #'muffle-warning))
144                   (let ((eval-form (cons operator (loop for v in vals collect `(quote ,v)))))                   (let* ((vals (if replicate (mapcar #'replicate vals) vals))
145                            (eval-form (cons operator (loop for v in vals
146                                                            collect `(quote ,v)))))
147                     ;; (print eval-form) (terpri)                     ;; (print eval-form) (terpri)
148                     ;; (dotimes (i 100) (eval eval-form))                     ;; (dotimes (i 100) (eval eval-form))
149                     (eval eval-form))))                     (eval eval-form))))
# Line 75  Line 154 
154                                      for v in vals                                      for v in vals
155                                      for p in param-names                                      for p in param-names
156                                      collect (if x                                      collect (if x
157                                                  (rcase                                                  (if (and arg-the (coin))
158                                                   (1 (let ((tp (make-random-type-containing v)))                                                      (let ((tp (make-random-type-containing v)))
159                                                        `(the ,tp ,p)))                                                        `(the ,tp ,p))
160                                                   (1 p))                                                    p)
161                                                (if (or (consp v)                                                (if (or (consp v)
162                                                        (and (symbolp v) (not (or (keywordp v)                                                        (and (symbolp v) (not (or (keywordp v)
163                                                                                  (member v '(nil t))))))                                                                                  (member v '(nil t))))))
# Line 93  Line 172 
172            (upgraded-result-type (and store-into-cell?            (upgraded-result-type (and store-into-cell?
173                                       (upgraded-array-element-type `(eql ,rval))))                                       (upgraded-array-element-type `(eql ,rval))))
174            (form            (form
175             `(lambda (,@(when store-into-cell? '(r)) ,@params)             (setq *form*
176                (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space))                   `(lambda (,@(when store-into-cell? '(r)) ,@params)
177                         ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r)))                      (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space))
178                         ,@ type-decls)                               ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r)))
179                ,(let ((result-form                               ,@ type-decls)
180                        (if enclosing-the `(the ,result-type ,expr) expr)))                      ,(let ((result-form
181                   (if store-into-cell?                              (if enclosing-the `(the ,result-type ,expr) expr)))
182                       `(setf (aref r) ,result-form)                         (if store-into-cell?
183                     result-form))))                             `(setf (aref r) ,result-form)
184            (*form* form))                           result-form)))))
185              )
186       (when *print-random-type-prop-input*       (when *print-random-type-prop-input*
187         (let ((*print-pretty* t)         (let ((*print-pretty* t)
188               (*print-case* :downcase))               (*print-case* :downcase))
# Line 315  Line 395 
395              (cond              (cond
396               ((subtypep t1 t2) `(complex ,(upgraded-complex-part-type t2)))               ((subtypep t1 t2) `(complex ,(upgraded-complex-part-type t2)))
397               ((subtypep t2 t1) `(complex ,(upgraded-complex-part-type t1)))               ((subtypep t2 t1) `(complex ,(upgraded-complex-part-type t1)))
398                 ((and (subtypep t1 'rational)
399                       (subtypep t2 'rational))
400                  `(complex rational))
401               (t               (t
402                `(complex ,(upgraded-complex-part-type `(or ,t1 ,t2)))))))                `(complex ,(upgraded-complex-part-type `(or ,t1 ,t2)))))))
403     (1 `(eql ,val))))     (1 `(eql ,val))))
# Line 386  Line 469 
469      `(integer ,start2 ,d)))      `(integer ,start2 ,d)))
470    
471    
472    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
473    
474    (defgeneric replicate (obj)
475      (:documentation "Copies the structure of a lisp object recursively, preserving sharing."))
476    
477    (declaim (special *replicate-table*))
478    
479    (defmethod replicate :around ((obj t))
480      "Wrapper to create a hash table for structure sharing, if none exists."
481      (if (boundp '*replicate-table*)
482          (call-next-method obj)
483        (let ((*replicate-table* (make-hash-table)))
484          (call-next-method obj))))
485    
486    (defmethod replicate ((obj cons))
487      (or (gethash obj *replicate-table*)
488          (let ((x (cons nil nil)))
489            (setf (gethash obj *replicate-table*) x)
490            (setf (car x) (replicate (car obj)))
491            (setf (cdr x) (replicate (cdr obj)))
492            x)))
493    
494    ;;; Default method for objects without internal structure
495    (defmethod replicate ((obj t)) obj)
496    
497    (defmethod replicate ((obj array))
498      (multiple-value-bind
499          (new-obj old-leaf new-leaf)
500          (replicate-displaced-array obj)
501        (when new-leaf
502          (loop for i below (array-total-size new-leaf)
503                do (setf (row-major-aref new-leaf i)
504                         (row-major-aref old-leaf i))))
505        new-obj))
506    
507    (defun replicate-displaced-array (obj)
508      "Replicate the non-terminal (and not already replicated) arrays
509       in a displaced array chain.  Return the new root array, the
510       old leaf array, and the new (but empty) leaf array.  The latter
511       two are NIL if the leaf did not have to be copied again."
512      (or (gethash obj *replicate-table*)
513          (multiple-value-bind
514              (displaced-to displaced-index-offset)
515              (array-displacement obj)
516            (let ((dims (array-dimensions obj))
517                  (element-type (array-element-type obj))
518                  (fill-pointer (and (array-has-fill-pointer-p obj)
519                                     (fill-pointer obj)))
520                  (adj (adjustable-array-p obj)))
521              (if displaced-to
522                  ;; The array is displaced
523                  ;; Copy recursively
524                  (multiple-value-bind
525                      (new-displaced-to old-leaf new-leaf)
526                      (replicate-displaced-array displaced-to)
527                    (let ((new-obj (make-array dims :element-type element-type
528                                               :fill-pointer fill-pointer
529                                               :adjustable adj
530                                               :displaced-to new-displaced-to
531                                               :displaced-index-offset displaced-index-offset)))
532                      (setf (gethash obj *replicate-table*) new-obj)
533                      (values new-obj old-leaf new-leaf)))
534                ;; The array is not displaced
535                ;; This is the leaf array
536                (let ((new-obj (make-array dims :element-type element-type
537                                           :fill-pointer fill-pointer
538                                           :adjustable adj)))
539                  (setf (gethash obj *replicate-table*) new-obj)
540                  (values new-obj obj new-obj)))))))

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

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