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 ;;; basic non-destructive case operations
  15 (with-test (:name (string-upcase string-downcase string-capitalize :smoke))
  16   (assert (string= (string-upcase     "This is a test.") "THIS IS A TEST."))
  17   (assert (string= (string-downcase   "This is a test.") "this is a test."))
  18   (assert (string= (string-capitalize "This is a test.") "This Is A Test."))
  19   (assert (string= (string-upcase "Is this 900-Sex-hott, please?" :start 3)
  20                    "Is THIS 900-SEX-HOTT, PLEASE?"))
  21   (assert (string= (string-downcase "Is this 900-Sex-hott, please?"
  22                                     :start 10 :end 16)
  23                    "Is this 900-sex-hott, please?"))
  24   (assert (string= (string-capitalize "Is this 900-Sex-hott, please?")
  25                    "Is This 900-Sex-Hott, Please?")))
  26
  27 ;;; The non-destructive case operations accept string designators, not
  28 ;;; just strings.
  29
  30 (with-test (:name (string-upcase string-downcase string-capitalize :designators))
  31   (assert (string= (string-upcase '|String designator|) "STRING DESIGNATOR"))
  32   (assert (string= (string-downcase #\S) "s"))
  33   (assert (string= (string-downcase #\.) "."))
  34   (assert (string= (string-capitalize 'ya-str-desig :end 5) "Ya-StR-DESIG")))
  35
  36 ;;; basic destructive case operations
  37 (with-test (:name (nstring-upcase nstring-downcase nstring-capitalize :smoke))
  38   (let ((nstring (make-array 5 :element-type 'character :fill-pointer 0)))
  39     (vector-push-extend #\c nstring)
  40     (vector-push-extend #\a nstring)
  41     (vector-push-extend #\t nstring)
  42     (nstring-upcase nstring)
  43     (assert (string= nstring "CAT"))
  44     (setf (fill-pointer nstring) 2)
  45     (nstring-downcase nstring :start 1)
  46     (setf (fill-pointer nstring) 3)
  47     (assert (string= nstring "CaT"))
  48     (nstring-capitalize nstring)
  49     (assert (string= nstring "Cat"))))
  50
  51 #|
  52 (VECTOR NIL)s are strings only if you believe that the definition involving union
  53 types prevails over the ample amount of exposition in the spec, as well as utility
  54 of the resulting strings, and common sense.
  55
  56 I tested 9 other implementations, and 7 of them agree that:
  57   (SUBTYPEP '(SIMPLE-ARRAY NIL (*)) 'STRING) => NIL and T
  58
  59 They have differing behaviors as to effect of make-string and make-array as follows:
  60
  61 Allegro (10.1 Free Express Edition):
  62  (SIMPLE-ARRAY NIL (*)) exists but does not satisfy STRINGP
  63  (make-string 1 :element-type NIL) returns a (SIMPLE-ARRAY CHARACTER (1))
  64
  65 Clasp (built from git rev 6b8047c2 @ 2020-10-22):
  66  (make-array 1 :element-type NIL) signals error
  67  (make-string 1 :element-type NIL) returns a (SIMPLE-ARRAY CHARACTER (1))
  68
  69 Clozure (v1.12):
  70  (make-array 1 :element-type NIL) returns (SIMPLE-VECTOR 1)
  71  (make-string 1 :element-type NIL) returns a (SIMPLE-BASE-STRING 1)
  72
  73 CMUCL (version 20d Unicode):
  74  (make-array 1 :element-type nil) returns (SIMPLE-BASE-STRING 1)
  75  as does MAKE-STRING.
  76
  77 ECL (version 20.4.24):
  78  (make-array 1 :element-type NIL) says
  79   "ECL does not support arrays with element type NIL"
  80  (make-string 1 :element-type NIL) returns a (SIMPLE-ARRAY BASE-CHAR (1))
  81
  82 GCL (version 2.6.12 CLtL1):
  83  (type-of (make-array 1 :element-type nil)) => VECTOR
  84  (array-element-type (make-string 1 :element-type nil)) => STRING-CHAR
  85
  86 MKCL (version 1.1.11):
  87  (make-array 1 :element-type NIL) returns a (VECTOR NIL 1)
  88  (make-string 1 :element-type NIL) returns a (SIMPLE-BASE-STRING 1)
  89
  90 Of the dissenters, they return T and T from the subtypep expression above
  91 though their behavioral differences from MAKE-ARRAY to MAKE-STRING
  92 present compelling evidence that at least in their API they disfavor considering
  93 an object a string if it has element type NIL, hence MAKE-STRING upgrades NIL
  94 to a nonempty type.
  95 ABCL (version 1.7.1):
  96  (type-of (make-array 1 :element-type nil)) => (NIL-VECTOR 1)
  97  (type-of (make-string 1 :element-type nil)) => (SIMPLE-BASE-STRING 1)
  98  Also: (make-string 1 :element-type 'ratio) => "^@" ; the type is just ignored
  99 CLISP (version 2.49.92):
 100  (type-of (make-array 1 :element-type nil)) => (SIMPLE-ARRAY NIL (1))
 101  (type-of (make-string 1 :element-type nil)) => (SIMPLE-BASE-STRING 1)
 102
 103 And one more Lisp implementation which matches none of the above-
 104 Lispworks personal edition 7.1:
 105   (make-array 1 :element-type nil) signals
 106     ERROR: (ARRAY NIL) is an illegal type specifier.
 107   (make-string 1 :element-type nil) signals
 108     ERROR: (ARRAY NIL) is an illegal type specifier.
 109   (subtypep '(vector nil) 'string) signals
 110     ERROR: (ARRAY NIL (*)) is an illegal type specifier.
 111
 112 Hence (SIMPLE-ARRAY NIL (*)) is most plausibly not regarded as a string,
 113 the ANSI compliance test suite notwithstanding.
 114 And the range of implementation choices suggest that users can not reasonably
 115 claim that any particular result from these edge cases constitutes a bug.
 116 |#
 117 (with-test (:name (vector nil))
 118   (assert (not (stringp (make-array 0 :element-type nil))))
 119   (assert (not (subtypep (class-of (make-array 1 :element-type nil))
 120                          (find-class 'string)))))
 121
 122 (with-test (:name (make-string :element-type t type-error))
 123   (multiple-value-bind (fun failure-p warnings)
 124       (checked-compile '(lambda () (make-string 5 :element-type t))
 125                        :allow-failure t :allow-warnings t)
 126     (assert failure-p)
 127     (assert (= 1 (length warnings)))
 128     ;; It's not clear why this function should be expected to return a TYPE-ERROR.
 129     ;; There is no object created which is of the wrong type,
 130     ;; and the type of the legal value of ELEMENT-TYPE isn't really in question
 131     ;; nor is the best way to describe what you can't pass.
 132     (assert-error (funcall fun) #|type-error|#)))
 133
 134 ;; MISC.574
 135 (with-test (:name (string<= base-string :optimized))
 136   (assert (= (funcall (lambda (a)
 137                         (declare (optimize (speed 3) (safety 1)
 138                                            (debug 1) (space 2))
 139                                  (fixnum a))
 140                         (string<= (coerce "e99mo7yAJ6oU4" 'base-string)
 141                                   (coerce "aaABAAbaa" 'base-string)
 142                                   :start1 a))
 143                       9)
 144              9)))
 145
 146 ;; String trimming.
 147 (with-test (:name (string-trim 1))
 148   (flet ((make-test (string left right both)
 149            (macrolet ((check (fun wanted)
 150                         `(let ((result (,fun " " string)))
 151                            (assert (equal result ,wanted))
 152                            (when (equal string ,wanted)
 153                              ;; Check that the original string is
 154                              ;; returned when no changes are needed. Not
 155                              ;; required by the spec, but a desireable
 156                              ;; feature for performance.
 157                              (assert (eql result string))))))
 158              ;; Check the functional implementations
 159              (locally
 160                  (declare (notinline string-left-trim string-right-trim
 161                                      string-trim))
 162                (check string-left-trim left)
 163                (check string-right-trim right)
 164                (check string-trim both))
 165              ;; Check the transforms
 166              (locally
 167                  (declare (type simple-string string))
 168                (check string-left-trim left)
 169                (check string-right-trim right)
 170                (check string-trim both)))))
 171     (make-test "x " "x " "x" "x")
 172     (make-test " x" "x" " x" "x")
 173     (make-test " x " "x " " x" "x")
 174     (make-test " x x " "x x " " x x" "x x")))
 175
 176
 177 ;;; Trimming should respect fill-pointers
 178 (with-test (:name (string-trim :fill-pointer))
 179   (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type
 180                         'character :fill-pointer 7))
 181          (s2 (string-left-trim "ab" s))
 182          (s3 (string-right-trim "ab" s)))
 183     (assert (equal "abcdaba" s))
 184     (assert (equal "cdaba" s2))
 185     (assert (equal "abcd" s3))))
 186
 187 ;;; Trimming should replace displacement offsets
 188 (with-test (:name (string-trim :displaced))
 189  (let* ((etype 'base-char)
 190         (s0
 191           (make-array '(6) :initial-contents "abcaeb" :element-type etype))
 192         (s
 193           (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1)))
 194    (assert (equal "bc" (string-right-trim "ab" s)))
 195    (assert (equal "bca" s))
 196    (assert (equal "abcaeb" s0))))
 197
 198 (with-test (:name (string-trim :nothing-to-do))
 199   ;; Trimming non-simple-strings when there is nothing to do
 200   (let ((a (make-array 10 :element-type 'character :initial-contents "abcde00000" :fill-pointer 5)))
 201     (assert (equal "abcde" (string-right-trim "Z" a))))
 202
 203   ;; Trimming non-strings when there is nothing to do.
 204   (string-right-trim " " #\a))
 205
 206 (with-test (:name :nil-vector-access)
 207   (let ((nil-vector (make-array 10 :element-type nil)))
 208     ;; Nowhere is it specified that PRINT-OBJECT on a VECTOR-NIL must
 209     ;; access the contents and signal an error. So WRITE works fine.
 210     (assert (write-to-string nil-vector))
 211     (let ((*read-eval* nil))
 212       (assert-error (write-to-string nil-vector :readably t)))
 213     (flet ((test (accessor)
 214              (assert-error
 215               (funcall (checked-compile
 216                         `(lambda ()
 217                            (,accessor (make-array 10 :element-type nil) 0))))
 218               sb-kernel:nil-array-accessed-error)
 219              (assert-error
 220               (funcall (checked-compile `(lambda (x) (,accessor x 0)))
 221                        nil-vector)
 222               sb-kernel:nil-array-accessed-error)))
 223       (test 'aref)
 224       ;; (test 'char)  ; you'll get a TYPE-ERROR instead.
 225       ;; (test 'schar) ; ditto
 226       (test 'row-major-aref))))
 227
 228 (with-test (:name :nil-array-access)
 229   (let ((nil-array (make-array '(10 10) :element-type nil)))
 230     (assert (write-to-string nil-array))
 231     (let ((*read-eval* nil))
 232       (assert-error (write-to-string nil-array :readably t)))
 233     (flet ((test (accessor args)
 234              (assert-error
 235               (funcall (checked-compile
 236                         `(lambda ()
 237                            (,accessor (make-array '(10 10) :element-type nil)
 238                                       ,@(make-list args :initial-element 0)))))
 239               sb-kernel:nil-array-accessed-error)
 240              (assert-error
 241               (funcall (checked-compile
 242                         `(lambda (x)
 243                            (,accessor x ,@(make-list args :initial-element 0))))
 244                        nil-array)
 245               sb-kernel:nil-array-accessed-error)))
 246       (test 'aref 2)
 247       (test 'row-major-aref 1))))
 248
 249 (with-test (:name (string-equal :two-arg))
 250   (flet ((check (function expected)
 251            (assert (eq (funcall
 252                         (checked-compile `(lambda (x y) (,function x y)))
 253                         "a"
 254                         (make-array 1 :element-type 'character
 255                                     :displaced-to "bA"
 256                                     :displaced-index-offset 1))
 257                        expected))))
 258     (check 'string-equal     t)
 259     (check 'string-not-equal nil)))
 260
 261 (with-test (:name :write-to-string-base-stringize)
 262   (let ((result (funcall (checked-compile `(lambda (x) (write-to-string x))) 33d0)))
 263     (assert (equal result "33.0d0"))
 264     (assert (typep result 'simple-base-string))))
 265
 266 (with-test (:name :make-string-fail-early)
 267   ;; This used to get "Heap exhausted"
 268   (assert-error
 269    (funcall (opaque-identity 'make-string) (truncate array-total-size-limit 2)
 270             :element-type '(unsigned-byte 8))))
 271
 272 (with-test (:name :make-string-pedantic-initial-element)
 273   ;; This used to be silently accepted (at least in the interpreter)
 274   (assert-error
 275    (funcall (opaque-identity 'make-string) 10
 276             :element-type '(member #\a #\b #\c) :initial-element nil))
 277   ;; As was this
 278   (assert-error
 279    (funcall (opaque-identity 'make-string) 10
 280             :element-type '(member #\a #\b #\c) :initial-element #\x)))
 281
 282 (with-test (:name :%sp-string-compare-argument-order)
 283   (checked-compile-and-assert
 284    ()
 285    `(lambda (x)
 286       (string/= "_" (the simple-string x)))
 287    (("_") nil)
 288    (("a") 0)))
 289
 290 (with-test (:name :string=-derive-type)
 291   (macrolet
 292       ((check (fun expected)
 293          `(assert
 294            (equal (second
 295                    (third
 296                     (sb-kernel:%simple-fun-type
 297                      (checked-compile '(lambda (x y)
 298                                         (declare (ignorable x y))
 299                                         ,fun)))))
 300                   ',expected))))
 301     (check (string= (the (simple-string 1) x)
 302                     (the (simple-string 2) y)) null)
 303     (check (string= (the (simple-base-string 1) x)
 304                     (the (simple-base-string 2) y)) null)
 305     (check (string= (the (simple-array character (1)) x)
 306                     (the (simple-array character (2)) y)) null)))
 307
 308 (with-test (:name :string/=-derive-type)
 309   (macrolet
 310       ((check (fun expected)
 311          `(assert
 312            (type-specifiers-equal
 313             (second
 314              (third
 315               (sb-kernel:%simple-fun-type
 316                (checked-compile '(lambda (x y)
 317                                   (declare (ignorable x y))
 318                                   ,fun)))))
 319             ',expected))))
 320     (check (string/= (the (simple-string 4) x)
 321                      (the (simple-string 1) y)
 322                      :start1 1 :end1 * :end2 0) (or (integer 1 1) null))))
 323
 324 #+sb-unicode
 325 (with-test (:name :possibly-base-stringize)
 326   ;;  simple-base, base non-simple
 327   (let* ((str (make-string 4 :element-type 'base-char))
 328          (res (sb-int:possibly-base-stringize str)))
 329     (assert (eq res str)))
 330   (let* ((str (make-array 4 :element-type 'base-char
 331                           :displaced-to (make-string 4 :element-type 'base-char)))
 332          (res (sb-int:possibly-base-stringize str)))
 333     (assert (and (sb-int:neq res str) (typep res 'simple-base-string))))
 334   ;;  simple-character w/ASCII only, non-simple character w/ASCII only
 335   (let* ((str (make-string 4))
 336          (res (sb-int:possibly-base-stringize str)))
 337     (assert (and (sb-int:neq res str) (typep res 'simple-base-string))))
 338   (let* ((str (make-array 4 :element-type 'character
 339                           :displaced-to (make-string 4)))
 340          (res (sb-int:possibly-base-stringize str)))
 341     (assert (and (sb-int:neq res str) (typep res 'simple-base-string))))
 342   ;; simple-character w/Unicode, non-simple character w/Unicode
 343   (let* ((str (make-string 4 :initial-element #\u3f4))
 344          (res (sb-int:possibly-base-stringize str)))
 345     (assert (and (eq res str) (typep res 'sb-kernel:simple-character-string))))
 346   (let* ((str (make-array 4 :element-type 'character
 347                           :displaced-to
 348                           (make-string 4 :initial-element #\u3f5)))
 349          (res (sb-int:possibly-base-stringize str)))
 350     (assert (and (sb-int:neq res str) (typep res 'sb-kernel:simple-character-string)))))
 351 (with-test (:name :possibly-base-stringize-dx :skipped-on :interpreter)
 352   (let* ((str (make-string 4 :element-type 'base-char))
 353          (res (sb-int:possibly-base-stringize-to-heap str)))
 354     (declare (dynamic-extent str))
 355     (assert (if (sb-kernel:dynamic-space-obj-p str)
 356                 (eq res str)
 357                 (not (eq res str))))))
 358
 359 (with-test (:name :string-case-type)
 360   (macrolet
 361       ((check (fun expected)
 362          `(assert
 363            (type-specifiers-equal
 364             (second
 365              (third
 366               (sb-kernel:%simple-fun-type
 367                (checked-compile '(lambda (x)
 368                                   (declare (ignorable x))
 369                                   ,fun)))))
 370             ',expected))))
 371     (check (string-upcase nil)
 372            (simple-base-string 3))
 373     (check (string-upcase (the symbol x))
 374            simple-string)
 375     (check (string-upcase (the character x))
 376            (simple-string 1))))