grovel-headers.c: Put win32 stuff into grovel-headers-win32.h.
[sbcl.git] / tests / string.pure.lisp
blob6404f3cf0f1e4ef4ee706b44bf90d5a7f85162ed
1 ;;;; miscellaneous tests of STRING-related stuff
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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?"
23 :start 10 :end 16)
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
29 ;;; just strings.
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
50 ;;; the process.
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))
71 'string))
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-error (make-string 5 :element-type t))
78 (assert-error (let () (make-string 5 :element-type t)))
80 ;; MISC.574
81 (assert (= (funcall (lambda (a)
82 (declare (optimize (speed 3) (safety 1)
83 (debug 1) (space 2))
84 (fixnum a))
85 (string<= (coerce "e99mo7yAJ6oU4" 'base-string)
86 (coerce "aaABAAbaa" 'base-string)
87 :start1 a))
89 9))
91 ;; String trimming.
92 (with-test (:name :string-trim.1)
93 (flet ((make-test (string left right both)
94 (macrolet ((check (fun wanted)
95 `(let ((result (,fun " " string)))
96 (assert (equal result ,wanted))
97 (when (equal string ,wanted)
98 ;; Check that the original string is
99 ;; returned when no changes are needed. Not
100 ;; required by the spec, but a desireable
101 ;; feature for performance.
102 (assert (eql result string))))))
103 ;; Check the functional implementations
104 (locally
105 (declare (notinline string-left-trim string-right-trim
106 string-trim))
107 (check string-left-trim left)
108 (check string-right-trim right)
109 (check string-trim both))
110 ;; Check the transforms
111 (locally
112 (declare (type simple-string string))
113 (check string-left-trim left)
114 (check string-right-trim right)
115 (check string-trim both)))))
116 (make-test "x " "x " "x" "x")
117 (make-test " x" "x" " x" "x")
118 (make-test " x " "x " " x" "x")
119 (make-test " x x " "x x " " x x" "x x")))
122 ;;; Trimming should respect fill-pointers
123 (with-test (:name :string-trim.fill-pointer)
124 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type
125 'character :fill-pointer 7))
126 (s2 (string-left-trim "ab" s))
127 (s3 (string-right-trim "ab" s)))
128 (assert (equal "abcdaba" s))
129 (assert (equal "cdaba" s2))
130 (assert (equal "abcd" s3))))
132 ;;; Trimming should replace displacement offsets
133 (with-test (:name :string-trim.displaced)
134 (let* ((etype 'base-char)
136 (make-array '(6) :initial-contents "abcaeb" :element-type etype))
138 (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1)))
139 (assert (equal "bc" (string-right-trim "ab" s)))
140 (assert (equal "bca" s))
141 (assert (equal "abcaeb" s0))))
143 (with-test (:name :string-trimg.nothing-to-do)
144 ;; Trimming non-simple-strings when there is nothing to do
145 (let ((a (make-array 10 :element-type 'character :initial-contents "abcde00000" :fill-pointer 5)))
146 (assert (equal "abcde" (string-right-trim "Z" a))))
148 ;; Trimming non-strings when there is nothing to do.
149 (string-right-trim " " #\a))
151 (with-test (:name :nil-vector-access)
152 (let ((nil-vector (make-array 10 :element-type nil)))
153 (assert-error (write-to-string nil-vector)
154 sb-kernel:nil-array-accessed-error)
155 (flet ((test (accessor)
156 (assert-error
157 (funcall (compile nil
158 `(lambda ()
159 (,accessor (make-array 10 :element-type nil) 0))))
160 sb-kernel:nil-array-accessed-error)
161 (assert-error
162 (funcall (compile nil `(lambda (x) (,accessor x 0)))
163 nil-vector)
164 sb-kernel:nil-array-accessed-error)))
165 (test 'aref)
166 (test 'char)
167 (test 'schar)
168 (test 'row-major-aref))))
170 (with-test (:name :nil-array-access)
171 (let ((nil-array (make-array '(10 10) :element-type nil)))
172 (assert-error (write-to-string nil-array)
173 sb-kernel:nil-array-accessed-error)
174 (flet ((test (accessor args)
175 (assert-error
176 (funcall (compile nil
177 `(lambda ()
178 (,accessor (make-array '(10 10) :element-type nil)
179 ,@(make-list args :initial-element 0)))))
180 sb-kernel:nil-array-accessed-error)
181 (assert-error
182 (funcall (compile nil `(lambda (x) (,accessor x ,@(make-list args :initial-element 0))))
183 nil-array)
184 sb-kernel:nil-array-accessed-error)))
185 (test 'aref 2)
186 (test 'row-major-aref 1))))