/[gcl]/gcl/ansi-tests/ansi-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/ansi-aux.lsp

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

revision 1.22 by pfdietz, Wed Jan 22 14:00:37 2003 UTC revision 1.23 by pfdietz, Thu Jan 23 04:11:59 2003 UTC
# Line 71  Line 71 
71  ;;; lisp objects used when stimulating things in various tests.  ;;; lisp objects used when stimulating things in various tests.
72  (declaim (special *universe*))  (declaim (special *universe*))
73    
74    ;;; The function EMPIRICAL-SUBTYPEP checks two types
75    ;;; for subtypeness, first using SUBTYPEP*, then (if that
76    ;;; fails) empirically against all the elements of *universe*,
77    ;;; checking if all that are in the first are also in the second.
78    ;;; Return T if this is the case, NIL otherwise.  This will
79    ;;; always return T if type1 is truly a subtype of type2,
80    ;;; but may return T even if this is not the case.
81    
82    (defun empirical-subtypep (type1 type2)
83      (multiple-value-bind (sub good)
84          (subtypep* type1 type2)
85        (if good
86            sub
87          (loop for e in *universe*
88                always (or (not (typep e type1)) (typep e type2))))))
89    
90  (defun check-type-predicate (P TYPE)  (defun check-type-predicate (P TYPE)
91    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))    "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
92     by applying both to all elements of *UNIVERSE*.  Print message     by applying both to all elements of *UNIVERSE*.  Print message
# Line 973  the condition to go uncaught if it canno Line 989  the condition to go uncaught if it canno
989    (let ((num 0))    (let ((num 0))
990      (declare (fixnum num))      (declare (fixnum num))
991      (do-symbols (s p num)      (do-symbols (s p num)
992        (declare (ignore s))        s
993        (incf num))))        (incf num))))
994    
995  (defun num-external-symbols-in-package (p)  (defun num-external-symbols-in-package (p)
996    (let ((num 0))    (let ((num 0))
997      (declare (fixnum num))      (declare (fixnum num))
998      (do-external-symbols (s p num)      (do-external-symbols (s p num)
999        (declare (ignore s))        s
1000        (incf num))))        (incf num))))
1001    
1002  (defun safely-delete-package (package-designator)  (defun safely-delete-package (package-designator)

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