diff --git a/ansi-tests/do-external-symbols.lsp b/ansi-tests/do-external-symbols.lsp index 4813f1ff63fc736ad1e1d8e753cbc37bb607356b..fb48be81faec3dd6a71e742cf5ab9323a81dba83 100644 --- a/ansi-tests/do-external-symbols.lsp +++ b/ansi-tests/do-external-symbols.lsp @@ -73,5 +73,45 @@ (error (c) c)) (NIL (DS1:B T))) +;;; Specialized sequence tests + +(defmacro def-do-external-symbols-test (test-name name-form) + `(deftest ,test-name + (collect-external-symbols ,name-form) + (DS1:A DS1:B))) + +(def-do-external-symbols-test do-external-symbols.9 + (make-array 3 :element-type 'base-char :initial-contents "DS1")) + +(def-do-external-symbols-test do-external-symbols.10 + (make-array 6 :element-type 'base-char :initial-contents "DS1XXX" + :fill-pointer 3)) + +(def-do-external-symbols-test do-external-symbols.11 + (make-array 6 :element-type 'character :initial-contents "DS1XXX" + :fill-pointer 3)) + +(def-do-external-symbols-test do-external-symbols.12 + (make-array 3 :element-type 'base-char :initial-contents "DS1" + :adjustable t)) + +(def-do-external-symbols-test do-external-symbols.13 + (make-array 3 :element-type 'character :initial-contents "DS1" + :adjustable t)) + +(def-do-external-symbols-test do-external-symbols.14 + (let* ((etype 'base-char) + (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) + (make-array 3 :element-type etype + :displaced-to name0 :displaced-index-offset 1))) + +(def-do-external-symbols-test do-external-symbols.15 + (let* ((etype 'character) + (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) + (make-array 3 :element-type etype + :displaced-to name0 :displaced-index-offset 1))) + +;;; Error tests + (def-macro-test do-external-symbols.error.1 - (do-external-symbols (x "CL"))) + (do-external-symbols (x "CL"))) \ No newline at end of file diff --git a/ansi-tests/do-symbols.lsp b/ansi-tests/do-symbols.lsp index 296b1889f59d0be1498d8b20c003fa9ca0452e54..51509496cf5b46b6611c0e68f9446599fd667846 100644 --- a/ansi-tests/do-symbols.lsp +++ b/ansi-tests/do-symbols.lsp @@ -85,6 +85,55 @@ (error (c) c)) (NIL (DS1:A DS1:B DS1::D T))) +;;; Specialized sequences + +(defmacro def-do-symbols-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (assert (string= name "B")) + (equalt + (remove-duplicates + (sort-symbols (let ((all nil)) + (do-symbols (x name all) (push x all))))) + (list (find-symbol "BAR" "B") + (find-symbol "FOO" "A")))) + t)) + +(def-do-symbols-test do-symbols.9 + (make-array 1 :element-type 'base-char :initial-contents "B")) + +(def-do-symbols-test do-symbols.10 + (make-array 5 :element-type 'character + :fill-pointer 1 + :initial-contents "BXXXX")) + +(def-do-symbols-test do-symbols.11 + (make-array 5 :element-type 'base-char + :fill-pointer 1 + :initial-contents "BXXXX")) + +(def-do-symbols-test do-symbols.12 + (make-array 1 :element-type 'base-char + :adjustable t :initial-contents "B")) + +(def-do-symbols-test do-symbols.13 + (make-array 1 :element-type 'character + :adjustable t :initial-contents "B")) + +(def-do-symbols-test do-symbols.14 + (let* ((etype 'base-char) + (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) + (make-array 1 :element-type etype + :displaced-to name0 :displaced-index-offset 1))) + +(def-do-symbols-test do-symbols.15 + (let* ((etype 'character) + (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) + (make-array 1 :element-type etype + :displaced-to name0 :displaced-index-offset 1))) + + + (def-macro-test do-symbols.error.1 (do-symbols (x "CL"))) diff --git a/ansi-tests/in-package.lsp b/ansi-tests/in-package.lsp index 00ba58cd1d24c2c9a1d6551c0b6ce6a695bec690..079f5f5f0cdb8a49ab448cf01bc5c0b689181c5d 100644 --- a/ansi-tests/in-package.lsp +++ b/ansi-tests/in-package.lsp @@ -48,3 +48,51 @@ (def-macro-test in-package.error.1 (in-package :cl-test)) + +(defmacro def-in-package-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package name) + (prog1 + (let* ((p (make-package name :use nil)) + (*package* *package*) + (p2 (eval `(in-package ,name)))) + (list (eqt p p2) + (eqt p *package*))) + (safely-delete-package name))) + (t t))) + +(def-in-package-test in-package.7 + (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) + +(def-in-package-test in-package.8 + (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'base-char)) + +(def-in-package-test in-package.9 + (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'character)) + +(def-in-package-test in-package.10 + (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'base-char)) + +(def-in-package-test in-package.11 + (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'character)) + +(def-in-package-test in-package.12 + (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +(def-in-package-test in-package.13 + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) \ No newline at end of file diff --git a/ansi-tests/intern.lsp b/ansi-tests/intern.lsp index c3f35b57145523324489dc8ec0108dc18bddcfdc..7f5bd0fecef05c4887a0cfe8fc015c85866c87b6 100644 --- a/ansi-tests/intern.lsp +++ b/ansi-tests/intern.lsp @@ -12,7 +12,7 @@ (deftest intern.1 (progn (safely-delete-package "TEMP1") - (let ((p (make-package "TEMP1")) + (let ((p (make-package "TEMP1" :use nil)) (i 0) x y) (multiple-value-bind* (sym1 status1) (find-symbol "FOO" p) @@ -34,7 +34,7 @@ (deftest intern.2 (progn (safely-delete-package "TEMP1") - (let ((p (make-package "TEMP1"))) + (let ((p (make-package "TEMP1" :use nil))) (multiple-value-bind* (sym1 status1) (find-symbol "FOO" "TEMP1") (intern "FOO" "TEMP1") @@ -63,6 +63,112 @@ :initial-contents "XYZZY") cl-user-package))) t) +;;; String is a specialized sequence type + +(defmacro def-intern-test (test-name &key (symbol-name "FOO") + (package-name "TEMP1")) + `(deftest ,test-name + (let ((sname ,symbol-name) + (pname ,package-name)) + (safely-delete-package pname) + (let ((p (make-package pname :use nil))) + (multiple-value-bind* + (sym1 status1) + (find-symbol sname pname) + (intern sname pname) + (multiple-value-bind* + (sym2 status2) + (find-symbol sname p) + (and (null sym1) + (null status1) + (string= (symbol-name sym2) sname) + (eqt (symbol-package sym2) p) + (eqt status2 :internal) + (progn (delete-package p) t)))))) + t)) + +(def-intern-test intern.5 + :symbol-name (make-array 3 :element-type 'base-char + :initial-contents "BAR")) + +(def-intern-test intern.6 + :symbol-name (make-array 13 :element-type 'base-char + :fill-pointer 3 + :initial-contents "BAR1234567890")) + +(def-intern-test intern.7 + :symbol-name (make-array 13 :element-type 'character + :fill-pointer 3 + :initial-contents "BAR1234567890")) + +(def-intern-test intern.8 + :symbol-name (make-array 3 :element-type 'base-char + :adjustable t + :initial-contents "BAR")) + +(def-intern-test intern.9 + :symbol-name (make-array 3 :element-type 'character + :adjustable t + :initial-contents "BAR")) + +(def-intern-test intern.10 + :symbol-name + (let* ((etype 'base-char) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) + (make-array 3 :element-type etype :displaced-to name0 + :displaced-index-offset 1))) + +(def-intern-test intern.11 + :symbol-name + (let* ((etype 'character) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) + (make-array 3 :element-type etype :displaced-to name0 + :displaced-index-offset 1))) + +(def-intern-test intern.12 + :package-name (make-array 3 :element-type 'base-char + :initial-contents "BAR")) + +(def-intern-test intern.13 + :package-name (make-array 13 :element-type 'base-char + :fill-pointer 3 + :initial-contents "BAR1234567890")) + +(def-intern-test intern.14 + :package-name (make-array 13 :element-type 'character + :fill-pointer 3 + :initial-contents "BAR1234567890")) + +(def-intern-test intern.15 + :package-name (make-array 3 :element-type 'base-char + :adjustable t + :initial-contents "BAR")) + +(def-intern-test intern.16 + :package-name (make-array 3 :element-type 'character + :adjustable t + :initial-contents "BAR")) + +(def-intern-test intern.17 + :package-name + (let* ((etype 'base-char) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) + (make-array 3 :element-type etype :displaced-to name0 + :displaced-index-offset 1))) + +(def-intern-test intern.18 + :package-name + (let* ((etype 'character) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) + (make-array 3 :element-type etype :displaced-to name0 + :displaced-index-offset 1))) + +;;; Error tests + (deftest intern.error.1 (signals-error (intern) program-error) t) diff --git a/ansi-tests/package-name.lsp b/ansi-tests/package-name.lsp index 78ed41cee0a1062ce7da3c6d87af46f0b9ef86d4..7fdffe077efe6f1c946e13ffedf587c370fba7c2 100644 --- a/ansi-tests/package-name.lsp +++ b/ansi-tests/package-name.lsp @@ -104,6 +104,61 @@ (ignore-errors (package-name (package-name p)))))) 0) +;;; Specialized sequence tests + +(defmacro def-package-name-test (test-name name-form expected-name-form) + `(deftest ,test-name + (let ((name ,name-form) + (expected-name ,expected-name-form)) + (assert (string= name expected-name)) + (safely-delete-package name) + (let ((p (make-package name :use nil))) + (equalt (package-name p) expected-name))) + t)) + +(def-package-name-test package-name.16 + (make-array 5 :element-type 'base-char :initial-contents "TEST1") + "TEST1") + +(def-package-name-test package-name.17 + (make-array 10 :element-type 'base-char + :fill-pointer 5 + :initial-contents "TEST1?????") + "TEST1") + +(def-package-name-test package-name.18 + (make-array 10 :element-type 'character + :fill-pointer 5 + :initial-contents "TEST1?????") + "TEST1") + +(def-package-name-test package-name.19 + (make-array 5 :element-type 'base-char :adjustable t + :initial-contents "TEST1") + "TEST1") + +(def-package-name-test package-name.20 + (make-array 5 :element-type 'character :adjustable t + :initial-contents "TEST1") + "TEST1") + +(def-package-name-test package-name.21 + (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2)) + "TEST1") + +(def-package-name-test package-name.22 + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2)) + "TEST1") + + (deftest package-name.error.1 (signals-error (package-name) program-error) t) diff --git a/ansi-tests/package-nicknames.lsp b/ansi-tests/package-nicknames.lsp index 39f23e2aeb4ba7fba9ffe11fe7167fb5e24a3657..c5e0395f519e4e3ca823f0e1827a59efe3dae7d2 100644 --- a/ansi-tests/package-nicknames.lsp +++ b/ansi-tests/package-nicknames.lsp @@ -83,6 +83,53 @@ (eqt p (find-package nk)))))) 0) +;;; Specialized sequence names tests + +(defmacro def-package-nicknames-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package name) + (let ((p (make-package name :use nil))) + (package-nicknames p))) + nil)) + +(def-package-nicknames-test package-nicknames.16 + (make-array 5 :element-type 'base-char :initial-contents "TEST1")) + +(def-package-nicknames-test package-nicknames.17 + (make-array 10 :element-type 'base-char + :fill-pointer 5 + :initial-contents "TEST1?????")) + +(def-package-nicknames-test package-nicknames.18 + (make-array 10 :element-type 'character + :fill-pointer 5 + :initial-contents "TEST1?????")) + +(def-package-nicknames-test package-nicknames.19 + (make-array 5 :element-type 'base-char :adjustable t + :initial-contents "TEST1")) + +(def-package-nicknames-test package-nicknames.20 + (make-array 5 :element-type 'character :adjustable t + :initial-contents "TEST1")) + +(def-package-nicknames-test package-nicknames.21 + (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2))) + +(def-package-nicknames-test package-nicknames.22 + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2))) + +;;; Error tests + (deftest package-nicknames.error.1 (signals-error (package-nicknames) program-error) t) diff --git a/ansi-tests/package-use-list.lsp b/ansi-tests/package-use-list.lsp index 0e5f1de316e0292f844b53be27292e3212cc5e79..3926adb2bf947a5dfc473642a5b0ece50680535e 100644 --- a/ansi-tests/package-use-list.lsp +++ b/ansi-tests/package-use-list.lsp @@ -7,6 +7,53 @@ ;;; Most tests of this function are in files for other package-related operators +;;; Specialized sequence tests + +(defmacro def-package-use-list-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package name) + (let ((p (make-package name :use nil))) + (package-use-list p))) + nil)) + +(def-package-use-list-test package-use-list.1 + (make-array 5 :element-type 'base-char :initial-contents "TEST1")) + +(def-package-use-list-test package-use-list.2 + (make-array 10 :element-type 'base-char + :fill-pointer 5 + :initial-contents "TEST1?????")) + +(def-package-use-list-test package-use-list.3 + (make-array 10 :element-type 'character + :fill-pointer 5 + :initial-contents "TEST1?????")) + +(def-package-use-list-test package-use-list.4 + (make-array 5 :element-type 'base-char :adjustable t + :initial-contents "TEST1")) + +(def-package-use-list-test package-use-list.5 + (make-array 5 :element-type 'character :adjustable t + :initial-contents "TEST1")) + +(def-package-use-list-test package-use-list.6 + (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2))) + +(def-package-use-list-test package-use-list.7 + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2))) + +;;; Error tests + (deftest package-use-list.error.1 (signals-error (package-use-list) program-error) t) diff --git a/ansi-tests/package-used-by-list.lsp b/ansi-tests/package-used-by-list.lsp index 42178126ab7bded0104a7335f6e3387903b440e3..dded936e851f7e3b57825436db05f3846abc6a2f 100644 --- a/ansi-tests/package-used-by-list.lsp +++ b/ansi-tests/package-used-by-list.lsp @@ -7,6 +7,53 @@ ;;; Most tests of this function are in files for other package-related operators +;;; Specialized sequence tests + +(defmacro def-package-used-by-list-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package name) + (let ((p (make-package name :use nil))) + (package-used-by-list p))) + nil)) + +(def-package-used-by-list-test package-used-by-list.1 + (make-array 5 :element-type 'base-char :initial-contents "TEST1")) + +(def-package-used-by-list-test package-used-by-list.2 + (make-array 10 :element-type 'base-char + :fill-pointer 5 + :initial-contents "TEST1?????")) + +(def-package-used-by-list-test package-used-by-list.3 + (make-array 10 :element-type 'character + :fill-pointer 5 + :initial-contents "TEST1?????")) + +(def-package-used-by-list-test package-used-by-list.4 + (make-array 5 :element-type 'base-char :adjustable t + :initial-contents "TEST1")) + +(def-package-used-by-list-test package-used-by-list.5 + (make-array 5 :element-type 'character :adjustable t + :initial-contents "TEST1")) + +(def-package-used-by-list-test package-used-by-list.6 + (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2))) + +(def-package-used-by-list-test package-used-by-list.7 + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) + (make-array 5 :element-type etype :displaced-to name0 + :displaced-index-offset 2))) + +;;; Error tests + (deftest package-used-by-list.error.1 (signals-error (package-used-by-list) program-error) t) diff --git a/ansi-tests/unexport.lsp b/ansi-tests/unexport.lsp index b1daec45764c8167f97275226b6081d7939714c9..628b5a2093bfb3d72feab006cddd0702f77e704c 100644 --- a/ansi-tests/unexport.lsp +++ b/ansi-tests/unexport.lsp @@ -134,6 +134,66 @@ t))))) t) +;;; Specialized sequence tests + +(defmacro def-unexport-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package name) + (let* ((p (make-package name :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind* + (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) name) + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) + t)) + +(def-unexport-test unexport.7 + (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) + +(def-unexport-test unexport.8 + (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'base-char)) + +(def-unexport-test unexport.9 + (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'character)) + +(def-unexport-test unexport.10 + (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'base-char)) + +(def-unexport-test unexport.11 + (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'character)) + +(def-unexport-test unexport.12 + (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +(def-unexport-test unexport.13 + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +;;; Error tests + (deftest unexport.error.1 (signals-error (unexport) program-error) t) diff --git a/ansi-tests/unintern.lsp b/ansi-tests/unintern.lsp index d2c45f50f6319d12cd3bce4fc371bc920c4da9f1..f803969290ff6c6fc919c414f3fde2d0b80b1f54 100644 --- a/ansi-tests/unintern.lsp +++ b/ansi-tests/unintern.lsp @@ -15,7 +15,7 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H")) + (let ((p (make-package "H" :use nil)) (i 0) x y) (intern "FOO" p) (multiple-value-bind* @@ -37,7 +37,7 @@ (progn (safely-delete-package "H") (prog1 - (let ((*PACKAGE* (make-package "H"))) + (let ((*PACKAGE* (make-package "H" :use nil))) (intern "FOO") (multiple-value-bind* (sym access) (find-symbol "FOO") @@ -54,7 +54,7 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H"))) + (let ((p (make-package "H" :use nil))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) @@ -71,7 +71,7 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H"))) + (let ((p (make-package "H" :use nil))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) @@ -89,7 +89,7 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H"))) + (let ((p (make-package "H" :use nil))) (intern "FOO" p) (multiple-value-bind* (sym access) (find-symbol "FOO" p) @@ -112,7 +112,7 @@ (progn (safely-delete-package "H") (safely-delete-package "G") - (make-package "G") + (make-package "G" :use nil) (export (intern "FOO" "G") "G") (make-package "H" :use '("G")) (export (intern "FOO" "H") "H") @@ -141,7 +141,7 @@ (block failed (safely-delete-package "H") (safely-delete-package "G") - (let* ((pg (make-package "G")) + (let* ((pg (make-package "G" :use nil)) (ph (make-package "H" :use (list pg)))) (handler-case (shadow "FOO" ph) @@ -171,8 +171,8 @@ (safely-delete-package "H") (safely-delete-package "G1") (safely-delete-package "G2") - (let* ((pg1 (make-package "G1")) - (pg2 (make-package "G2")) + (let* ((pg1 (make-package "G1" :use nil)) + (pg2 (make-package "G2" :use nil)) (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) @@ -208,7 +208,7 @@ (safely-delete-package "G1") (safely-delete-package "G2") (safely-delete-package "G3") - (let* ((pg3 (make-package "G3")) + (let* ((pg3 (make-package "G3" :use nil)) (pg1 (make-package "G1" :use (list pg3))) (pg2 (make-package "G2" :use (list pg3))) (ph (make-package "H" :use (list pg1 pg2)))) @@ -236,6 +236,62 @@ (error (c) c))))))) t) +;;; Specialized sequence tests + +(defmacro def-unintern-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package name) + (prog1 + (let ((p (make-package name :use nil))) + (intern "FOO" p) + (multiple-value-bind* + (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym name) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (safely-delete-package name))) + t)) + +(def-unintern-test unintern.10 + (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) + +(def-unintern-test unintern.11 + (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'base-char)) + +(def-unintern-test unintern.12 + (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'character)) + +(def-unintern-test unintern.13 + (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'base-char)) + +(def-unintern-test unintern.14 + (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'character)) + +(def-unintern-test unintern.15 + (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +(def-unintern-test unintern.16 + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + + (deftest unintern.error.1 (signals-error (unintern) program-error) t) diff --git a/ansi-tests/unuse-package.lsp b/ansi-tests/unuse-package.lsp index 5e19d15ca273d3dce6fbc2711c5eb7d6990042d1..bdc2a5fa7032969398b434b8d9d59a8351e09a23 100644 --- a/ansi-tests/unuse-package.lsp +++ b/ansi-tests/unuse-package.lsp @@ -189,6 +189,107 @@ (safely-delete-package p)))))) t) +;;; Specialized sequences + +(defmacro def-unuse-package-test (test-name &key + (user "H") + (used "G")) + `(deftest ,test-name + (let ((user-name ,user) + (used-name ,used)) + (safely-delete-package user-name) + (safely-delete-package used-name) + (let* ((pused (make-package used-name :use nil)) + (puser (make-package user-name :use (list used-name)))) + (prog1 + (and + (equal (package-use-list puser) (list pused)) + (equal (package-used-by-list pused) (list puser)) + (unuse-package (list used-name) user-name) + (equal (package-use-list puser) nil) + (null (package-used-by-list pused))) + (safely-delete-package user-name) + (safely-delete-package used-name)))) + t)) + +;;; Specialized user package designator + +(def-unuse-package-test unuse-package.10 + :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) + +(def-unuse-package-test unuse-package.11 + :user (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'base-char)) + +(def-unuse-package-test unuse-package.12 + :user (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'character)) + +(def-unuse-package-test unuse-package.13 + :user (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'base-char)) + +(def-unuse-package-test unuse-package.14 + :user (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'character)) + +(def-unuse-package-test unuse-package.15 + :user (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +(def-unuse-package-test unuse-package.16 + :user + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +;;; Specialed used package designator + +(def-unuse-package-test unuse-package.17 + :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) + +(def-unuse-package-test unuse-package.18 + :used (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'base-char)) + +(def-unuse-package-test unuse-package.19 + :used (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'character)) + +(def-unuse-package-test unuse-package.20 + :used (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'base-char)) + +(def-unuse-package-test unuse-package.21 + :used (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'character)) + +(def-unuse-package-test unuse-package.22 + :used (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +(def-unuse-package-test unuse-package.23 + :used + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +;;; Error tests + (deftest unuse-package.error.1 (signals-error (unuse-package) program-error) t) diff --git a/ansi-tests/use-package.lsp b/ansi-tests/use-package.lsp index 3250cc39b5355d274e86313867005f55326f1a57..544c529b67d71bd71155a0ba3d8d2f335c38c340 100644 --- a/ansi-tests/use-package.lsp +++ b/ansi-tests/use-package.lsp @@ -197,7 +197,142 @@ (safely-delete-package ph)))) t) -;; Also: need to check that *PACKAGE* is used as a default +;; Check that *PACKAGE* is used as a default + +(deftest use-package.7 + (let ((user-name "H") + (used-name "G")) + (safely-delete-package user-name) + (safely-delete-package used-name) + (let* ((pused (make-package used-name :use nil)) + (puser (make-package user-name :use nil)) + (sym1 (intern "FOO" pused))) + (and + (eqt (export sym1 pused) t) + (null (package-used-by-list pused)) + (null (package-used-by-list puser)) + (null (package-use-list pused)) + (null (package-use-list puser)) + (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used + (multiple-value-bind (sym2 access) + (find-symbol "FOO" puser) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list puser) (list pused)) + (equal (package-used-by-list pused) (list puser)) + (null (package-use-list pused)) + (null (package-used-by-list puser)) + (eqt (unuse-package pused puser) t) + (null (find-symbol "FOO" puser))))) + t) + +;;; Tests for specialized sequence arguments + +(defmacro def-use-package-test (test-name &key (user "H") (used "G")) + `(deftest ,test-name + (let ((user-name ,user) + (used-name ,used)) + (safely-delete-package user-name) + (safely-delete-package used-name) + (let* ((pused (make-package used-name :use nil)) + (puser (make-package user-name :use nil)) + (sym1 (intern "FOO" pused))) + (and + (eqt (export sym1 pused) t) + (null (package-used-by-list pused)) + (null (package-used-by-list puser)) + (null (package-use-list pused)) + (null (package-use-list puser)) + (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used + (multiple-value-bind (sym2 access) + (find-symbol "FOO" puser) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list puser) (list pused)) + (equal (package-used-by-list pused) (list puser)) + (null (package-use-list pused)) + (null (package-used-by-list puser)) + (eqt (unuse-package pused puser) t) + (null (find-symbol "FOO" puser))))) + t)) + +;;; Specialized user package designator + +(def-use-package-test use-package.10 + :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) + +(def-use-package-test use-package.11 + :user (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'base-char)) + +(def-use-package-test use-package.12 + :user (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'character)) + +(def-use-package-test use-package.13 + :user (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'base-char)) + +(def-use-package-test use-package.14 + :user (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'character)) + +(def-use-package-test use-package.15 + :user (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +(def-use-package-test use-package.16 + :user + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +;;; Specialed used package designator + +(def-use-package-test use-package.17 + :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) + +(def-use-package-test use-package.18 + :used (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'base-char)) + +(def-use-package-test use-package.19 + :used (make-array 10 :initial-contents "TEST1ABCDE" + :fill-pointer 5 :element-type 'character)) + +(def-use-package-test use-package.20 + :used (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'base-char)) + +(def-use-package-test use-package.21 + :used (make-array 5 :initial-contents "TEST1" + :adjustable t :element-type 'character)) + +(def-use-package-test use-package.22 + :used (let* ((etype 'base-char) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) + +(def-use-package-test use-package.23 + :used + (let* ((etype 'character) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) (deftest use-package.error.1 (signals-error (use-package) program-error) diff --git a/ansi-tests/with-package-iterator.lsp b/ansi-tests/with-package-iterator.lsp index 5368f6df70f3f7f75c94fefe057984c9c5cf2d91..31e1447ba7f1d94f00f6961fa2fbe3f25d930c88 100644 --- a/ansi-tests/with-package-iterator.lsp +++ b/ansi-tests/with-package-iterator.lsp @@ -54,33 +54,10 @@ (with-package-iterator-inherited (list (find-package "A"))) t) -;;; Check that if no access symbols are provided, a program error is -;;; raised -#| (deftest with-package-iterator.11 - (handler-case - (progn - (test-with-package-iterator (list (find-package "COMMON-LISP-USER"))) - nil) - (program-error () t) - (error (c) c)) - t) -|# - -;;; Paul Werkowski" <pw@snoopy.mv.com> pointed out that -;;; that test is broken. Here's a version of the replacement -;;; he suggested. -;; -;;; I'm not sure if this is correct either; it depends on -;;; whether with-package-iterator should signal the error -;;; at macro expansion time or at run time. -;; - -(deftest with-package-iterator.11 - (handler-case (macroexpand-1 - '(with-package-iterator (x "COMMON-LISP-USER"))) - (program-error () t) - (error (c) c)) + (signals-error + (with-package-iterator (x "COMMON-LISP-USER")) + program-error) t) ;;; Apply to all packages @@ -122,3 +99,65 @@ (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)))