Really restore clisp cross-compilation.
[sbcl.git] / tests / string.pure.lisp
1 ;;;; miscellaneous tests of STRING-related stuff
2
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.
13
14 (in-package "CL-USER")
15
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?"))
27
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"))
34
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")))
48
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)))
55
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)))
60
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)))
64
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))
72
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))))
76
77 (assert (raises-error? (make-string 5 :element-type t)))
78 (assert (raises-error? (let () (make-string 5 :element-type t))))
79
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))
88                     9)
89            9))
90
91 ;; String trimming.
92
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"))
120
121
122 ;;; Trimming should respect fill-pointers
123 (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type
124                       'character :fill-pointer 7))
125        (s2 (string-left-trim "ab" s))
126        (s3 (string-right-trim "ab" s)))
127   (assert (equal "abcdaba" s))
128   (assert (equal "cdaba" s2))
129   (assert (equal "abcd" s3)))
130
131 ;;; Trimming should replace displacement offsets
132 (let* ((etype 'base-char)
133              (s0
134               (make-array '(6) :initial-contents "abcaeb" :element-type etype))
135              (s
136               (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1)))
137   (assert (equal "bc" (string-right-trim "ab" s)))
138   (assert (equal "bca" s))
139   (assert (equal "abcaeb" s0)))
140
141 ;;; Trimming non-simple-strings when there is nothing to do
142 (let ((a (make-array 10 :element-type 'character :initial-contents "abcde00000" :fill-pointer 5)))
143   (assert (equal "abcde" (string-right-trim "Z" a))))
144
145 ;;; Trimming non-strings when there is nothing to do.
146 (string-right-trim " " #\a)
147