Skip to content
Snippets Groups Projects
Commit 6f9e63b4 authored by pfdietz's avatar pfdietz
Browse files

More tests for non-simple or non-base strings

parent cb197851
No related branches found
No related tags found
No related merge requests found
......@@ -35,7 +35,83 @@
(string c)))))
collect c)
nil)
;;; Unusual strings
(deftest find-all-symbols.3
(let* ((name (make-array '(3) :initial-contents "NIL"
:element-type 'base-char))
(symbols (find-all-symbols name)))
(values
(notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols))
(some #'not symbols)))
t t)
(deftest find-all-symbols.4
(let* ((name (make-array '(5) :initial-contents "NILXY"
:fill-pointer 3
:element-type 'character))
(symbols (find-all-symbols name)))
(values
(notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols))
(some #'not symbols)))
t t)
(deftest find-all-symbols.5
(let* ((name (make-array '(5) :initial-contents "NILXY"
:fill-pointer 3
:element-type 'base-char))
(symbols (find-all-symbols name)))
(values
(notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols))
(some #'not symbols)))
t t)
(deftest find-all-symbols.6
(let* ((name (make-array '(3) :initial-contents "NIL"
:adjustable t
:element-type 'base-char))
(symbols (find-all-symbols name)))
(values
(notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols))
(some #'not symbols)))
t t)
(deftest find-all-symbols.7
(let* ((name (make-array '(3) :initial-contents "NIL"
:adjustable t
:element-type 'character))
(symbols (find-all-symbols name)))
(values
(notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols))
(some #'not symbols)))
t t)
(deftest find-all-symbols.8
(let* ((type 'character)
(name0 (make-array '(9) :initial-contents "XYZNILABC"
:element-type type))
(name (make-array '(3) :element-type type
:displaced-to name0
:displaced-index-offset 3))
(symbols (find-all-symbols name)))
(values
(notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols))
(some #'not symbols)))
t t)
(deftest find-all-symbols.9
(let* ((type 'base-char)
(name0 (make-array '(9) :initial-contents "XYZNILABC"
:element-type type))
(name (make-array '(3) :element-type type
:displaced-to name0
:displaced-index-offset 3))
(symbols (find-all-symbols name)))
(values
(notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols))
(some #'not symbols)))
t t)
;;; Error tests
......
......@@ -82,6 +82,56 @@
(eqt cl cl2)))
t)
(deftest find-package.12
(let* ((name (make-array '(7) :initial-contents "KEYWORD"
:element-type 'base-char))
(p (find-package name)))
(and p (eqt p (symbol-package :test))))
t)
(deftest find-package.13
(let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ"
:fill-pointer 7
:element-type 'base-char))
(p (find-package name)))
(and p (eqt p (symbol-package :test))))
t)
(deftest find-package.14
(let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ"
:fill-pointer 7
:element-type 'character))
(p (find-package name)))
(and p (eqt p (symbol-package :test))))
t)
(deftest find-package.15
(let* ((name0 (make-array '(10) :initial-contents "XYKEYWORDZ"
:element-type 'character))
(name (make-array '(7) :displaced-to name0 :displaced-index-offset 2
:element-type 'character))
(p (find-package name)))
(and p (eqt p (symbol-package :test))))
t)
(deftest find-package.16
(let* ((name (make-array '(7) :initial-contents "KEYWORDXYZ"
:adjustable t
:element-type 'base-char))
(p (find-package name)))
(and p (eqt p (symbol-package :test))))
t)
(deftest find-package.17
(let* ((name (make-array '(7) :initial-contents "KEYWORDXYZ"
:adjustable t
:element-type 'character))
(p (find-package name)))
(and p (eqt p (symbol-package :test))))
t)
;;; Error tests
(deftest find-package.error.1
(signals-error (find-package) program-error)
t)
......
......@@ -4,7 +4,10 @@
;;;; Contains: Tests for FIND-SYMBOL
(in-package :cl-test)
(declaim (optimize (safety 3)))
(compile-and-load "packages-00.lsp")
;;(declaim (optimize (safety 3)))
;; Test find-symbol, with the various combinations of
;; package designators
......@@ -75,6 +78,56 @@
(find-symbol "FOO" (find-package "B"))
A::FOO :inherited)
(deftest find-package.17
(let ((name (make-array '(3) :initial-contents "FOO"
:element-type 'base-char)))
(find-symbol name "B"))
A::FOO :inherited)
(deftest find-package.18
(let ((name (make-array '(4) :initial-contents "FOOD"
:element-type 'character
:fill-pointer 3)))
(find-symbol name "B"))
A::FOO :inherited)
(deftest find-package.19
(let ((name (make-array '(4) :initial-contents "FOOD"
:element-type 'base-char
:fill-pointer 3)))
(find-symbol name "B"))
A::FOO :inherited)
(deftest find-package.20
(let* ((name0 (make-array '(5) :initial-contents "XFOOY"
:element-type 'character))
(name (make-array '(3) :element-type 'character
:displaced-to name0
:displaced-index-offset 1)))
(find-symbol name "B"))
A::FOO :inherited)
(deftest find-package.21
(let* ((name0 (make-array '(5) :initial-contents "XFOOY"
:element-type 'base-char))
(name (make-array '(3) :element-type 'base-char
:displaced-to name0
:displaced-index-offset 1)))
(find-symbol name "B"))
A::FOO :inherited)
(deftest find-symbol.22
(find-symbol "FOO" (make-array '(1) :initial-element #\B :element-type 'base-char))
A::FOO :inherited)
(deftest find-symbol.23
(find-symbol "FOO" (make-array '(2) :initial-element #\B
:fill-pointer 1
:element-type 'base-char))
A::FOO :inherited)
(deftest find-symbol.order.1
(let ((i 0) x y)
(values
......
......@@ -134,6 +134,59 @@
)))
(t) t t nil)
(deftest import.10
(let ((pkg-name *import-package-test-name*))
(safely-delete-package pkg-name)
(let ((pkg (eval `(defpackage ,pkg-name (:use))))
(sym 'foo))
(values
(let ((pname (make-array (length pkg-name) :element-type 'base-char
:initial-contents pkg-name)))
(multiple-value-list (import sym pname)))
(eqlt (find-symbol (symbol-name sym) pkg) sym)
(eqlt (symbol-package sym) (find-package :cl-test))
(external-symbols-in-package pkg)
)))
(t) t t nil)
(deftest import.11
(let ((pkg-name *import-package-test-name*))
(safely-delete-package pkg-name)
(let ((pkg (eval `(defpackage ,pkg-name (:use))))
(sym 'foo))
(values
(let ((pname (make-array (+ 3 (length pkg-name))
:element-type 'base-char
:fill-pointer (length pkg-name)
:initial-contents (concatenate 'string pkg-name "XYZ"))))
(multiple-value-list (import sym pname)))
(eqlt (find-symbol (symbol-name sym) pkg) sym)
(eqlt (symbol-package sym) (find-package :cl-test))
(external-symbols-in-package pkg)
)))
(t) t t nil)
(deftest import.12
(let ((pkg-name *import-package-test-name*))
(safely-delete-package pkg-name)
(let ((pkg (eval `(defpackage ,pkg-name (:use))))
(sym 'foo))
(values
(let* ((pname0 (make-array (+ 4 (length pkg-name))
:element-type 'base-char
:fill-pointer (length pkg-name)
:initial-contents (concatenate 'string " " pkg-name "XY")))
(pname (make-array (length pkg-name) :element-type 'base-char
:displaced-to pname0
:displaced-index-offset 2)))
(multiple-value-list (import sym pname)))
(eqlt (find-symbol (symbol-name sym) pkg) sym)
(eqlt (symbol-package sym) (find-package :cl-test))
(external-symbols-in-package pkg)
)))
(t) t t nil)
;;; Error tests
......
......@@ -51,6 +51,65 @@
(symbol-name (make-symbol (make-array '(0) :element-type nil)))
"")
(deftest make-symbol.12
(let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D)
:element-type 'base-char))
(s (make-symbol name))
(name2 (symbol-name s)))
(values
(symbol-package s)
(string=t name2 "ABCD")))
nil t)
(deftest make-symbol.13
(let* ((name (make-array '(6) :initial-contents '(#\A #\B #\C #\D #\E #\F)
:element-type 'character
:fill-pointer 4))
(s (make-symbol name))
(name2 (symbol-name s)))
(values
(symbol-package s)
(string=t name2 "ABCD")))
nil t)
(deftest make-symbol.14
(let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D)
:adjustable t
:element-type 'character))
(s (make-symbol name))
(name2 (symbol-name s)))
(values
(symbol-package s)
(string=t name2 "ABCD")))
nil t)
(deftest make-symbol.15
(let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E)
:element-type 'character))
(name (make-array '(4) :element-type 'character
:displaced-to name0
:displaced-index-offset 1))
(s (make-symbol name))
(name2 (symbol-name s)))
(values
(symbol-package s)
(string=t name2 "ABCD")))
nil t)
(deftest make-symbol.16
(let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E)
:element-type 'base-char))
(name (make-array '(4) :element-type 'base-char
:displaced-to name0
:displaced-index-offset 1))
(s (make-symbol name))
(name2 (symbol-name s)))
(values
(symbol-package s)
(string=t name2 "ABCD")))
nil t)
(deftest make-symbol.order.1
(let ((i 0))
(values
......
......@@ -160,6 +160,81 @@
t)))
t)
(deftest rename-package.7
(block nil
(let ((name1 (make-array '(5) :element-type 'base-char
:initial-contents "TEST1"))
(name2 (make-array '(5) :element-type 'base-char
:initial-contents "TEST2")))
(safely-delete-package name1)
(safely-delete-package name2)
(let ((p (make-package name1)))
(unless (packagep p) (return nil))
(let ((p2 (rename-package name1 name2)))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(equal (package-name p2) name2))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t))))
t)
(deftest rename-package.8
(block nil
(let ((name1 (make-array '(10) :element-type 'base-char
:fill-pointer 5
:initial-contents "TEST1 "))
(name2 (make-array '(9) :element-type 'character
:fill-pointer 5
:initial-contents "TEST2XXXX")))
(safely-delete-package name1)
(safely-delete-package name2)
(let ((p (make-package "TEST1")))
(unless (packagep p) (return nil))
(let ((p2 (rename-package name1 name2)))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(string= (package-name p2) "TEST2"))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t))))
t)
(deftest rename-package.9
(block nil
(let ((name1 (make-array '(5) :element-type 'character
:adjustable t
:initial-contents "TEST1"))
(name2 (make-array '(5) :element-type 'base-char
:adjustable t
:initial-contents "TEST2")))
(safely-delete-package name1)
(safely-delete-package name2)
(let ((p (make-package "TEST1")))
(unless (packagep p) (return nil))
(let ((p2 (rename-package name1 name2)))
(unless (packagep p2)
(safely-delete-package p)
(return p2))
(unless (and (eqt p p2)
(string= (package-name p2) "TEST2"))
(safely-delete-package p)
(safely-delete-package p2)
(return nil))
(safely-delete-package p2)
t))))
t)
(deftest rename-package.error.1
(signals-error (rename-package) program-error)
t)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment