1 ;;;; miscellaneous tests of STRING-related stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (in-package "CL-USER")
16 ;;; basic non-destructive case operations
17 (assert (string= (string-upcase "This is a test.") "THIS IS A TEST."))
18 (assert (string= (string-downcase "This is a test.") "this is a test."))
19 (assert (string= (string-capitalize "This is a test.") "This Is A Test."))
20 (assert (string= (string-upcase "Is this 900-Sex-hott, please?" :start
3)
21 "Is THIS 900-SEX-HOTT, PLEASE?"))
22 (assert (string= (string-downcase "Is this 900-Sex-hott, please?"
24 "Is this 900-sex-hott, please?"))
25 (assert (string= (string-capitalize "Is this 900-Sex-hott, please?")
26 "Is This 900-Sex-Hott, Please?"))
28 ;;; The non-destructive case operations accept string designators, not
30 (assert (string= (string-upcase '|String designator|
) "STRING DESIGNATOR"))
31 (assert (string= (string-downcase #\S
) "s"))
32 (assert (string= (string-downcase #\.
) "."))
33 (assert (string= (string-capitalize 'ya-str-desig
:end
5) "Ya-StR-DESIG"))
35 ;;; basic destructive case operations
36 (let ((nstring (make-array 5 :element-type
'character
:fill-pointer
0)))
37 (vector-push-extend #\c nstring
)
38 (vector-push-extend #\a nstring
)
39 (vector-push-extend #\t nstring
)
40 (nstring-upcase nstring
)
41 (assert (string= nstring
"CAT"))
42 (setf (fill-pointer nstring
) 2)
43 (nstring-downcase nstring
:start
1)
44 (setf (fill-pointer nstring
) 3)
45 (assert (string= nstring
"CaT"))
46 (nstring-capitalize nstring
)
47 (assert (string= nstring
"Cat")))
49 ;;; (VECTOR NIL)s are strings. Tests for that and issues uncovered in
51 (assert (typep (make-array 1 :element-type nil
) 'string
))
52 (assert (not (typep (make-array 2 :element-type nil
) 'base-string
)))
53 (assert (typep (make-string 3 :element-type nil
) 'simple-string
))
54 (assert (not (typep (make-string 4 :element-type nil
) 'simple-base-string
)))
56 (assert (subtypep (class-of (make-array 1 :element-type nil
))
57 (find-class 'string
)))
58 (assert (subtypep (class-of (make-array 2 :element-type nil
:fill-pointer
1))
59 (find-class 'string
)))
61 (assert (string= "" (make-array 0 :element-type nil
)))
62 (assert (string/= "a" (make-array 0 :element-type nil
)))
63 (assert (string= "" (make-array 5 :element-type nil
:fill-pointer
0)))
65 (assert (= (sxhash "")
66 (sxhash (make-array 0 :element-type nil
))
67 (sxhash (make-array 5 :element-type nil
:fill-pointer
0))
68 (sxhash (make-string 0 :element-type nil
))))
69 (assert (subtypep (type-of (make-array 2 :element-type nil
)) 'simple-string
))
70 (assert (subtypep (type-of (make-array 4 :element-type nil
:fill-pointer t
))
73 (assert (eq (intern "") (intern (make-array 0 :element-type nil
))))
74 (assert (eq (intern "")
75 (intern (make-array 5 :element-type nil
:fill-pointer
0))))
77 (assert (raises-error?
(make-string 5 :element-type t
)))
78 (assert (raises-error?
(let () (make-string 5 :element-type t
))))