Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;; "strcase.scm" String casing functions. |
2 | ; Written 1992 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) | |
3 | ; | |
4 | ; This code is in the public domain. | |
5 | ||
6 | ; Modified by Aubrey Jaffer Nov 1992. | |
7 | ; SYMBOL-APPEND added by A. Jaffer 2001. | |
8 | ; Authors of the original version were Ken Dickey and Aubrey Jaffer. | |
9 | ||
10 | ;string-upcase, string-downcase, string-capitalize | |
11 | ; are obvious string conversion procedures and are non destructive. | |
12 | ;string-upcase!, string-downcase!, string-capitalize! | |
13 | ; are destructive versions. | |
14 | ||
15 | (define (string-upcase! str) | |
16 | (do ((i (- (string-length str) 1) (- i 1))) | |
17 | ((< i 0) str) | |
18 | (string-set! str i (char-upcase (string-ref str i))))) | |
19 | ||
20 | (define (string-upcase str) | |
21 | (string-upcase! (string-copy str))) | |
22 | ||
23 | (define (string-downcase! str) | |
24 | (do ((i (- (string-length str) 1) (- i 1))) | |
25 | ((< i 0) str) | |
26 | (string-set! str i (char-downcase (string-ref str i))))) | |
27 | ||
28 | (define (string-downcase str) | |
29 | (string-downcase! (string-copy str))) | |
30 | ||
31 | (define (string-capitalize! str) ; "hello" -> "Hello" | |
32 | (let ((non-first-alpha #f) ; "hELLO" -> "Hello" | |
33 | (str-len (string-length str))) ; "*hello" -> "*Hello" | |
34 | (do ((i 0 (+ i 1))) ; "hello you" -> "Hello You" | |
35 | ((= i str-len) str) | |
36 | (let ((c (string-ref str i))) | |
37 | (if (char-alphabetic? c) | |
38 | (if non-first-alpha | |
39 | (string-set! str i (char-downcase c)) | |
40 | (begin | |
41 | (set! non-first-alpha #t) | |
42 | (string-set! str i (char-upcase c)))) | |
43 | (set! non-first-alpha #f)))))) | |
44 | ||
45 | (define (string-capitalize str) | |
46 | (string-capitalize! (string-copy str))) | |
47 | ||
48 | (define string-ci->symbol | |
49 | (let ((s2cis (if (equal? "x" (symbol->string 'x)) | |
50 | string-downcase string-upcase))) | |
51 | (lambda (str) (string->symbol (s2cis str))))) | |
52 | ||
53 | (define symbol-append | |
54 | (let ((s2cis (if (equal? "x" (symbol->string 'x)) | |
55 | string-downcase string-upcase))) | |
56 | (lambda args | |
57 | (string->symbol | |
58 | (apply string-append | |
59 | (map | |
60 | (lambda (obj) | |
61 | (cond ((string? obj) (s2cis obj)) | |
62 | ((number? obj) (s2cis (number->string obj))) | |
63 | ((symbol? obj) (symbol->string obj)) | |
64 | ((not obj) "") | |
65 | (else (slib:error 'wrong-type-to 'symbol-append obj)))) | |
66 | args)))))) |