Commit cab86f7d authored by pfdietz's avatar pfdietz

Added test file for SHADOWING-IMPORT.

Added specialized sequence (string) tests for more package functions.
parent 7cab9749
......@@ -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)
......
......@@ -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")
......
......@@ -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
......
......@@ -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)
......
;-*- 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)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment