/[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.11 by pfdietz, Sat Mar 19 14:53:11 2005 UTC revision 1.12 by pfdietz, Sat Apr 23 14:17:20 2005 UTC
# Line 5  Line 5 
5    
6  (in-package :cl-test)  (in-package :cl-test)
7    
8  (eval-when (load eval compile)  (eval-when (:compile-toplevel :load-toplevel :execute)
9    (compile-and-load "random-int-form.lsp"))    (compile-and-load "random-int-form.lsp"))
10    
11  (defvar *print-random-type-prop-input* nil)  (defvar *print-random-type-prop-input* nil)
# Line 56  Line 56 
56  ;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles  ;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles
57  ;;; (compile-and-load "random-type-prop.lsp")  ;;; (compile-and-load "random-type-prop.lsp")
58  ;;; (in-package :cl-test)  ;;; (in-package :cl-test)
 ;;; #+sbcl (setq *default-arg-the* nil)   ;; This reduces the rate at which the sbcl IR2 type check bug occurs  
59  ;;; (load "random-type-prop-tests.lsp")  ;;; (load "random-type-prop-tests.lsp")
60  ;;; (let (*catch-errors*) (do-test '<testname>))  ;;; (let (*catch-errors*) (do-test '<testname>))
61  ;;; or (let (*catch-errors*) (do-tests))  ;;; or (let (*catch-errors*) (do-tests))
# Line 82  Line 81 
81  ;;;                              array of specialized type.  This enables one to test  ;;;                              array of specialized type.  This enables one to test
82  ;;;                              forms where the result will be unboxed.  Otherwise, just  ;;;                              forms where the result will be unboxed.  Otherwise, just
83  ;;;                              return the values.  ;;;                              return the values.
84  ;;;  ignore      nil             Ignore conditions that are elements of IGNORE.  For example,  ;;;  ignore      *default-ignore*  Ignore conditions that are elements of IGNORE.  Default is
85  ;;;                              one might bind this to ARITHMETIC-ERROR if you want to  ;;;                              ARITHMETIC-ERROR.
 ;;;                              ignore possible floating errors (say).  
86  ;;;  test        rt::equalp-with-case   The test function used to compare outputs.  It's  ;;;  test        rt::equalp-with-case   The test function used to compare outputs.  It's
87  ;;;                              also handy to use #'approx= to handle approximate equality  ;;;                              also handy to use #'approx= to handle approximate equality
88  ;;;                              when testing floating point computations, where compiled code  ;;;                              when testing floating point computations, where compiled code
# Line 126  Line 124 
124            ; (vals (mapcar #'make-random-element-of-type types))            ; (vals (mapcar #'make-random-element-of-type types))
125            (vals (setq *params*            (vals (setq *params*
126                        (or (make-random-arguments types) (go again))))                        (or (make-random-arguments types) (go again))))
127            (vals (if replicate (mapcar #'replicate vals) vals))            (vals
128            (is-var? (loop repeat (length vals) collect (coin)))             (if replicate
129                   (mapcar #'replicate vals)
130                 vals))
131              (is-var? (if (consp replicate)
132                           (progn
133                             (assert (= (length replicate) (length vals)))
134                             (loop for x in replicate collect (or x (coin))))
135                         (loop repeat (length vals) collect (coin))))
136            (*is-var?* is-var?)            (*is-var?* is-var?)
137            (params (loop for x in is-var?            (params (loop for x in is-var?
138                          for p in param-names                          for p in param-names
# Line 360  Line 365 
365       (1 `(,root ,etype))       (1 `(,root ,etype))
366       (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i))))       (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i))))
367       (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i))))       (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i))))
368       (1 `(,root ,etype ,rank)))))       #-ecl (1 `(,root ,etype ,rank))
369         )))
370    
371  (defmethod make-random-type-containing ((val string))  (defmethod make-random-type-containing ((val string))
372    (rcase    (rcase
# Line 391  Line 397 
397     (1 'complex)     (1 'complex)
398     (1 'number)     (1 'number)
399     #-gcl (1     #-gcl (1
400            (let ((t1 (type-of (realpart val)))            (let* ((t1 (type-of (realpart val)))
401                  (t2 (type-of (imagpart val))))                   (t2 (type-of (imagpart val)))
402              (cond                   (part-type
403               ((subtypep t1 t2) `(complex ,(upgraded-complex-part-type t2)))                    (cond
404               ((subtypep t2 t1) `(complex ,(upgraded-complex-part-type t1)))                     ((subtypep t1 t2) (upgraded-complex-part-type t2))
405               ((and (subtypep t1 'rational)                     ((subtypep t2 t1) (upgraded-complex-part-type t1))
406                     (subtypep t2 'rational))                     ((and (subtypep t1 'rational)
407                `(complex rational))                           (subtypep t2 'rational))
408               (t                      'rational)
409                `(complex ,(upgraded-complex-part-type `(or ,t1 ,t2)))))))                     (t
410                        (upgraded-complex-part-type `(or ,t1 ,t2))))))
411                (if (subtypep 'real part-type)
412                    '(complex real)
413                  `(complex ,part-type))))
414     (1 `(eql ,val))))     (1 `(eql ,val))))
415    
416  (defmethod make-random-type-containing ((val generic-function))  (defmethod make-random-type-containing ((val generic-function))
# Line 433  Line 443 
443            do (setq result `(cons ,element-type ,result)))            do (setq result `(cons ,element-type ,result)))
444      result))      result))
445    
446    (defun make-sequence-type (length &optional (element-type t))
447      (rcase
448       (1 `(vector ,element-type ,length))
449       (1 (make-list-type length 'null element-type))))
450    
451    (defun make-random-sequence-type-containing (element)
452      (make-sequence-type (random 10) (make-random-type-containing element)))
453    
454  (defun same-set-p (set1 set2 &rest args &key key test test-not)  (defun same-set-p (set1 set2 &rest args &key key test test-not)
455    (declare (ignorable key test test-not))    (declare (ignorable key test test-not))
456    (and (apply #'subsetp set1 set2 args)    (and (apply #'subsetp set1 set2 args)
# Line 539  Line 557 
557                                         :adjustable adj)))                                         :adjustable adj)))
558                (setf (gethash obj *replicate-table*) new-obj)                (setf (gethash obj *replicate-table*) new-obj)
559                (values new-obj obj new-obj)))))))                (values new-obj obj new-obj)))))))
560    
561    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
562    
563    (declaim (special *isomorphism-table*))
564    
565    (defun isomorphic-p (obj1 obj2)
566      (let ((*isomorphism-table* (make-hash-table)))
567        (isomorphic-p* obj1 obj2)))
568    
569    (defgeneric isomorphic-p* (obj1 obj2)
570      (:documentation
571       "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure,
572        including the same leaf values and the same pattern of sharing).  It should be
573        the case that (isomorphic-p obj (replicate obj)) is true."))
574    
575    (defmethod isomorphic-p* ((obj1 t) (obj2 t))
576      (eql obj1 obj2))
577    
578    (defmethod isomorphic-p* ((obj1 cons) (obj2 cons))
579      (let ((previous (gethash obj1 *isomorphism-table*)))
580        (cond
581         (previous
582          ;; If we've already produced a mapping from obj1 to something,
583          ;; isomorphism requires that obj2 be that object
584          (eq previous obj2))
585         ;; Otherwise, assume obj1 will map to obj2 and recurse
586         (t
587          (setf (gethash obj1  *isomorphism-table*) obj2)
588          (and (isomorphic-p* (car obj1) (car obj2))
589               (isomorphic-p* (cdr obj1) (cdr obj2)))))))
590    
591    (defmethod isomorphic-p* ((obj1 array) (obj2 array))
592      (let ((previous (gethash obj1 *isomorphism-table*)))
593        (cond
594         (previous
595          ;; If we've already produced a mapping from obj1 to something,
596          ;; isomorphism requires that obj2 be that object
597          (eq previous obj2))
598         (t
599          (setf (gethash obj1 *isomorphism-table*) obj2)
600          (and (equal (array-dimensions obj1) (array-dimensions obj2))
601               (equal (array-element-type obj1) (array-element-type obj2))
602               (if (array-has-fill-pointer-p obj1)
603                   (and (array-has-fill-pointer-p obj2)
604                        (eql (fill-pointer obj1) (fill-pointer obj2)))
605                 (not (array-has-fill-pointer-p obj2)))
606               (let (to-1 (index-1 0) to-2 (index-2 0))
607                 (multiple-value-setq (to-1 index-1) (array-displacement obj1))
608                 (multiple-value-setq (to-2 index-2) (array-displacement obj2))
609                 (if to-1
610                     (and to-2
611                          (eql index-1 index-2)
612                          (isomorphic-p* to-1 to-2))
613                   ;; Not displaced -- recurse on elements
614                   (let ((total-size (array-total-size obj1)))
615                     (loop for i below total-size
616                           always (isomorphic-p* (row-major-aref obj1 i)
617                                                 (row-major-aref obj2 i)))))))))))
618    
619    

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

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