946 |
`(eval-when (load eval compile) |
`(eval-when (load eval compile) |
947 |
(ignore-errors |
(ignore-errors |
948 |
(defstruct ,@args)))) |
(defstruct ,@args)))) |
949 |
|
|
950 |
|
|
951 |
|
(defun sort-package-list (x) |
952 |
|
(sort (copy-list x) |
953 |
|
#'string< |
954 |
|
:key #'package-name)) |
955 |
|
|
956 |
|
(defun sort-symbols (sl) |
957 |
|
(sort (copy-list sl) |
958 |
|
#'(lambda (x y) |
959 |
|
(or |
960 |
|
(string< (symbol-name x) |
961 |
|
(symbol-name y)) |
962 |
|
(and (string= (symbol-name x) |
963 |
|
(symbol-name y)) |
964 |
|
(string< (package-name (symbol-package x)) |
965 |
|
(package-name (symbol-package y)))))))) |
966 |
|
|
967 |
|
(defun num-symbols-in-package (p) |
968 |
|
(let ((num 0)) |
969 |
|
(declare (fixnum num)) |
970 |
|
(do-symbols (s p num) |
971 |
|
(declare (ignore s)) |
972 |
|
(incf num)))) |
973 |
|
|
974 |
|
(defun num-external-symbols-in-package (p) |
975 |
|
(let ((num 0)) |
976 |
|
(declare (fixnum num)) |
977 |
|
(do-external-symbols (s p num) |
978 |
|
(declare (ignore s)) |
979 |
|
(incf num)))) |
980 |
|
|
981 |
|
(defun safely-delete-package (package-designator) |
982 |
|
(let ((package (find-package package-designator))) |
983 |
|
(when package |
984 |
|
(let ((used-by (package-used-by-list package))) |
985 |
|
(dolist (using-package used-by) |
986 |
|
(unuse-package package using-package))) |
987 |
|
(delete-package package)))) |
988 |
|
|
989 |
|
(defmacro test-with-package-iterator (package-list-expr &rest symbol-types) |
990 |
|
"Build an expression that tests the with-package-iterator form." |
991 |
|
(let ((name (gensym)) |
992 |
|
(cht-var (gensym)) |
993 |
|
(pkg-list-var (gensym))) |
994 |
|
`(let ((,cht-var (make-hash-table)) |
995 |
|
(,pkg-list-var ,package-list-expr) |
996 |
|
(fail-count 0)) |
997 |
|
(with-package-iterator (,name ,pkg-list-var |
998 |
|
,@(copy-list symbol-types)) |
999 |
|
;; For each symbol, check that name is returning appropriate |
1000 |
|
;; things |
1001 |
|
(loop |
1002 |
|
(block fail |
1003 |
|
(multiple-value-bind (more sym access pkg) |
1004 |
|
(,name) |
1005 |
|
(unless more (return nil)) |
1006 |
|
(setf (gethash sym ,cht-var) t) ;; note presence of symbol |
1007 |
|
;; Check that its access status is in the list, |
1008 |
|
;; that pkg is a package, |
1009 |
|
;; that the symbol is in the package, |
1010 |
|
;; and that (in the package) it has the correct access type |
1011 |
|
(unless (member access (quote ,(copy-list symbol-types))) |
1012 |
|
(unless (> fail-count +fail-count-limit+) |
1013 |
|
(format t "Bad access type: ~S ==> ~A~%" sym access)) |
1014 |
|
(when (= fail-count +fail-count-limit+) |
1015 |
|
(format t "Further messages suppressed~%")) |
1016 |
|
(incf fail-count) |
1017 |
|
(return-from fail nil)) |
1018 |
|
|
1019 |
|
(unless (packagep pkg) |
1020 |
|
(unless (> fail-count +fail-count-limit+) |
1021 |
|
(format t "Not a package: ~S ==> ~S~%" sym pkg)) |
1022 |
|
(when (= fail-count +fail-count-limit+) |
1023 |
|
(format t "Further messages suppressed~%")) |
1024 |
|
(incf fail-count) |
1025 |
|
(return-from fail nil)) |
1026 |
|
(multiple-value-bind (sym2 access2) |
1027 |
|
(find-symbol (symbol-name sym) pkg) |
1028 |
|
(unless (or (eqt sym sym2) |
1029 |
|
(member sym2 (PACKAGE-SHADOWING-SYMBOLS pkg))) |
1030 |
|
(unless (> fail-count +fail-count-limit+) |
1031 |
|
(format t "Not same symbol: ~S ~S~%" sym sym2)) |
1032 |
|
(when (= fail-count +fail-count-limit+) |
1033 |
|
(format t "Further messages suppressed~%")) |
1034 |
|
(incf fail-count) |
1035 |
|
(return-from fail nil)) |
1036 |
|
(unless (eqt access access2) |
1037 |
|
(unless (> fail-count +fail-count-limit+) |
1038 |
|
(format t "Not same access type: ~S ~S ~S~%" |
1039 |
|
sym access access2)) |
1040 |
|
(when (= fail-count +fail-count-limit+) |
1041 |
|
(format t "Further messages suppressed~%")) |
1042 |
|
(incf fail-count) |
1043 |
|
(return-from fail nil))))))) |
1044 |
|
;; now, check that each symbol in each package has |
1045 |
|
;; been properly found |
1046 |
|
(loop |
1047 |
|
for p in ,pkg-list-var do |
1048 |
|
(block fail |
1049 |
|
(do-symbols (sym p) |
1050 |
|
(multiple-value-bind (sym2 access) |
1051 |
|
(find-symbol (symbol-name sym) p) |
1052 |
|
(unless (eqt sym sym2) |
1053 |
|
(unless (> fail-count +fail-count-limit+) |
1054 |
|
(format t "Not same symbol (2): ~S ~S~%" |
1055 |
|
sym sym2)) |
1056 |
|
(when (= fail-count +fail-count-limit+) |
1057 |
|
(format t "Further messages suppressed~%")) |
1058 |
|
(incf fail-count) |
1059 |
|
(return-from fail nil)) |
1060 |
|
(unless (or (not (member access |
1061 |
|
(quote ,(copy-list symbol-types)))) |
1062 |
|
(gethash sym ,cht-var)) |
1063 |
|
(format t "Symbol not found: ~S~%" sym) |
1064 |
|
(incf fail-count) |
1065 |
|
(return-from fail nil)))))) |
1066 |
|
(or (zerop fail-count) fail-count)))) |
1067 |
|
|
1068 |
|
(defun with-package-iterator-internal (packages) |
1069 |
|
(test-with-package-iterator packages :internal)) |
1070 |
|
|
1071 |
|
(defun with-package-iterator-external (packages) |
1072 |
|
(test-with-package-iterator packages :external)) |
1073 |
|
|
1074 |
|
(defun with-package-iterator-inherited (packages) |
1075 |
|
(test-with-package-iterator packages :inherited)) |
1076 |
|
|
1077 |
|
(defun with-package-iterator-all (packages) |
1078 |
|
(test-with-package-iterator packages :internal :external :inherited)) |