home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / strcase < prev    next >
Text File  |  1994-05-25  |  1KB  |  44 lines
  1. ;;; "strcase.scm" String casing functions.
  2. ; Copyright (C) Feb 1992 Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
  3.  
  4. ; Modified by Aubrey Jaffer Nov 1992.
  5. ; Authors of the original version were Ken Dickey and Aubrey Jaffer.
  6.  
  7. ;string-upcase, string-downcase, string-capitalize
  8. ; are obvious string conversion procedures and are non destructive.
  9. ;string-upcase!, string-downcase!, string-capitalize!
  10. ; are destructive versions.
  11.  
  12. (define (string-upcase! str)
  13.   (do ((i (- (string-length str) 1) (- i 1)))
  14.       ((< i 0) str)
  15.     (string-set! str i (char-upcase (string-ref str i)))))
  16.  
  17. (define (string-upcase str)
  18.   (string-upcase! (string-copy str)))
  19.   
  20. (define (string-downcase! str)
  21.   (do ((i (- (string-length str) 1) (- i 1)))
  22.       ((< i 0) str)
  23.     (string-set! str i (char-downcase (string-ref str i)))))
  24.  
  25. (define (string-downcase str)
  26.   (string-downcase! (string-copy str)))
  27.  
  28. (define (string-capitalize! str)    ; "hello" -> "Hello"
  29.   (let ((non-first-alpha #f)        ; "hELLO" -> "Hello"
  30.     (str-len (string-length str)))    ; "*hello" -> "*Hello"
  31.     (do ((i 0 (+ i 1)))            ; "hello you" -> "Hello You"
  32.     ((= i str-len) str)
  33.       (let ((c (string-ref str i)))
  34.     (if (char-alphabetic? c)
  35.         (if non-first-alpha
  36.         (string-set! str i (char-downcase c))
  37.         (begin
  38.           (set! non-first-alpha #t)
  39.           (string-set! str i (char-upcase c))))
  40.         (set! non-first-alpha #f))))))
  41.  
  42. (define (string-capitalize str)
  43.   (string-capitalize! (string-copy str)))
  44.