summaryrefslogtreecommitdiffstats
path: root/strcase.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /strcase.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'strcase.scm')
-rw-r--r--strcase.scm45
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)))