;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:03:36 1998 ;;;; Contains: Tests of WITH-PACKAGE-ITERATOR (declaim (optimize (safety 3))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; with-package-iterator (deftest with-package-iterator.1 (with-package-iterator-internal (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.2 (with-package-iterator-external (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.3 (with-package-iterator-inherited (list (find-package "COMMON-LISP-USER"))) t) (deftest with-package-iterator.4 (with-package-iterator-all (list (find-package "COMMON-LISP-USER"))) t) ;;; Should test on some packages containing shadowed symbols, ;;; multiple inheritance (deftest with-package-iterator.5 (progn (set-up-packages) (with-package-iterator-all '("A"))) t) (deftest with-package-iterator.6 (progn (set-up-packages) (with-package-iterator-all '(#:|A|))) t) (deftest with-package-iterator.7 (progn (set-up-packages) (with-package-iterator-all '(#\A))) t) (deftest with-package-iterator.8 (progn (set-up-packages) (with-package-iterator-internal (list (find-package "A")))) t) (deftest with-package-iterator.9 (progn (set-up-packages) (with-package-iterator-external (list (find-package "A")))) t) (deftest with-package-iterator.10 (progn (set-up-packages) (with-package-iterator-inherited (list (find-package "A")))) t) (deftest with-package-iterator.11 (signals-error (with-package-iterator (x "COMMON-LISP-USER")) program-error) t) ;;; Apply to all packages (deftest with-package-iterator.12 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-internal (list p)))) (error (c) (format t "Error ~S on package ~A~%" c p) t))) 0) (deftest with-package-iterator.13 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-external (list p)))) (error (c) (format t "Error ~S on package ~A~%" c p) t))) 0) (deftest with-package-iterator.14 (loop for p in (list-all-packages) count (handler-case (progn (format t "Package ~S~%" p) (not (with-package-iterator-inherited (list p)))) (error (c) (format t "Error ~S on package ~S~%" c p) t))) 0) (def-macro-test with-package-iterator.error.1 (with-package-iterator (x "CL" :external) nil)) ;;; Specialized sequence tests (defmacro def-with-package-iterator-test (test-name name-form) `(deftest ,test-name (let ((name ,name-form)) (safely-delete-package name) (let* ((p (make-package name :use nil)) (result nil) (s (intern "X" p))) (with-package-iterator (x name :internal) (loop (multiple-value-bind (good? sym) (x) (unless good? (safely-delete-package name) (return (equalt (list s) result))) (push sym result)))))) t)) (def-with-package-iterator-test with-package-iterator.15 (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.16 (make-array 8 :initial-contents "TEST1XXX" :fill-pointer 5 :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.17 (make-array 8 :initial-contents "TEST1XXX" :fill-pointer 5 :element-type 'character)) (def-with-package-iterator-test with-package-iterator.18 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.19 (make-array 5 :initial-contents "TEST1" :adjustable t :element-type 'character)) (def-with-package-iterator-test with-package-iterator.20 (let* ((etype 'base-char) (name0 (make-array 10 :initial-contents "XTEST1YzYY" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 1))) (def-with-package-iterator-test with-package-iterator.21 (let* ((etype 'character) (name0 (make-array 10 :initial-contents "XTEST1YzYY" :element-type etype))) (make-array 5 :element-type etype :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope (deftest with-package-iterator.22 (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-package-iterator (s (return-from done x) :internal) (declare (special x)))))) :good)