Import Upstream version 2a6upstream/2a6

1 files changed, 45 insertions, 0 deletions

diff --git a/strcase.scm b/strcase.scm
new file mode 100644
index 0000000..f223527
--- /dev/null
+++ b/strcase.scm
@@ -0,0 +1,45 @@
+;;; "strcase.scm" String casing functions.
+; Written 1992 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
+;
+; This code is in the public domain.
+
+; Modified by Aubrey Jaffer Nov 1992.
+; Authors of the original version were Ken Dickey and Aubrey Jaffer.
+
+;string-upcase, string-downcase, string-capitalize
+; are obvious string conversion procedures and are non destructive.
+;string-upcase!, string-downcase!, string-capitalize!
+; are destructive versions.
+
+(define (string-upcase! str)
+  (do ((i (- (string-length str) 1) (- i 1)))
+      ((< i 0) str)
+    (string-set! str i (char-upcase (string-ref str i)))))
+
+(define (string-upcase str)
+  (string-upcase! (string-copy str)))
+  
+(define (string-downcase! str)
+  (do ((i (- (string-length str) 1) (- i 1)))
+      ((< i 0) str)
+    (string-set! str i (char-downcase (string-ref str i)))))
+
+(define (string-downcase str)
+  (string-downcase! (string-copy str)))
+
+(define (string-capitalize! str)	; "hello" -> "Hello"
+  (let ((non-first-alpha #f)		; "hELLO" -> "Hello"
+	(str-len (string-length str)))	; "*hello" -> "*Hello"
+    (do ((i 0 (+ i 1)))			; "hello you" -> "Hello You"
+	((= i str-len) str)
+      (let ((c (string-ref str i)))
+	(if (char-alphabetic? c)
+	    (if non-first-alpha
+		(string-set! str i (char-downcase c))
+		(begin
+		  (set! non-first-alpha #t)
+		  (string-set! str i (char-upcase c))))
+	    (set! non-first-alpha #f))))))
+
+(define (string-capitalize str)
+  (string-capitalize! (string-copy str)))