Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Karsten Poeck
ansi-test
Commits
34ceedd8
Commit
34ceedd8
authored
Aug 29, 2004
by
pfdietz
Browse files
Tests of various package functions on string arguments that are not simple
character strings.
parent
5d215b89
Changes
13
Hide whitespace changes
Inline
Side-by-side
ansi-tests/do-external-symbols.lsp
View file @
34ceedd8
...
...
@@ -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
ansi-tests/do-symbols.lsp
View file @
34ceedd8
...
...
@@ -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")))
ansi-tests/in-package.lsp
View file @
34ceedd8
...
...
@@ -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
ansi-tests/intern.lsp
View file @
34ceedd8
...
...
@@ -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)
...
...
ansi-tests/package-name.lsp
View file @
34ceedd8
...
...
@@ -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)
...
...
ansi-tests/package-nicknames.lsp
View file @
34ceedd8
...
...
@@ -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)
...
...
ansi-tests/package-use-list.lsp
View file @
34ceedd8
...
...
@@ -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)
...
...
ansi-tests/package-used-by-list.lsp
View file @
34ceedd8
...
...
@@ -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)
...
...
ansi-tests/unexport.lsp
View file @
34ceedd8
...
...
@@ -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)
...
...
ansi-tests/unintern.lsp
View file @
34ceedd8
...
...
@@ -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")