/[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.18 by pfdietz, Tue Jan 14 11:36:13 2003 UTC revision 1.19 by pfdietz, Sat Jan 18 18:14:02 2003 UTC
# Line 946  the condition to go uncaught if it canno Line 946  the condition to go uncaught if it canno
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))

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.19

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