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
......
......@@ -10,214 +10,214 @@
;;; shadow
(deftest shadow-1
(prog1
(progn
(ignore-errors (delete-package "TEST5"))
(ignore-errors (delete-package "TEST4"))
(handler-case
(let* ((p1 (prog1
(make-package "TEST4")
(export (intern "A" "TEST4") "TEST4")))
(p2 (make-package "TEST5" :use '("TEST4")))
(r1 (package-shadowing-symbols "TEST4"))
(r2 (package-shadowing-symbols "TEST5")))
(multiple-value-bind (s1 kind1)
(find-symbol "A" p1)
(multiple-value-bind (s2 kind2)
(find-symbol "A" p2)
(let ((r3 (shadow "A" p2)))
(multiple-value-bind (s3 kind3)
(find-symbol "A" p2)
(list
(package-name p1)
(package-name p2)
r1 r2
(symbol-name s1)
(package-name (symbol-package s1))
kind1
(symbol-name s2)
(package-name (symbol-package s2))
kind2
r3
(symbol-name s3)
(package-name (symbol-package s3))
kind3))))))
(error (c) c)))
(ignore-errors (delete-package "TEST5"))
(ignore-errors (delete-package "TEST4")))
(prog1
(progn
(safely-delete-package "TEST5")
(safely-delete-package "TEST4")
(handler-case
(let* ((p1 (prog1
(make-package "TEST4")
(export (intern "A" "TEST4") "TEST4")))
(p2 (make-package "TEST5" :use '("TEST4")))
(r1 (package-shadowing-symbols "TEST4"))
(r2 (package-shadowing-symbols "TEST5")))
(multiple-value-bind (s1 kind1)
(find-symbol "A" p1)
(multiple-value-bind (s2 kind2)
(find-symbol "A" p2)
(let ((r3 (shadow "A" p2)))
(multiple-value-bind (s3 kind3)
(find-symbol "A" p2)
(list
(package-name p1)
(package-name p2)
r1 r2
(symbol-name s1)
(package-name (symbol-package s1))
kind1
(symbol-name s2)
(package-name (symbol-package s2))
kind2
r3
(symbol-name s3)
(package-name (symbol-package s3))
kind3))))))
(error (c) c)))
(safely-delete-package "TEST5")
(safely-delete-package "TEST4"))
("TEST4" "TEST5" nil nil "A" "TEST4" :external
"A" "TEST4" :inherited
t
"A" "TEST5" :internal))
"A" "TEST4" :inherited
t
"A" "TEST5" :internal))
(deftest shadow-2
(progn
(ignore-errors (delete-package "H"))
(ignore-errors (delete-package "G"))
(handler-case
(let* ((p1 (prog1
(make-package "G")
(export (intern "A" "G") "G")))
(p2 (make-package "H" :use '("G")))
(r1 (package-shadowing-symbols "G"))
(r2 (package-shadowing-symbols "H")))
(multiple-value-bind (s1 kind1)
(find-symbol "A" p1)
(multiple-value-bind (s2 kind2)
(find-symbol "A" p2)