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-error (make-string 5 :element-type t))
  78 (assert-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 (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")))
 120
 121
 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))))
 131
 132 ;;; Trimming should replace displacement offsets
 133 (with-test (:name :string-trim.displaced)
 134  (let* ((etype 'base-char)
 135         (s0
 136           (make-array '(6) :initial-contents "abcaeb" :element-type etype))
 137         (s
 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))))
 142
 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))))
 147
 148   ;; Trimming non-strings when there is nothing to do.
 149   (string-right-trim " " #\a))
 150
 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))))
 169
 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))))
 187
 188 (with-test (:name :two-arg-string-equal)
 189   (assert (funcall
 190            (checked-compile
 191             (lambda (x y)
 192               (string-equal x y)))
 193            "a"
 194            (make-array 1 :element-type 'character
 195                          :displaced-to "bA"
 196                          :displaced-index-offset 1)))
 197   (assert (not (funcall
 198                 (checked-compile
 199                  (lambda (x y)
 200                    (string-not-equal x y)))
 201                 "a"
 202                 (make-array 1 :element-type 'character
 203                               :displaced-to "bA"
 204                               :displaced-index-offset 1)))))