From e7c0037516c1a23f4bb48a99bfb5fa5d1781b8b1 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 17 Jan 2001 14:45:42 +0000 Subject: [PATCH] 0.6.10.1: made revised STRING-FOO functions accept string designators instead of just strings (thanks to MNA bug report) --- BUGS | 20 ++++++++--------- src/code/string.lisp | 56 ++++++++++++++++++++++++------------------------ tests/string.pure.lisp | 22 +++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 60 insertions(+), 40 deletions(-) diff --git a/BUGS b/BUGS index 353c71a..2f2a651 100644 --- a/BUGS +++ b/BUGS @@ -844,17 +844,15 @@ Error in function C::GET-LAMBDA-TO-COMPILE: :ELEMENT-TYPE, but in sbcl-0.6.9 this is not defined for WITH-OUTPUT-TO-STRING. -77: - As reported by Martin Atzmueller on sbcl-devel 2000-01-09, - DEF-ALIEN-VARIABLE doesn't work. With either the example in the - old CMU CL docs, - (def-alien-variable "errno" integer) - or another test avoiding any peculiarities of modern errno-as-macro - implementations, - (def-alien-variable "from_space" integer) - in sbcl-0.6.9 the operation fails with - TYPE-ERROR in SB-KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER: - NIL is not of type SB-KERNEL:LEXENV. +78: + ANSI says in one place that type declarations can be abbreviated even + when the type name is not a symbol, e.g. + (DECLAIM ((VECTOR T) *FOOVECTOR*)) + SBCL doesn't support this. But ANSI says in another place that this + isn't allowed. So it's not clear this is a bug after all. (See the + e-mail on cmucl-help@cons.org on 2001-01-16 and 2001-01-17 from WHN + and Pierre Mai.) + KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/src/code/string.lisp b/src/code/string.lisp index 3ffae90..0482f5d 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -352,61 +352,61 @@ (setf (schar string i) fill-char)) (make-string count))) -(flet ((frob (string start end) - (declare (string string) (index start) (type (or index null end))) - (let ((save-header string)) +(flet ((%upcase (string start end) + (declare (string string) (index start) (type sequence-end end)) + (let ((saved-header string)) (with-one-string (string start end) (do ((index start (1+ index))) ((= index (the fixnum end))) (declare (fixnum index)) (setf (schar string index) (char-upcase (schar string index))))) - save-header))) + saved-header))) (defun string-upcase (string &key (start 0) end) - (frob (copy-seq string) start end)) + (%upcase (copy-seq (string string)) start end)) (defun nstring-upcase (string &key (start 0) end) - (frob string start end)) + (%upcase string start end)) ) ; FLET -(flet ((frob (string start end) - (declare (string string) (index start) (type (or index null end))) - (let ((save-header string)) +(flet ((%downcase (string start end) + (declare (string string) (index start) (type sequence-end end)) + (let ((saved-header string)) (with-one-string (string start end) (do ((index start (1+ index))) ((= index (the fixnum end))) (declare (fixnum index)) (setf (schar string index) (char-downcase (schar string index))))) - save-header))) + saved-header))) (defun string-downcase (string &key (start 0) end) - (frob (copy-seq string) start end)) + (%downcase (copy-seq (string string)) start end)) (defun nstring-downcase (string &key (start 0) end) - (frob string start end)) + (%downcase string start end)) ) ; FLET -(flet ((frob (string start end) - (declare (string string) (index start) (type (or index null end))) - (let ((save-header string)) +(flet ((%capitalize (string start end) + (declare (string string) (index start) (type sequence-end end)) + (let ((saved-header string)) (with-one-string (string start end) (do ((index start (1+ index)) - (newword t) - (char ())) + (new-word? t) + (char nil)) ((= index (the fixnum end))) (declare (fixnum index)) (setq char (schar string index)) (cond ((not (alphanumericp char)) - (setq newword t)) - (newword - ;; CHAR is the first case-modifiable character after - ;; a sequence of non-case-modifiable characters. - (setf (schar string index) (char-upcase char)) - (setq newword ())) - (t - (setf (schar string index) (char-downcase char)))))) - save-header))) + (setq new-word? t)) + (new-word? + ;; CHAR is the first case-modifiable character after + ;; a sequence of non-case-modifiable characters. + (setf (schar string index) (char-upcase char)) + (setq new-word? nil)) + (t + (setf (schar string index) (char-downcase char)))))) + saved-header))) (defun string-capitalize (string &key (start 0) end) - (frob (copy-seq string) start end)) + (%capitalize (copy-seq (string string)) start end)) (defun nstring-capitalize (string &key (start 0) end) - (frob string start end)) + (%capitalize string start end)) ) ; FLET (defun string-left-trim (char-bag string) diff --git a/tests/string.pure.lisp b/tests/string.pure.lisp index c44ffb3..5d7fd11 100644 --- a/tests/string.pure.lisp +++ b/tests/string.pure.lisp @@ -13,6 +13,7 @@ (in-package "CL-USER") +;;; basic non-destructive case operations (assert (string= (string-upcase "This is a test.") "THIS IS A TEST.")) (assert (string= (string-downcase "This is a test.") "this is a test.")) (assert (string= (string-capitalize "This is a test.") "This Is A Test.")) @@ -23,3 +24,24 @@ "Is this 900-sex-hott, please?")) (assert (string= (string-capitalize "Is this 900-Sex-hott, please?") "Is This 900-Sex-Hott, Please?")) + +;;; The non-destructive case operations accept string designators, not +;;; just strings. +(assert (string= (string-upcase '|String designator|) "STRING DESIGNATOR")) +(assert (string= (string-downcase #\S) "s")) +(assert (string= (string-downcase #\.) ".")) +(assert (string= (string-capitalize 'ya-str-desig :end 5) "Ya-StR-DESIG")) + +;;; basic destructive case operations +(let ((nstring (make-array 5 :element-type 'character :fill-pointer 0))) + (vector-push-extend #\c nstring) + (vector-push-extend #\a nstring) + (vector-push-extend #\t nstring) + (nstring-upcase nstring) + (assert (string= nstring "CAT")) + (setf (fill-pointer nstring) 2) + (nstring-downcase nstring :start 1) + (setf (fill-pointer nstring) 3) + (assert (string= nstring "CaT")) + (nstring-capitalize nstring) + (assert (string= nstring "Cat"))) diff --git a/version.lisp-expr b/version.lisp-expr index 833805f..2178b1f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.10" +"0.6.10.1" -- 1.7.10.4