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 |
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) |