diff --git a/ansi-tests/find-all-symbols.lsp b/ansi-tests/find-all-symbols.lsp index c8234fb36f1f725bb84000ee48e1390614fe648b..a1310031bc91df6fba4e175e2607c35fb3048194 100644 --- a/ansi-tests/find-all-symbols.lsp +++ b/ansi-tests/find-all-symbols.lsp @@ -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 diff --git a/ansi-tests/find-package.lsp b/ansi-tests/find-package.lsp index ebf06d9492f5727e4c0754e1c6b6c862e3677a57..c50b25057b5fa6a20f33d1b78aa16cf7cf7901d9 100644 --- a/ansi-tests/find-package.lsp +++ b/ansi-tests/find-package.lsp @@ -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) diff --git a/ansi-tests/find-symbol.lsp b/ansi-tests/find-symbol.lsp index f3541a797b2369fad106027fe93d371ae4a90eb8..d66dc925696dc95615aef365f8791534f4a1b266 100644 --- a/ansi-tests/find-symbol.lsp +++ b/ansi-tests/find-symbol.lsp @@ -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 diff --git a/ansi-tests/import.lsp b/ansi-tests/import.lsp index f4f3956e67b79b8f6e2429879092197842ed254a..8edbe2f20e1d5f3d7218ca0ab5b640cfd11b4d4c 100644 --- a/ansi-tests/import.lsp +++ b/ansi-tests/import.lsp @@ -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 diff --git a/ansi-tests/make-symbol.lsp b/ansi-tests/make-symbol.lsp index 8b37f470e135c64853493b213455cc352f993504..9c3f1375a5aeb378c12b7751773bca17b2a97130 100644 --- a/ansi-tests/make-symbol.lsp +++ b/ansi-tests/make-symbol.lsp @@ -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 diff --git a/ansi-tests/rename-package.lsp b/ansi-tests/rename-package.lsp index e00425c199387c50d5631a8eb8a147c94629637b..e97a46c8ee02a19bd398ec9cd226f67d1b849283 100644 --- a/ansi-tests/rename-package.lsp +++ b/ansi-tests/rename-package.lsp @@ -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)