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 (with-test (:name (string-upcase string-downcase string-capitalize :smoke))
  18   (assert (string= (string-upcase     "This is a test.") "THIS IS A TEST."))
  19   (assert (string= (string-downcase   "This is a test.") "this is a test."))
  20   (assert (string= (string-capitalize "This is a test.") "This Is A Test."))
  21   (assert (string= (string-upcase "Is this 900-Sex-hott, please?" :start 3)
  22                    "Is THIS 900-SEX-HOTT, PLEASE?"))
  23   (assert (string= (string-downcase "Is this 900-Sex-hott, please?"
  24                                     :start 10 :end 16)
  25                    "Is this 900-sex-hott, please?"))
  26   (assert (string= (string-capitalize "Is this 900-Sex-hott, please?")
  27                    "Is This 900-Sex-Hott, Please?")))
  28
  29 ;;; The non-destructive case operations accept string designators, not
  30 ;;; just strings.
  31
  32 (with-test (:name (string-upcase string-downcase string-capitalize :designators))
  33   (assert (string= (string-upcase '|String designator|) "STRING DESIGNATOR"))
  34   (assert (string= (string-downcase #\S) "s"))
  35   (assert (string= (string-downcase #\.) "."))
  36   (assert (string= (string-capitalize 'ya-str-desig :end 5) "Ya-StR-DESIG")))
  37
  38 ;;; basic destructive case operations
  39 (with-test (:name (nstring-upcase nstring-downcase nstring-capitalize :smoke))
  40   (let ((nstring (make-array 5 :element-type 'character :fill-pointer 0)))
  41     (vector-push-extend #\c nstring)
  42     (vector-push-extend #\a nstring)
  43     (vector-push-extend #\t nstring)
  44     (nstring-upcase nstring)
  45     (assert (string= nstring "CAT"))
  46     (setf (fill-pointer nstring) 2)
  47     (nstring-downcase nstring :start 1)
  48     (setf (fill-pointer nstring) 3)
  49     (assert (string= nstring "CaT"))
  50     (nstring-capitalize nstring)
  51     (assert (string= nstring "Cat"))))
  52
  53 ;;; (VECTOR NIL)s are strings.  Tests for that and issues uncovered in
  54 ;;; the process.
  55 (with-test (:name (vector nil))
  56   (assert (typep (make-array 1 :element-type nil) 'string))
  57   (assert (not (typep (make-array 2 :element-type nil) 'base-string)))
  58   (assert (typep (make-string 3 :element-type nil) 'simple-string))
  59   (assert (not (typep (make-string 4 :element-type nil) 'simple-base-string)))
  60
  61   (assert (subtypep (class-of (make-array 1 :element-type nil))
  62                     (find-class 'string)))
  63   (assert (subtypep (class-of (make-array 2 :element-type nil :fill-pointer 1))
  64                     (find-class 'string)))
  65
  66   (assert (string= "" (make-array 0 :element-type nil)))
  67   (assert (string/= "a" (make-array 0 :element-type nil)))
  68   (assert (string= "" (make-array 5 :element-type nil :fill-pointer 0)))
  69
  70   (assert (= (sxhash "")
  71              (sxhash (make-array 0 :element-type nil))
  72              (sxhash (make-array 5 :element-type nil :fill-pointer 0))
  73              (sxhash (make-string 0 :element-type nil))))
  74   (assert (subtypep (type-of (make-array 2 :element-type nil)) 'simple-string))
  75   (assert (subtypep (type-of (make-array 4 :element-type nil :fill-pointer t))
  76                     'string))
  77
  78   (assert (eq (intern "") (intern (make-array 0 :element-type nil))))
  79   (assert (eq (intern "")
  80               (intern (make-array 5 :element-type nil :fill-pointer 0)))))
  81
  82 (with-test (:name (make-string :element-type t type-error))
  83   (multiple-value-bind (fun failure-p warnings)
  84       (checked-compile '(lambda () (make-string 5 :element-type t))
  85                        :allow-failure t :allow-warnings t)
  86     (assert failure-p)
  87     (assert (= 1 (length warnings)))
  88     (assert-error (funcall fun) type-error)))
  89
  90 ;; MISC.574
  91 (with-test (:name (string<= base-string :optimized))
  92   (assert (= (funcall (lambda (a)
  93                         (declare (optimize (speed 3) (safety 1)
  94                                            (debug 1) (space 2))
  95                                  (fixnum a))
  96                         (string<= (coerce "e99mo7yAJ6oU4" 'base-string)
  97                                   (coerce "aaABAAbaa" 'base-string)
  98                                   :start1 a))
  99                       9)
 100              9)))
 101
 102 ;; String trimming.
 103 (with-test (:name (string-trim 1))
 104   (flet ((make-test (string left right both)
 105            (macrolet ((check (fun wanted)
 106                         `(let ((result (,fun " " string)))
 107                            (assert (equal result ,wanted))
 108                            (when (equal string ,wanted)
 109                              ;; Check that the original string is
 110                              ;; returned when no changes are needed. Not
 111                              ;; required by the spec, but a desireable
 112                              ;; feature for performance.
 113                              (assert (eql result string))))))
 114              ;; Check the functional implementations
 115              (locally
 116                  (declare (notinline string-left-trim string-right-trim
 117                                      string-trim))
 118                (check string-left-trim left)
 119                (check string-right-trim right)
 120                (check string-trim both))
 121              ;; Check the transforms
 122              (locally
 123                  (declare (type simple-string string))
 124                (check string-left-trim left)
 125                (check string-right-trim right)
 126                (check string-trim both)))))
 127     (make-test "x " "x " "x" "x")
 128     (make-test " x" "x" " x" "x")
 129     (make-test " x " "x " " x" "x")
 130     (make-test " x x " "x x " " x x" "x x")))
 131
 132
 133 ;;; Trimming should respect fill-pointers
 134 (with-test (:name (string-trim :fill-pointer))
 135   (let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type
 136                         'character :fill-pointer 7))
 137          (s2 (string-left-trim "ab" s))
 138          (s3 (string-right-trim "ab" s)))
 139     (assert (equal "abcdaba" s))
 140     (assert (equal "cdaba" s2))
 141     (assert (equal "abcd" s3))))
 142
 143 ;;; Trimming should replace displacement offsets
 144 (with-test (:name (string-trim :displaced))
 145  (let* ((etype 'base-char)
 146         (s0
 147           (make-array '(6) :initial-contents "abcaeb" :element-type etype))
 148         (s
 149           (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1)))
 150    (assert (equal "bc" (string-right-trim "ab" s)))
 151    (assert (equal "bca" s))
 152    (assert (equal "abcaeb" s0))))
 153
 154 (with-test (:name (string-trim :nothing-to-do))
 155   ;; Trimming non-simple-strings when there is nothing to do
 156   (let ((a (make-array 10 :element-type 'character :initial-contents "abcde00000" :fill-pointer 5)))
 157     (assert (equal "abcde" (string-right-trim "Z" a))))
 158
 159   ;; Trimming non-strings when there is nothing to do.
 160   (string-right-trim " " #\a))
 161
 162 (with-test (:name :nil-vector-access)
 163   (let ((nil-vector (make-array 10 :element-type nil)))
 164     (assert-error (write-to-string nil-vector)
 165                   sb-kernel:nil-array-accessed-error)
 166     (flet ((test (accessor)
 167              (assert-error
 168               (funcall (checked-compile
 169                         `(lambda ()
 170                            (,accessor (make-array 10 :element-type nil) 0))))
 171               sb-kernel:nil-array-accessed-error)
 172              (assert-error
 173               (funcall (checked-compile `(lambda (x) (,accessor x 0)))
 174                        nil-vector)
 175               sb-kernel:nil-array-accessed-error)))
 176       (test 'aref)
 177       (test 'char)
 178       (test 'schar)
 179       (test 'row-major-aref))))
 180
 181 (with-test (:name :nil-array-access)
 182   (let ((nil-array (make-array '(10 10) :element-type nil)))
 183     (assert-error (write-to-string nil-array)
 184                   sb-kernel:nil-array-accessed-error)
 185     (flet ((test (accessor args)
 186              (assert-error
 187               (funcall (checked-compile
 188                         `(lambda ()
 189                            (,accessor (make-array '(10 10) :element-type nil)
 190                                       ,@(make-list args :initial-element 0)))))
 191               sb-kernel:nil-array-accessed-error)
 192              (assert-error
 193               (funcall (checked-compile
 194                         `(lambda (x)
 195                            (,accessor x ,@(make-list args :initial-element 0))))
 196                        nil-array)
 197               sb-kernel:nil-array-accessed-error)))
 198       (test 'aref 2)
 199       (test 'row-major-aref 1))))
 200
 201 (with-test (:name (string-equal :two-arg))
 202   (flet ((check (function expected)
 203            (assert (eq (funcall
 204                         (checked-compile `(lambda (x y) (,function x y)))
 205                         "a"
 206                         (make-array 1 :element-type 'character
 207                                     :displaced-to "bA"
 208                                     :displaced-index-offset 1))
 209                        expected))))
 210     (check 'string-equal     t)
 211     (check 'string-not-equal nil)))