Commit 34ceedd8 authored by pfdietz's avatar pfdietz

Tests of various package functions on string arguments that are not simple

character strings.
parent 5d215b89
......@@ -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
......@@ -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")))
......@@ -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
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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