From d0968980b9bdea04b347832b2944a48afab3bd5c Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Tue, 1 Oct 2002 02:09:04 +0000
Subject: [PATCH] Added tests for various other string functions and classes.

---
 ansi-tests/string.lsp | 159 +++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 157 insertions(+), 2 deletions(-)

diff --git a/ansi-tests/string.lsp b/ansi-tests/string.lsp
index 245d660e..9de96d27 100644
--- a/ansi-tests/string.lsp
+++ b/ansi-tests/string.lsp
@@ -1,7 +1,7 @@
 ;-*- Mode:     Lisp -*-
 ;;;; Author:   Paul Dietz
 ;;;; Created:  Mon Sep 30 19:16:59 2002
-;;;; Contains: Tests for class and function STRING
+;;;; Contains: Tests for string related functions and classes
 
 (in-package :cl-test)
 
@@ -38,6 +38,161 @@
 			     (type-error () :caught)))
   t)
 
+;;; Tests of base-string
 
-		 
+(deftest base-string.1
+  (subtypep 'base-string 'string)
+  t t)
+
+(deftest base-string.2
+  (subtypep 'base-string 'vector)
+  t t)
+
+(deftest base-string.3
+  (subtypep 'base-string 'array)
+  t t)
+
+(deftest base-string.4
+  (subtypep 'base-string 'sequence)
+  t t)
+
+;;; Tests of simple-string
+
+(deftest simple-string.1
+  (subtypep 'simple-string 'string)
+  t t)
+
+(deftest simple-string.2
+  (subtypep 'simple-string 'vector)
+  t t)
+
+(deftest simple-string.3
+  (subtypep 'simple-string 'simple-array)
+  t t)
+
+(deftest simple-string.4
+  (subtypep 'simple-string 'array)
+  t t)
+
+(deftest simple-string.5
+  (subtypep 'simple-string 'sequence)
+  t t)
+
+;;; Tests for simple-base-string
+
+(deftest simple-base-string.1
+  (subtypep 'simple-base-string 'string)
+  t t)
+
+(deftest simple-base-string.2
+  (subtypep 'simple-base-string 'vector)
+  t t)
+
+(deftest simple-base-string.3
+  (subtypep 'simple-base-string 'simple-array)
+  t t)
+
+(deftest simple-base-string.4
+  (subtypep 'simple-base-string 'array)
+  t t)
+
+(deftest simple-base-string.5
+  (subtypep 'simple-base-string 'sequence)
+  t t)
+
+(deftest simple-base-string.6
+  (subtypep 'simple-base-string 'base-string)
+  t t)
 
+(deftest simple-base-string.7
+  (subtypep 'simple-base-string 'simple-string)
+  t t)
+
+;;; Tests for simple-string-p
+
+(deftest simple-string-p.1
+  (loop for x in *universe*
+	always (if (typep x 'simple-string)
+		   (simple-string-p x)
+		 (not (simple-string-p x))))
+  t)
+
+(deftest simple-string-p.2
+  (not (not (simple-string-p "ancd")))
+  t)
+
+(deftest simple-string-p.3
+  (simple-string-p 0)
+  nil)
+
+(deftest simple-string-p.4
+  (simple-string-p (make-array 4 :element-type 'character
+			       :initial-contents '(#\a #\a #\a #\b)
+			       :fill-pointer t))
+  nil)
+
+(deftest simple-string-p.5
+  (not (not (simple-string-p (make-array
+			      4 :element-type 'base-char
+			      :initial-contents '(#\a #\a #\a #\b)))))
+  t)
+
+(deftest simple-string-p.6
+  (not (not (simple-string-p (make-array
+			      4 :element-type 'standard-char
+			      :initial-contents '(#\a #\a #\a #\b)))))
+  t)
+
+(deftest simple-string-p.7
+  (let* ((s (make-array 10 :element-type 'character
+			:initial-element #\a))
+	 (s2 (make-array 4 :element-type 'character
+			 :displaced-to s
+			 :displaced-index-offset 2)))
+    (simple-string-p s2))
+  nil)
+
+;;; Tests of stringp
+
+(deftest stringp.1
+  (loop for x in *universe*
+	always (if (typep x 'string)
+		   (stringp x)
+		 (not (stringp x))))
+  t)
+
+(deftest stringp.2
+  (not (not (stringp "abcd")))
+  t)
+
+(deftest stringp.3
+  (not (not (stringp (make-array 4 :element-type 'character
+				 :initial-contents '(#\a #\b #\c #\d)))))
+  t)
+
+(deftest stringp.4
+  (not (not (stringp (make-array 4 :element-type 'base-char
+				 :initial-contents '(#\a #\b #\c #\d)))))
+  t)
+
+(deftest stringp.5
+  (not (not (stringp (make-array 4 :element-type 'standard-char
+				 :initial-contents '(#\a #\b #\c #\d)))))
+  t)
+
+(deftest stringp.6
+  (stringp 0)
+  nil)
+
+(deftest stringp.7
+  (stringp #\a)
+  nil)
+
+(deftest stringp.8
+  (let* ((s (make-array 10 :element-type 'character
+			:initial-element #\a))
+	 (s2 (make-array 4 :element-type 'character
+			 :displaced-to s
+			 :displaced-index-offset 2)))
+    (not (not (stringp s2))))
+  t)
-- 
GitLab