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