;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:56 1998 ;;;; Contains: Package test code, part 12 (in-package :cl-test) (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; unintern ;; Simple unintern of an internal symbol, package explicitly ;; given as a package object (deftest unintern-1 (progn (when (packagep (find-package "H")) (delete-package "H")) (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind (sym access) (find-symbol "FOO" p) (and (eq access :internal) (unintern sym p) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (delete-package "H"))) t) ;; Simple unintern, package taken from the *PACKAGES* ;; special variable (should this have unwind protect?) (deftest unintern-2 (progn (when (packagep (find-package "H")) (delete-package "H")) (prog1 (let ((*PACKAGE* (make-package "H"))) (declare (special *PACKAGE*)) (intern "FOO") (multiple-value-bind (sym access) (find-symbol "FOO") (and (eq access :internal) (unintern sym) (null (symbol-package sym)) (not (find-symbol "FOO"))))) (delete-package "H"))) t) ;; Simple unintern, package given as string (deftest unintern-3 (progn (when (packagep (find-package "H")) (delete-package "H")) (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind (sym access) (find-symbol "FOO" p) (and (eq access :internal) (unintern sym "H") (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (delete-package "H"))) t) ;; Simple unintern, package given as symbol (deftest unintern-4 (progn (when (packagep (find-package "H")) (delete-package "H")) (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind (sym access) (find-symbol "FOO" p) (and (eq access :internal) (unintern sym '#:|H|) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (delete-package "H"))) t) ;; Simple unintern, package given as character (deftest unintern-5 (handler-case (progn (when (packagep (find-package "H")) (delete-package "H")) (prog1 (let ((p (make-package "H"))) (intern "FOO" p) (multiple-value-bind (sym access) (find-symbol "FOO" p) (and (eq access :internal) (unintern sym #\H) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) (delete-package "H"))) (error (c) c)) t) ;; Test more complex examples of unintern ;; Unintern an external symbol that is also inherited (deftest unintern-6 (handler-case (progn (ignore-errors (delete-package "H")) (ignore-errors (delete-package "G")) (make-package "G") (export (intern "FOO" "G") "G") (make-package "H" :use '("G")) (export (intern "FOO" "H") "H") ;; At this point, G:FOO is also an external ;; symbol of H. (multiple-value-bind (sym1 access1) (find-symbol "FOO" "H") (and sym1 (eq access1 :external) (equal "FOO" (symbol-name sym1)) (eq (find-package "G") (symbol-package sym1)) (unintern sym1 "H") (multiple-value-bind (sym2 access2) (find-symbol "FOO" "H") (and (eq sym1 sym2) (eq (symbol-package sym1) (find-package "G")) (eq access2 :inherited)))))) (error (c) c)) t) ;; unintern a symbol that is shadowing another symbol (deftest unintern-7 (block failed (ignore-errors (delete-package "H")) (ignore-errors (delete-package "G")) (let* ((pg (make-package "G")) (ph (make-package "H" :use (list pg)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (export (intern "FOO" pg) pg) ;; At this point, H::FOO shadows G:FOO (multiple-value-bind (sym1 access1) (find-symbol "FOO" ph) (and sym1 (eq (symbol-package sym1) ph) (eq access1 :internal) (equal (list sym1) (package-shadowing-symbols ph)) (unintern sym1 ph) (multiple-value-bind (sym2 access2) (find-symbol "FOO" ph) (and (not (eq sym1 sym2)) (eq access2 :inherited) (null (symbol-package sym1)) (eq (symbol-package sym2) pg))))))) t) ;; Error situation: when the symbol is uninterned, creates ;; a name conflict from two used packages (deftest unintern-8 (block failed (ignore-errors (delete-package "H")) (ignore-errors (delete-package "G1")) (ignore-errors (delete-package "G2")) (let* ((pg1 (make-package "G1")) (pg2 (make-package "G2")) (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym1 (intern "FOO" pg1)) (gsym2 (intern "FOO" pg2))) (export gsym1 pg1) (export gsym2 pg2) (multiple-value-bind (sym1 access1) (find-symbol "FOO" ph) (and (equal (list sym1) (package-shadowing-symbols ph)) (not (eq sym1 gsym1)) (not (eq sym1 gsym2)) (eq (symbol-package sym1) ph) (eq access1 :internal) (equal (symbol-name sym1) "FOO") (handler-case (progn (unintern sym1 ph) nil) (error (c) (format t "Properly threw an error: ~S~%" c) t))))))) t) ;; Now, inherit the same symbol through two intermediate ;; packages. No error should occur when the shadowing ;; is removed (deftest unintern-9 (block failed (ignore-errors (delete-package "H")) (ignore-errors (delete-package "G1")) (ignore-errors (delete-package "G2")) (ignore-errors (delete-package "G3")) (let* ((pg3 (make-package "G3")) (pg1 (make-package "G1" :use (list pg3))) (pg2 (make-package "G2" :use (list pg3))) (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym (intern "FOO" pg3))) (export gsym pg3) (export gsym pg1) (export gsym pg2) (multiple-value-bind (sym access) (find-symbol "FOO" ph) (and (equal (list sym) (package-shadowing-symbols ph)) (not (eq sym gsym)) (equal (symbol-name sym) "FOO") (equal (symbol-package sym) ph) (eq access :internal) (handler-case (and (unintern sym ph) (multiple-value-bind (sym2 access2) (find-symbol "FOO" ph) (and (eq gsym sym2) (eq access2 :inherited)))) (error (c) c))))))) t)