Commit 33f928e4 authored by pfdietz's avatar pfdietz

Move package iterator auxiliary functions and macros to ansi-aux.lsp,

where they can be compiled.

Added SAFELY-DELETE-PACKAGE, which unlinks a package's users before
deleting it.  This was prompted by a bug in use-package.error.2.
Replace uses of delete-package or (ignore-errors (delete-package ...))
in the tests with calls to this new function.

Some comment and indentation fixes.
parent 644feb84
......@@ -946,3 +946,133 @@ the condition to go uncaught if it cannot be classified."
`(eval-when (load eval compile)
(ignore-errors
(defstruct ,@args))))
(defun sort-package-list (x)
(sort (copy-list x)
#'string<
:key #'package-name))
(defun sort-symbols (sl)
(sort (copy-list sl)
#'(lambda (x y)
(or
(string< (symbol-name x)
(symbol-name y))
(and (string= (symbol-name x)
(symbol-name y))
(string< (package-name (symbol-package x))
(package-name (symbol-package y))))))))
(defun num-symbols-in-package (p)
(let ((num 0))
(declare (fixnum num))
(do-symbols (s p num)
(declare (ignore s))
(incf num))))
(defun num-external-symbols-in-package (p)
(let ((num 0))
(declare (fixnum num))
(do-external-symbols (s p num)
(declare (ignore s))
(incf num))))
(defun safely-delete-package (package-designator)
(let ((package (find-package package-designator)))
(when package
(let ((used-by (package-used-by-list package)))
(dolist (using-package used-by)
(unuse-package package using-package)))
(delete-package package))))
(defmacro test-with-package-iterator (package-list-expr &rest symbol-types)
"Build an expression that tests the with-package-iterator form."
(let ((name (gensym))
(cht-var (gensym))
(pkg-list-var (gensym)))
`(let ((,cht-var (make-hash-table))
(,pkg-list-var ,package-list-expr)
(fail-count 0))
(with-package-iterator (,name ,pkg-list-var
,@(copy-list symbol-types))
;; For each symbol, check that name is returning appropriate
;; things
(loop
(block fail
(multiple-value-bind (more sym access pkg)
(,name)
(unless more (return nil))
(setf (gethash sym ,cht-var) t) ;; note presence of symbol
;; Check that its access status is in the list,
;; that pkg is a package,
;; that the symbol is in the package,
;; and that (in the package) it has the correct access type
(unless (member access (quote ,(copy-list symbol-types)))
(unless (> fail-count +fail-count-limit+)
(format t "Bad access type: ~S ==> ~A~%" sym access))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(unless (packagep pkg)
(unless (> fail-count +fail-count-limit+)
(format t "Not a package: ~S ==> ~S~%" sym pkg))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(multiple-value-bind (sym2 access2)
(find-symbol (symbol-name sym) pkg)
(unless (or (eqt sym sym2)
(member sym2 (PACKAGE-SHADOWING-SYMBOLS pkg)))
(unless (> fail-count +fail-count-limit+)
(format t "Not same symbol: ~S ~S~%" sym sym2))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(unless (eqt access access2)
(unless (> fail-count +fail-count-limit+)
(format t "Not same access type: ~S ~S ~S~%"
sym access access2))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil)))))))
;; now, check that each symbol in each package has
;; been properly found
(loop
for p in ,pkg-list-var do
(block fail
(do-symbols (sym p)
(multiple-value-bind (sym2 access)
(find-symbol (symbol-name sym) p)
(unless (eqt sym sym2)
(unless (> fail-count +fail-count-limit+)
(format t "Not same symbol (2): ~S ~S~%"
sym sym2))
(when (= fail-count +fail-count-limit+)
(format t "Further messages suppressed~%"))
(incf fail-count)
(return-from fail nil))
(unless (or (not (member access
(quote ,(copy-list symbol-types))))
(gethash sym ,cht-var))
(format t "Symbol not found: ~S~%" sym)
(incf fail-count)
(return-from fail nil))))))
(or (zerop fail-count) fail-count))))
(defun with-package-iterator-internal (packages)
(test-with-package-iterator packages :internal))
(defun with-package-iterator-external (packages)
(test-with-package-iterator packages :external))
(defun with-package-iterator-inherited (packages)
(test-with-package-iterator packages :inherited))
(defun with-package-iterator-all (packages)
(test-with-package-iterator packages :internal :external :inherited))
......@@ -37,33 +37,3 @@
(:use "DS1" "DS3")
(:intern "X" "Y" "Z")
(:import-from "DS2" "F"))9
(defun sort-package-list (x)
(sort (copy-list x)
#'string<
:key #'package-name))
(defun sort-symbols (sl)
(sort (copy-list sl)
#'(lambda (x y)
(or
(string< (symbol-name x)
(symbol-name y))
(and (string= (symbol-name x)
(symbol-name y))
(string< (package-name (symbol-package x))
(package-name (symbol-package y))))))))
(defun num-symbols-in-package (p)
(let ((num 0))
(declare (fixnum num))
(do-symbols (s p num)
(declare (ignore s))
(incf num))))
(defun num-external-symbols-in-package (p)
(let ((num 0))
(declare (fixnum num))
(do-external-symbols (s p num)
(declare (ignore s))
(incf num))))
......@@ -103,7 +103,7 @@
(pname1 (package-name p)))
(rename-package "TEMP1" "TEMP2")
(let ((pname2 (package-name p)))
(ignore-errors (delete-package p))
(safely-delete-package p)
(list pname1 pname2 (package-name p))))
("TEMP1" "TEMP2" nil))
......
......@@ -10,33 +10,37 @@
;;; intern
(deftest intern-1
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(find-symbol "FOO" p)
(intern "FOO" p)
(multiple-value-bind (sym2 status2)
(progn
(safely-delete-package "TEMP1")
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(find-symbol "FOO" p)
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t)))))
(intern "FOO" p)
(multiple-value-bind (sym2 status2)
(find-symbol "FOO" p)
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t))))))
t)
(deftest intern-2
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(find-symbol "FOO" "TEMP1")
(intern "FOO" "TEMP1")
(multiple-value-bind (sym2 status2)
(find-symbol "FOO" p)
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t)))))
(progn
(safely-delete-package "TEMP1")
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(find-symbol "FOO" "TEMP1")
(intern "FOO" "TEMP1")
(multiple-value-bind (sym2 status2)
(find-symbol "FOO" p)
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t))))))
t)
(deftest intern.error.1
......@@ -46,4 +50,3 @@
(deftest intern.error.2
(classify-error (intern "X" "CL" nil))
program-error)
......@@ -11,7 +11,7 @@
(deftest export-1
(let ((return-value nil))
(ignore-errors (delete-package "TEST1"))
(safely-delete-package "TEST1")
(let ((p (make-package "TEST1")))
(let ((sym (intern "FOO" p)))
(setf return-value (export sym p))
......@@ -28,30 +28,32 @@
t)
(deftest export-2
(progn (ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1")))
(let ((sym (intern "FOO" p)))
(export (list sym) p)
(multiple-value-bind (sym2 status)
(find-symbol "FOO" p)
(prog1
(and sym2
(eqt (symbol-package sym2) p)
(string= (symbol-name sym2) "FOO")
(eqt sym sym2)
(eqt status :external))
(delete-package p))))))
(progn
(safely-delete-package "TEST1")
(let ((p (make-package "TEST1")))
(let ((sym (intern "FOO" p)))
(export (list sym) p)
(multiple-value-bind (sym2 status)
(find-symbol "FOO" p)
(prog1
(and sym2
(eqt (symbol-package sym2) p)
(string= (symbol-name sym2) "FOO")
(eqt sym sym2)
(eqt status :external))
(delete-package p))))))
t)
(deftest export-3
(handler-case
(progn
(safely-delete-package "F")
(make-package "F")
(let ((sym (intern "FOO" "F")))
(export sym #\F)
(delete-package "F")
t))
(error (c) (delete-package "F") c))
(error (c) (safely-delete-package "F") c))
t)
;;
......@@ -73,6 +75,8 @@
;;
(deftest export-5
(progn
(safely-delete-package "TEST1")
(safely-delete-package "TEST2")
(make-package "TEST1")
(make-package "TEST2" :use '("TEST1"))
(export (intern "X" "TEST2") "TEST2")
......
......@@ -10,138 +10,149 @@
;;; rename-package
(deftest rename-package-1
(block nil
(ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1")))
(unless (packagep p) (return nil))
(let ((p2 (rename-package "TEST1" "TEST2")))
(unless (packagep p2)
(ignore-errors (delete-package p))
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2"))
(ignore-errors (delete-package p))
(ignore-errors (delete-package p2))
(return nil))
(ignore-errors (delete-package p2))
t)))
(block nil
(safely-delete-package "TEST1")
(safely-delete-package "TEST2")
(let ((p (make-package "TEST1")))
(unless (packagep p) (return nil))
(let ((p2 (rename-package "TEST1" "TEST2")))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2"))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t)))
t)
(deftest rename-package-2
(block nil
(ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1"))
(nicknames (copy-list '("TEST3" "TEST4" "TEST5"))))
(unless (packagep p) (return nil))
(let ((p2 (rename-package "TEST1" "TEST2" nicknames)))
(unless (packagep p2)
(ignore-errors (delete-package p))
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(null (set-exclusive-or nicknames
(package-nicknames p2)
:test #'equal)))
(ignore-errors (delete-package p))
(ignore-errors (delete-package p2))
(return nil))
(ignore-errors (delete-package p2))
t)))
(block nil
(safely-delete-package "TEST1")
(safely-delete-package "TEST2")
(safely-delete-package "TEST3")
(safely-delete-package "TEST4")
(safely-delete-package "TEST5")
(let ((p (make-package "TEST1"))
(nicknames (copy-list '("TEST3" "TEST4" "TEST5"))))
(unless (packagep p) (return nil))
(let ((p2 (rename-package "TEST1" "TEST2" nicknames)))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(null (set-exclusive-or nicknames
(package-nicknames p2)
:test #'equal)))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t)))
t)
(deftest rename-package-3
(block nil
(ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1"))
(nicknames (copy-list '(#\M #\N))))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames))))
(unless (packagep p2)
(ignore-errors (delete-package p))
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(equal
(sort (copy-list (package-nicknames p2))
#'string<)
(sort (mapcar #'(lambda (c)
(make-string 1 :initial-element c))
nicknames)
#'string<)))
(ignore-errors (delete-package p))
(ignore-errors (delete-package p2))
(return nil))
(ignore-errors (delete-package p2))
t)))
(block nil
(safely-delete-package "TEST1")
(safely-delete-package "TEST2")
(let ((p (make-package "TEST1"))
(nicknames (copy-list '(#\M #\N))))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames))))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(equal
(sort (copy-list (package-nicknames p2))
#'string<)
(sort (mapcar #'(lambda (c)
(make-string 1 :initial-element c))
nicknames)
#'string<)))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t)))
t)
(deftest rename-package-4
(block nil
(ignore-errors (delete-package "G"))
(let ((p (make-package "G"))
(nicknames nil))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames))))
(unless (packagep p2)
(ignore-errors (delete-package p))
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(null (set-exclusive-or nicknames
(package-nicknames p2)
:test #'equal)))
(ignore-errors (delete-package p))
(ignore-errors (delete-package p2))
(return nil))
(ignore-errors (delete-package p2))
t)))
(block nil
(safely-delete-package "G")
(safely-delete-package "TEST2")
(let ((p (make-package "G"))
(nicknames nil))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames))))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(null (set-exclusive-or nicknames
(package-nicknames p2)
:test #'equal)))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(ignore-errors (safely-delete-package p2))
t)))
t)
(deftest rename-package-5
(block nil
(ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1"))
(nicknames nil))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames))))
(unless (packagep p2)
(ignore-errors (delete-package p))
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "G")
(null (set-exclusive-or nicknames
(package-nicknames p2)
:test #'equal)))
(ignore-errors (delete-package p))
(ignore-errors (delete-package p2))
(return nil))
(ignore-errors (delete-package p2))
t)))
(block nil
(safely-delete-package "TEST1")
(safely-delete-package "G")
(let ((p (make-package "TEST1"))
(nicknames nil))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames))))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "G")
(null (set-exclusive-or nicknames
(package-nicknames p2)
:test #'equal)))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t)))
t)
(deftest rename-package-6
(block nil
(ignore-errors (delete-package '|TEST1|))
(let ((p (make-package '|TEST1|))
(nicknames (copy-list '(|M| |N|))))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package
'|TEST1| '|TEST2| nicknames))))
(unless (packagep p2)
(ignore-errors (delete-package p))
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(equal
(sort (copy-list (package-nicknames p2))
#'string<)
(sort (mapcar #'symbol-name nicknames)
#'string<)))
(ignore-errors (delete-package p))
(ignore-errors (delete-package p2))
(return nil))
(ignore-errors (delete-package p2))
t)))
(block nil
(safely-delete-package '|TEST1|)
(safely-delete-package '|TEST2|)
(safely-delete-package '|M|)
(safely-delete-package '|N|)
(let ((p (make-package '|TEST1|))
(nicknames (copy-list '(|M| |N|))))
(unless (packagep p) (return nil))
(let ((p2 (ignore-errors (rename-package
'|TEST1| '|TEST2| nicknames))))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) "TEST2")
(equal
(sort (copy-list (package-nicknames p2))
#'string<)
(sort (mapcar #'symbol-name nicknames)
#'string<)))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t)))
t)
(deftest rename-package.error.1
......
This diff is collapsed.
......@@ -11,116 +11,108 @@
;; check return value of delete-package, and check
;; that package-name is nil on the deleted package object
(deftest delete-package-1
(progn
(ignore-errors (delete-package :test1))
(let ((p (make-package :test1 :use nil)))
(list
(not (not (delete-package :test1)))
(not (not (packagep p)))
(package-name p))))
(progn
(safely-delete-package :test1)
(let ((p (make-package :test1 :use nil)))
(list
(notnot (delete-package :test1))
(notnot (packagep p))
(package-name p))))
(t t nil))
(deftest delete-package-2
(progn
(ignore-errors (delete-package :test1))
(let ((p (make-package :test1 :use nil)))
(list
(not (not (delete-package :test1)))
(not (not (packagep p)))
(delete-package p))))
(progn
(safely-delete-package :test1)
(let ((p (make-package :test1 :use nil)))
(list
(notnot (delete-package :test1))
(notnot (packagep p))
(delete-package p))))
(t t nil))
;; Check that deletion of different package designators works
(deftest delete-package-3
(progn
(ignore-errors (delete-package "X"))
(make-package "X")
(handler-case
(not (not (delete-package "X")))
(error (c) c)))
(progn
(safely-delete-package "X")
(make-package "X")
(handler-case
(notnot (delete-package "X"))
(error (c) c)))
t)
(deftest delete-package-4
(progn
(ignore-errors (delete-package "X"))
(make-package "X")
(handler-case
(not (not (delete-package #\X)))
(error (c) c)))
(progn
(safely-delete-package "X")
(make-package "X")
(handler-case
(notnot (delete-package #\X))
(error (c) c)))
t)
;; Paul Werkowski pointed out a problem in a previous
;; version of the next test. The problem is to catch
;; an error, check that it is the appropriate type,
;; check that it is continuable, and continue it.
;; The scheme here uses *debugger-hook*, but this
;; apparently doesn't work if the code is inside
;; a handler-case or ignore-errors form.
;;
;; The next test had the same problem.
;;; PFD 10/14/02 -- These tests are broken again. I suspect
;;; some sort of interaction with the test harness.
(deftest delete-package-5
(prog (P1 S1 P2 S2 P3)
(ignore-errors (delete-package "P3"))
(ignore-errors (delete-package "P2"))
(ignore-errors (delete-package "P1"))
(setq P1 (make-package "P1" :use ()))
(setq S1 (intern "S1" P1))
(export S1 "P1")
(setq P2 (make-package "P2" :use '("P1")))
(setq S2 (intern "S2" P2))
(export S1 P2)
(export S2 "P2")
(setf P3 (make-package "P3" :use '("P2")))
;; Delete the P2 package, catching the continuable
;; error and deleting the package
(handler-bind ((package-error
#'(lambda (c)
(let ((r (find-restart 'continue c)))
(and r (invoke-restart r))))))
(delete-package P2))
;;; PFD 01-18-03 This test is working, but suspicious.
(unless (and (equal (package-name P1) "P1")
(null (package-name P2))
(equal (package-name P3) "P3"))
(return 'fail1))
(unless (eqt (symbol-package S1) P1)
(return 'fail2))
(unless (equal (prin1-to-string S1) "P1:S1")
(return 'fail3))
(unless (equal (multiple-value-list (find-symbol "S1" P3))
'(nil nil))
(return 'fail4))
(unless (equal (multiple-value-list (find-symbol "S2" P3))
'(nil nil))
(return 'fail5))
(unless (and (null (package-used-by-list P1))
(null (package-used-by-list P3)))
(return 'fail6))
(unless (and (packagep P1)
(packagep P2)
(packagep P3)) (return 'fail7))
(unless (and (null (package-use-list P1))
(null (package-use-list P3)))
(return 'fail8))
(ignore-errors (delete-package P3))
(ignore-errors (delete-package P1))
(return t))
(deftest delete-package-5
(prog (P1 S1 P2 S2 P3)
(safely-delete-package "P3")
(safely-delete-package "P2")
(safely-delete-package "P1")
(setq P1 (make-package "P1" :use ()))
(setq S1 (intern "S1" P1))
(export S1 "P1")
(setq P2 (make-package "P2" :use '("P1")))
(setq S2 (intern "S2" P2))
(export S1 P2)
(export S2 "P2")
(setf P3 (make-package "P3" :use '("P2")))
;; Delete the P2 package, catching the continuable
;; error and deleting the package
(handler-bind ((package-error
#'(lambda (c)
(let ((r (find-restart 'continue c)))
(and r (invoke-restart r))))))
(delete-package P2))
(unless (and (equal (package-name P1) "P1")
(null (package-name P2))
(equal (package-name P3) "P3"))
(return 'fail1))
(unless (eqt (symbol-package S1) P1)
(return 'fail2))
(unless (equal (prin1-to-string S1) "P1:S1")
(return 'fail3))
(unless (equal (multiple-value-list (find-symbol "S1" P3))
'(nil nil))
(return 'fail4))
(unless (equal (multiple-value-list (find-symbol "S2" P3))
'(nil nil))
(return 'fail5))
(unless (and (null (package-used-by-list P1))
(null (package-used-by-list P3)))
(return 'fail6))
(unless (and (packagep P1)
(packagep P2)
(packagep P3)) (return 'fail7))
(unless (and (null (package-use-list P1))
(null (package-use-list P3)))
(return 'fail8))
(safely-delete-package P3)
(safely-delete-package P1)
(return t))
t)