From cab86f7d8bcb47bc8cf9043c5a4945dc5811b48a Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sun, 29 Aug 2004 15:44:23 +0000 Subject: [PATCH] Added test file for SHADOWING-IMPORT. Added specialized sequence (string) tests for more package functions. --- ansi-tests/delete-package.lsp | 55 ++++++++++ ansi-tests/load-packages.lsp | 1 + ansi-tests/make-package.lsp | 171 ++++++++++++++++++++++++++++++++ ansi-tests/shadow.lsp | 81 +++++++++++++-- ansi-tests/shadowing-import.lsp | 157 +++++++++++++++++++++++++++++ 5 files changed, 458 insertions(+), 7 deletions(-) create mode 100644 ansi-tests/shadowing-import.lsp diff --git a/ansi-tests/delete-package.lsp b/ansi-tests/delete-package.lsp index 4b645610..15dee9f1 100644 --- a/ansi-tests/delete-package.lsp +++ b/ansi-tests/delete-package.lsp @@ -143,6 +143,61 @@ (delete-package "TEST-20")))) :good) +;;; Specialized sequences + +(defmacro def-delete-package-test (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package name) + (let ((p (make-package name :use nil))) + (list + (notnot (delete-package :test1)) + (notnot (packagep p)) + (package-name p)))) + (t t nil))) + +(def-delete-package-test delete-package.7 + (make-array '(5) :initial-contents "TEST1" + :element-type 'base-char)) + +(def-delete-package-test delete-package.8 + (make-array '(10) :initial-contents "TEST1XXXXX" + :fill-pointer 5 + :element-type 'base-char)) + +(def-delete-package-test delete-package.9 + (make-array '(10) :initial-contents "TEST1XXXXX" + :fill-pointer 5 + :element-type 'character)) + +(def-delete-package-test delete-package.10 + (make-array '(5) :initial-contents "TEST1" + :adjustable t + :element-type 'base-char)) + +(def-delete-package-test delete-package.11 + (make-array '(5) :initial-contents "TEST1" + :adjustable t + :element-type 'character)) + +(def-delete-package-test delete-package.12 + (let* ((etype 'character) + (name2 (make-array '(10) :initial-contents "XXXTEST1YY" + :element-type etype))) + (make-array '(5) :displaced-to name2 + :displaced-index-offset 3 + :element-type etype))) + +(def-delete-package-test delete-package.13 + (let* ((etype 'base-char) + (name2 (make-array '(10) :initial-contents "XXXTEST1YY" + :element-type etype))) + (make-array '(5) :displaced-to name2 + :displaced-index-offset 3 + :element-type etype))) + +;;; Error tests + (deftest delete-package.error.1 (signals-error (delete-package) program-error) t) diff --git a/ansi-tests/load-packages.lsp b/ansi-tests/load-packages.lsp index 86c0fc43..aca9d212 100644 --- a/ansi-tests/load-packages.lsp +++ b/ansi-tests/load-packages.lsp @@ -15,6 +15,7 @@ (load "export.lsp") (load "rename-package.lsp") (load "shadow.lsp") +(load "shadowing-import.lsp") (load "delete-package.lsp") (load "make-package.lsp") (load "with-package-iterator.lsp") diff --git a/ansi-tests/make-package.lsp b/ansi-tests/make-package.lsp index f88e8ecc..4d15d57f 100644 --- a/ansi-tests/make-package.lsp +++ b/ansi-tests/make-package.lsp @@ -260,6 +260,177 @@ (safely-delete-package p)))) t) +;;; Specialized sequences as designators + +;;; The package name being a specialized sequence + +(defmacro def-make-package-test1 (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (assert (string= name "TEST1")) + (safely-delete-package "TEST1") + (let ((p (ignore-errors (make-package name)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t)) + +(def-make-package-test1 make-package.14 + (make-array 5 :initial-contents "TEST1" + :element-type 'base-char)) + +(def-make-package-test1 make-package.15 + (make-array 12 :initial-contents "TEST1xxxyyyz" + :fill-pointer 5 + :element-type 'base-char)) + +(def-make-package-test1 make-package.16 + (make-array 12 :initial-contents "TEST1xxxyyyz" + :fill-pointer 5 + :element-type 'character)) + +(def-make-package-test1 make-package.17 + (make-array 5 :initial-contents "TEST1" + :adjustable t + :element-type 'base-char)) + +(def-make-package-test1 make-package.18 + (make-array 5 :initial-contents "TEST1" + :adjustable t + :element-type 'character)) + +(def-make-package-test1 make-package.19 + (let* ((etype 'base-char) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 2))) + +(def-make-package-test1 make-package.20 + (let* ((etype 'character) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 2))) + +;;; Nicknames being specialized sequences + +(defmacro def-make-package-test2 (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form) + (nickname "TEST1-NICKNAME")) + (safely-delete-package "TEST1") + (safely-delete-package nickname) + (let ((p (make-package name :nicknames (list nickname)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) (list nickname)) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t)) + +(def-make-package-test2 make-package.21 + (make-array 5 :initial-contents "TEST1" + :element-type 'base-char)) + +(def-make-package-test2 make-package.22 + (make-array 12 :initial-contents "TEST1xxxyyyz" + :fill-pointer 5 + :element-type 'base-char)) + +(def-make-package-test2 make-package.23 + (make-array 12 :initial-contents "TEST1xxxyyyz" + :fill-pointer 5 + :element-type 'character)) + +(def-make-package-test2 make-package.24 + (make-array 5 :initial-contents "TEST1" + :adjustable t + :element-type 'base-char)) + +(def-make-package-test2 make-package.25 + (make-array 5 :initial-contents "TEST1" + :adjustable t + :element-type 'character)) + +(def-make-package-test2 make-package.26 + (let* ((etype 'base-char) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 2))) + +(def-make-package-test2 make-package.27 + (let* ((etype 'character) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 2))) + +;;; USE names being specialized sequences + +(defmacro def-make-package-test3 (test-name name-form) + `(deftest ,test-name + (let ((name ,name-form)) + (safely-delete-package "TEST1") + (assert (find-package name)) + (let ((p (ignore-errors (make-package "TEST1" :use (list name))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package name))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t)) + +(def-make-package-test3 make-package.28 + (make-array 1 :initial-contents "A" :element-type 'base-char)) + +(def-make-package-test3 make-package.29 + (make-array 8 :initial-contents "Axxxyyyz" + :fill-pointer 1 + :element-type 'base-char)) + +(def-make-package-test3 make-package.30 + (make-array 8 :initial-contents "Axxxyyyz" + :fill-pointer 1 + :element-type 'character)) + +(def-make-package-test3 make-package.31 + (make-array 1 :initial-contents "A" + :adjustable t + :element-type 'base-char)) + +(def-make-package-test3 make-package.32 + (make-array 1 :initial-contents "A" + :adjustable t + :element-type 'character)) + +(def-make-package-test3 make-package.33 + (let* ((etype 'base-char) + (name0 (make-array 10 :initial-contents "xxAyyy0123" + :element-type etype))) + (make-array 1 :element-type etype + :displaced-to name0 + :displaced-index-offset 2))) + +(def-make-package-test3 make-package.34 + (let* ((etype 'character) + (name0 (make-array 10 :initial-contents "xxAzzzzyyy" + :element-type etype))) + (make-array 1 :element-type etype + :displaced-to name0 + :displaced-index-offset 2))) + ;; Signal a continuable error if the package or any nicknames ;; exist as packages or nicknames of packages diff --git a/ansi-tests/shadow.lsp b/ansi-tests/shadow.lsp index d55b80a3..7b3f7ef8 100644 --- a/ansi-tests/shadow.lsp +++ b/ansi-tests/shadow.lsp @@ -16,7 +16,7 @@ (safely-delete-package "TEST4") (handler-case (let* ((p1 (prog1 - (make-package "TEST4") + (make-package "TEST4" :use nil) (export (intern "A" "TEST4") "TEST4"))) (p2 (make-package "TEST5" :use '("TEST4"))) (r1 (package-shadowing-symbols "TEST4")) @@ -56,7 +56,7 @@ (safely-delete-package "G") (handler-case (let* ((p1 (prog1 - (make-package "G") + (make-package "G" :use nil) (export (intern "A" "G") "G"))) (p2 (make-package "H" :use '("G"))) (r1 (package-shadowing-symbols "G")) @@ -94,7 +94,7 @@ (safely-delete-package "G") (handler-case (let* ((p1 (prog1 - (make-package "G") + (make-package "G" :use nil) (export (intern "A" "G") "G"))) (p2 (make-package "H" :use '("G"))) (r1 (package-shadowing-symbols "G")) @@ -131,7 +131,7 @@ (handler-case (progn (safely-delete-package :G) - (make-package :G) + (make-package :G :use nil) (let ((s1 (intern "X" :G))) (shadow "X" :G) (multiple-value-bind* (s2 kind) @@ -152,7 +152,7 @@ (progn (safely-delete-package :H) (safely-delete-package :G) - (make-package :G) + (make-package :G :use nil) (export (intern "X" :G) :G) (make-package :H :use '("G")) (shadow "X" :H) @@ -174,7 +174,7 @@ (handler-case (progn (safely-delete-package :G) - (make-package :G) + (make-package :G :use nil) (shadow '("X" "Y" |Z|) :G) (let ((results (append (multiple-value-list @@ -202,7 +202,7 @@ (handler-case (let ((i 0) x y) (safely-delete-package :G) - (make-package :G) + (make-package :G :use nil) (shadow (progn (setf x (incf i)) '(#\X #\Y)) (progn (setf y (incf i)) :G)) (let ((results @@ -222,6 +222,73 @@ (safely-delete-package :G)) (2 1 2 "X" :internal "Y" :internal 2)) +;;; Specialized string tests + +(deftest shadow.8 + (prog1 + (handler-case + (progn + (safely-delete-package :G) + (make-package :G :use nil) + (let* ((name (make-array '(1) :initial-contents "X" + :element-type 'base-char)) + (s1 (intern name :G))) + (shadow name :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) + (error (c) c)) + (safely-delete-package "G")) + (t "X" "G" :internal)) + +(deftest shadow.9 + (prog1 + (handler-case + (progn + (safely-delete-package :G) + (make-package :G :use nil) + (let* ((name (make-array '(3) :initial-contents "XYZ" + :fill-pointer 1 + :element-type 'character)) + (s1 (intern name :G))) + (shadow name :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) + (error (c) c)) + (safely-delete-package "G")) + (t "X" "G" :internal)) + +(deftest shadow.10 + (prog1 + (handler-case + (progn + (safely-delete-package :G) + (make-package :G :use nil) + (let* ((name (make-array '(1) :initial-contents "X" + :adjustable t + :element-type 'base-char)) + (s1 (intern name :G))) + (shadow name :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) + (error (c) c)) + (safely-delete-package "G")) + (t "X" "G" :internal)) + + + + (deftest shadow.error.1 (signals-error (shadow) program-error) t) diff --git a/ansi-tests/shadowing-import.lsp b/ansi-tests/shadowing-import.lsp new file mode 100644 index 00000000..2580d120 --- /dev/null +++ b/ansi-tests/shadowing-import.lsp @@ -0,0 +1,157 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 29 07:42:18 2004 +;;;; Contains: Tests for SHADOWING-IMPORT + +(in-package :cl-test) + +(deftest shadowing-import.1 + (let ((name1 "TEST1") + (name2 "TEST2")) + (safely-delete-package name1) + (safely-delete-package name2) + (prog1 + (let* ((p1 (make-package name1 :use nil)) + (p2 (make-package name2)) + (s1 (intern "X" p1)) + (s2 (intern "X" p2))) + (list + (eqt s1 s2) + (eqt (find-symbol "X" p2) s2) + (shadowing-import s1 p2) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) + (safely-delete-package name1) + (safely-delete-package name2))) + (nil t t t t)) + +(deftest shadowing-import.2 + (let ((name1 "TEST1") + (name2 "TEST2")) + (safely-delete-package name1) + (safely-delete-package name2) + (prog1 + (let* ((p1 (make-package name1 :use nil)) + (p2 (make-package name2)) + (s1 (intern "X" p1))) + (list + (find-symbol "X" p2) + (shadowing-import s1 p2) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) + (safely-delete-package name1) + (safely-delete-package name2))) + (nil t t t)) + +(deftest shadowing-import.3 + (let ((name1 "TEST1") + (name2 "TEST2")) + (safely-delete-package name1) + (safely-delete-package name2) + (prog1 + (let* ((p1 (make-package name1 :use nil)) + (p2 (make-package name2 :use nil)) + (s1 (intern "X" p1)) + (s2 (intern "X" p2))) + (list + (eqt s1 s2) + (eqt (find-symbol "X" p2) s2) + (let ((*package* p2)) + (shadowing-import s1)) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) + (safely-delete-package name1) + (safely-delete-package name2))) + (nil t t t t)) + +(deftest shadowing-import.4 + (let ((name1 "TEST1") + (name2 "TEST2") + (name3 "TEST3")) + (safely-delete-package name1) + (safely-delete-package name2) + (safely-delete-package name3) + (prog1 + (let* ((p1 (make-package name1 :use nil)) + (p3 (make-package name2 :use nil)) + (p2 (make-package name3 :use (list p3))) + (s1 (intern "X" p1)) + (s2 (intern "X" p3))) + (export s2 p3) + (list + (eqt s1 s2) + (eqt (find-symbol "X" p2) s2) + (shadowing-import s1 p2) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) + (safely-delete-package name1) + (safely-delete-package name3) + (safely-delete-package name2))) + (nil t t t t)) + +;;; Specialized sequence tests + +(defmacro def-shadowing-import-test (test-name name-form) + `(deftest ,test-name + (let ((name1 ,name-form)) + (safely-delete-package name1) + (prog1 + (let* ((p1 (make-package name1 :use nil))) + (list + (find-symbol "T" p1) + (shadowing-import t name1) + (package-shadowing-symbols p1) + (find-symbol "T" p1))) + (safely-delete-package name1))) + (nil t (t) t))) + +(def-shadowing-import-test shadowing-import.5 + (make-array '(5) :initial-contents "TEST1" + :element-type 'base-char)) + +(def-shadowing-import-test shadowing-import.6 + (make-array '(7) :initial-contents "TEST1XX" + :fill-pointer 7 + :element-type 'character)) + +(def-shadowing-import-test shadowing-import.7 + (make-array '(7) :initial-contents "TEST1XX" + :fill-pointer 7 + :element-type 'base-char)) + +(def-shadowing-import-test shadowing-import.8 + (make-array '(5) :initial-contents "TEST1" + :adjustable t + :element-type 'base-char)) + +(def-shadowing-import-test shadowing-import.9 + (make-array '(5) :initial-contents "TEST1" + :adjustable t + :element-type 'character)) + +(def-shadowing-import-test shadowing-import.10 + (let* ((etype 'character) + (name2 (make-array '(10) :initial-contents "ABTEST1CDE" + :element-type etype))) + (make-array '(5) :element-type etype + :displaced-to name2 + :displaced-index-offset 2))) + +(def-shadowing-import-test shadowing-import.11 + (let* ((etype 'base-char) + (name2 (make-array '(10) :initial-contents "ABTEST1CDE" + :element-type etype))) + (make-array '(5) :element-type etype + :displaced-to name2 + :displaced-index-offset 2))) + +;;; Error tests + +(deftest shadowing-import.error.1 + (signals-error (shadowing-import) program-error) + t) + +(deftest shadowing-import.error.2 + (signals-error (shadowing-import nil *package* nil) + program-error) + t) -- GitLab