X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fstring.pure.lisp;h=89e98066c94daf1cff3700ee4f4f748d5a1e4b0e;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=1b659fdc22b4e7ca6e6ecf5d6602121fd4c0c127;hpb=5cc68148d1a5f9bacf4eb12e396b680d992fc2c2;p=sbcl.git

diff --git a/tests/string.pure.lisp b/tests/string.pure.lisp
index 1b659fd..89e9806 100644
--- a/tests/string.pure.lisp
+++ b/tests/string.pure.lisp
@@ -6,7 +6,7 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
@@ -18,12 +18,12 @@
 (assert (string= (string-downcase   "This is a test.") "this is a test."))
 (assert (string= (string-capitalize "This is a test.") "This Is A Test."))
 (assert (string= (string-upcase "Is this 900-Sex-hott, please?" :start 3)
-		 "Is THIS 900-SEX-HOTT, PLEASE?"))
+                 "Is THIS 900-SEX-HOTT, PLEASE?"))
 (assert (string= (string-downcase "Is this 900-Sex-hott, please?"
-				  :start 10 :end 16)
-		 "Is this 900-sex-hott, please?"))
+                                  :start 10 :end 16)
+                 "Is this 900-sex-hott, please?"))
 (assert (string= (string-capitalize "Is this 900-Sex-hott, please?")
-		 "Is This 900-Sex-Hott, Please?"))
+                 "Is This 900-Sex-Hott, Please?"))
 
 ;;; The non-destructive case operations accept string designators, not
 ;;; just strings.
@@ -54,36 +54,94 @@
 (assert (not (typep (make-string 4 :element-type nil) 'simple-base-string)))
 
 (assert (subtypep (class-of (make-array 1 :element-type nil))
-		  (find-class 'string)))
+                  (find-class 'string)))
 (assert (subtypep (class-of (make-array 2 :element-type nil :fill-pointer 1))
-		  (find-class 'string)))
+                  (find-class 'string)))
 
 (assert (string= "" (make-array 0 :element-type nil)))
 (assert (string/= "a" (make-array 0 :element-type nil)))
 (assert (string= "" (make-array 5 :element-type nil :fill-pointer 0)))
 
 (assert (= (sxhash "")
-	   (sxhash (make-array 0 :element-type nil))
-	   (sxhash (make-array 5 :element-type nil :fill-pointer 0))
-	   (sxhash (make-string 0 :element-type nil))))
+           (sxhash (make-array 0 :element-type nil))
+           (sxhash (make-array 5 :element-type nil :fill-pointer 0))
+           (sxhash (make-string 0 :element-type nil))))
 (assert (subtypep (type-of (make-array 2 :element-type nil)) 'simple-string))
 (assert (subtypep (type-of (make-array 4 :element-type nil :fill-pointer t))
-		  'string))
+                  'string))
 
 (assert (eq (intern "") (intern (make-array 0 :element-type nil))))
 (assert (eq (intern "")
-	    (intern (make-array 5 :element-type nil :fill-pointer 0))))
+            (intern (make-array 5 :element-type nil :fill-pointer 0))))
 
 (assert (raises-error? (make-string 5 :element-type t)))
 (assert (raises-error? (let () (make-string 5 :element-type t))))
 
 ;; MISC.574
 (assert (= (funcall (lambda (a)
-		      (declare (optimize (speed 3) (safety 1)
-					 (debug 1) (space 2))
-			       (fixnum a))
-		      (string<= (coerce "e99mo7yAJ6oU4" 'base-string)
-				(coerce "aaABAAbaa" 'base-string)
-				:start1 a))
-		    9)
-	   9))
+                      (declare (optimize (speed 3) (safety 1)
+                                         (debug 1) (space 2))
+                               (fixnum a))
+                      (string<= (coerce "e99mo7yAJ6oU4" 'base-string)
+                                (coerce "aaABAAbaa" 'base-string)
+                                :start1 a))
+                    9)
+           9))
+
+;; String trimming.
+
+(flet ((make-test (string left right both)
+         (macrolet ((check (fun wanted)
+                      `(let ((result (,fun " " string)))
+                         (assert (equal result ,wanted))
+                         (when (equal string ,wanted)
+                           ;; Check that the original string is
+                           ;; returned when no changes are needed. Not
+                           ;; required by the spec, but a desireable
+                           ;; feature for performance.
+                           (assert (eql result string))))))
+           ;; Check the functional implementations
+           (locally
+               (declare (notinline string-left-trim string-right-trim
+                                   string-trim))
+             (check string-left-trim left)
+             (check string-right-trim right)
+             (check string-trim both))
+           ;; Check the transforms
+           (locally
+               (declare (type simple-string string))
+             (check string-left-trim left)
+             (check string-right-trim right)
+             (check string-trim both)))))
+  (make-test "x " "x " "x" "x")
+  (make-test " x" "x" " x" "x")
+  (make-test " x " "x " " x" "x")
+  (make-test " x x " "x x " " x x" "x x"))
+
+
+;;; Trimming should respect fill-pointers
+(let* ((s (make-array 9 :initial-contents "abcdabadd" :element-type
+                      'character :fill-pointer 7))
+       (s2 (string-left-trim "ab" s))
+       (s3 (string-right-trim "ab" s)))
+  (assert (equal "abcdaba" s))
+  (assert (equal "cdaba" s2))
+  (assert (equal "abcd" s3)))
+
+;;; Trimming should replace displacement offsets
+(let* ((etype 'base-char)
+             (s0
+              (make-array '(6) :initial-contents "abcaeb" :element-type etype))
+             (s
+              (make-array '(3) :element-type etype :displaced-to s0 :displaced-index-offset 1)))
+  (assert (equal "bc" (string-right-trim "ab" s)))
+  (assert (equal "bca" s))
+  (assert (equal "abcaeb" s0)))
+
+;;; Trimming non-simple-strings when there is nothing to do
+(let ((a (make-array 10 :element-type 'character :initial-contents "abcde00000" :fill-pointer 5)))
+  (assert (equal "abcde" (string-right-trim "Z" a))))
+
+;;; Trimming non-strings when there is nothing to do.
+(string-right-trim " " #\a)
+