From faddbbd0079c48f0e228f2ad9d59abf1a2a75852 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sat, 5 Oct 2002 22:35:19 +0000
Subject: [PATCH] Added tests for character-related functions (except character
 comparisons).

---
 ansi-tests/character.lsp | 237 ++++++++++++++++++++++++++++++++++++---
 ansi-tests/gclload2.lsp  |  10 +-
 2 files changed, 228 insertions(+), 19 deletions(-)

diff --git a/ansi-tests/character.lsp b/ansi-tests/character.lsp
index a3c2b339..98bb3f33 100644
--- a/ansi-tests/character.lsp
+++ b/ansi-tests/character.lsp
@@ -5,6 +5,11 @@
 
 (in-package :cl-test)
 
+(defun char-type-error-check (fn)
+  (loop for x in *universe*
+	always (or (characterp x)
+		   (eq (catch-type-error (funcall fn x)) 'type-error))))
+
 (deftest character-class.1
   (subtypep 'character t)
   t t)
@@ -113,11 +118,7 @@
   t)
 
 (deftest alpha-char-p.3
-  (loop for x in *universe*
-	always (if (characterp x)
-		   (or (find x +alpha-chars+)
-		       (not (alpha-char-p x)))
-		 (eql (catch-type-error (alpha-char-p x)) 'type-error)))
+  (char-type-error-check #'alpha-char-p)
   t)
 
 (deftest alphanumericp.1
@@ -132,13 +133,10 @@
   t)
 
 (deftest alphanumericp.3
-  (loop for x in *universe*
-	always (if (characterp x)
-		   (or (find x +alphanumeric-chars+)
-		       (not (alphanumericp x)))
-		 (eql (catch-type-error (alphanumericp x)) 'type-error)))
+  (char-type-error-check #'alphanumericp)
   t)
 
+
 (deftest alphanumericp.4
   (loop for x in *universe*
 	always (or (not (characterp x))
@@ -234,9 +232,7 @@
   nil)
 
 (deftest graphic-char.3
-  (loop for x in *universe*
-	never (and (not (characterp x))
-		   (not (eq (catch-type-error (graphic-char-p x)) 'type-error))))
+  (char-type-error-check #'graphic-char-p)
   t)
 
 (deftest standard-char-p.1
@@ -259,7 +255,218 @@
   t)
 
 (deftest standard-char-p.3
+  (char-type-error-check #'standard-char-p)
+  t)
+
+(deftest char-upcase.1
   (loop for x in *universe*
-	always (or (characterp x)
-		   (eq (catch-type-error (standard-char-p x)) 'type-error)))
+	always
+	(or (not (characterp x))
+	    (let ((u (char-upcase x))) 
+	      (and
+	       (or (lower-case-p x) (eql u x))
+	       (eql u (char-upcase u))))))
+  t)
+
+(deftest char-upcase.2
+  (loop for i from 0 below (min 65536 char-code-limit)
+	for x = (code-char i)
+	always
+	(or (not x)
+	    (let ((u (char-upcase x)))
+	      (and
+	       (or (lower-case-p x) (eql u x))
+	       (eql u (char-upcase u))))))
+  t)
+
+(deftest char-upcase.3
+  (map 'string #'char-upcase +alpha-chars+)
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ")
+
+(deftest char-upcase.4
+  (char-type-error-check #'char-upcase)
+  t)	
+
+(deftest char-downcase.1
+  (loop for x in *universe*
+	always
+	(or (not (characterp x))
+	    (let ((u (char-downcase x))) 
+	      (and
+	       (or (upper-case-p x) (eql u x))
+	       (eql u (char-downcase u))))))
+  t)
+
+(deftest char-downcase.2
+  (loop for i from 0 below (min 65536 char-code-limit)
+	for x = (code-char i)
+	always
+	(or (not x)
+	    (let ((u (char-downcase x)))
+	      (and
+	       (or (upper-case-p x) (eql u x))
+	       (eql u (char-downcase u))))))
+  t)
+
+(deftest char-downcase.3
+  (map 'string #'char-downcase +alpha-chars+)
+  "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz")
+
+(deftest char-downcase.4
+  (char-type-error-check #'char-downcase)
+  t)
+
+(deftest upper-case-p.1
+  (find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52)
+  nil)
+
+(deftest upper-case-p.2
+  (find-if #'upper-case-p +standard-chars+ :end 26)
+  nil)
+
+(deftest upper-case-p.3
+  (find #'upper-case-p +standard-chars+ :start 52)
+  nil)
+
+(deftest upper-case-p.4
+  (char-type-error-check #'upper-case-p)
+  t)
+
+(deftest lower-case-p.1
+  (find-if-not #'lower-case-p +standard-chars+ :end 26)
+  nil)
+
+(deftest lower-case-p.2
+  (find-if #'lower-case-p +standard-chars+ :start 26)
+  nil)
+
+(deftest lower-case-p.3
+  (char-type-error-check #'lower-case-p)
+  t)
+
+(deftest both-case-p.1
+  (loop for x in *universe*
+	always (or (not (characterp x))
+		   (if (both-case-p x)
+		       (and (graphic-char-p x)
+			    (or (upper-case-p x)
+				(lower-case-p x)))
+		     (not (or (upper-case-p x)
+			      (lower-case-p x))))))
+  t)
+
+(deftest both-case-p.2
+  (loop for i from 0 below (min 65536 char-code-limit)
+	for x = (code-char i)
+	always (or (not (characterp x))
+		   (if (both-case-p x)
+		       (and (graphic-char-p x)
+			    (or (upper-case-p x)
+				(lower-case-p x)))
+		     (not (or (upper-case-p x)
+			      (lower-case-p x))))))
+  t)
+
+(deftest both-case-p.3
+  (char-type-error-check #'both-case-p)
+  t)
+
+(deftest char-code.1
+  (char-type-error-check #'char-code)
+  t)
+
+(deftest char-code.2
+  (loop for i from 0 below (min 65536 char-code-limit)
+	for c = (code-char i)
+	always (or (not c)
+		   (eql (char-code c) i)))
+  t)
+
+(deftest code-char.1
+  (loop for x across +standard-chars+
+	always (eql (code-char (char-code x)) x))
+  t)
+
+(deftest char-int.1
+  (loop for x across +standard-chars+
+	always (eql (char-int x) (char-code x)))
+  t)
+
+(deftest char-int.2
+  (let ((c->i (make-hash-table :test #'equal))
+	(i->c (make-hash-table :test #'eql)))
+    (flet ((%insert
+	    (c)
+	    (or (not (characterp c))
+		(let* ((i (char-int c))
+		       (j (gethash c c->i))
+		       (d (gethash i i->c)))
+		  (and
+		   (or (null j) (eql j i))
+		   (or (null d) (char= c d))
+		   (progn
+		     (setf (gethash c c->i) i)
+		     (setf (gethash i i->c) c)
+		     t))))))
+      (and
+       (loop for i from 0 below char-code-limit
+	     always (%insert (code-char i)))
+       (every #'%insert +standard-chars+)
+       (every #'%insert *universe*))))
+  t)
+
+(deftest char-name.1
+  (flet ((%check
+	  (c)
+	  (or (not (characterp c))
+	      (let ((name (char-name c)))
+		(or (null name)
+		    (and (stringp name)
+			 (eql c (name-char name))))))))
+    (and
+     (loop for i from 0 below char-code-limit
+	   always (%check (code-char i)))
+     (every #'%check +standard-chars+)
+     (every #'%check *universe*)))
+  t)
+
+(deftest char-name.2
+  (string= (char-name #\Space) "Space")
+  t)
+
+(deftest char-name.3
+  (string= (char-name #\Newline) "Newline")
+  t)
+
+(deftest char-name.4
+  (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed")
+	for c = (name-char s)
+	unless (or (not c) (string= (char-name c) s))
+	collect (list s c (char-name c)))
+  nil)
+
+(deftest char-name.5
+  (char-type-error-check #'char-name)
+  t)
+
+(deftest name-char.1
+  (loop for x in *universe*
+	for s = (catch-type-error (string x))
+	always
+	(or (eql s 'type-error)
+	    (let ((c (name-char x)))
+	      (or (not c)
+		  (characterp c)
+		  (string-equal (char-name c) s)))))
+  t)
+
+(deftest name-char.2
+  (loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed"
+		   "SpaCE" "NewLine")
+	always
+	(let ((c1 (name-char (string-upcase s)))
+	      (c2 (name-char (string-downcase s)))
+	      (c3 (name-char (string-capitalize s)))
+	      (c4 (name-char s)))
+	  (and (eql c1 c2) (eql c2 c3) (eql c3 c4))))
   t)
diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp
index bf754a1d..36813b9c 100644
--- a/ansi-tests/gclload2.lsp
+++ b/ansi-tests/gclload2.lsp
@@ -32,8 +32,7 @@
 ;;; Tests of packages
 
 #|
-(compile-file "packages-00.lsp")
-(load "packages-00.o")
+(compile-and-load "packages-00.lsp")
 (load "packages-01.lsp")
 (load "packages-02.lsp")
 (load "packages-03.lsp")
@@ -76,8 +75,7 @@
 (load "find-if.lsp")
 (load "find-if-not.lsp")
 (load "position.lsp")
-(compile-file "search-aux.lsp")
-(load "search-aux.o")
+(compile-and-load "search-aux.lsp")
 (load "search-list.lsp")
 (load "search-vector.lsp")
 (load "search-bitvector.lsp")
@@ -130,3 +128,7 @@
 (load "string-comparisons.lsp")
 (load "make-string.lsp")
 
+;;; Tests for character functions
+(load "character.lsp")
+
+
-- 
GitLab