Add basic support for converting between CamelCase and lisp syntax.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 55fc550f52acac230f7e03865e4a6cbdf37f767a..5f419c0fe5b8d64179fc94570dfefd98c4affc84 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.685 2008/09/21 23:50:31 cph Exp $
+$Id: runtime.pkg,v 14.686 2008/09/23 23:59:19 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -773,6 +773,7 @@ USA.
          (vector-8b? string?)
          allocate-external-string
          burst-string
+         camel-case-string->lisp
          char->string
          decorated-string-append
          error:not-string
@@ -787,6 +788,7 @@ USA.
          guarantee-substring-start-index
          guarantee-xstring
          hexadecimal->vector-8b
+         lisp-string->camel-case
          list->string
          make-string
          make-vector-8b

diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index e8e866aabf50a8b1969b2e7495696f1a8a004014..f693fa573cda2d86d1e7eb0032912de2b6b252fb 100644 (file)
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.69 2008/07/23 11:10:56 cph Exp $
+$Id: string.scm,v 14.70 2008/09/23 23:59:23 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -654,6 +654,44 @@ USA.
          (%substring-upcase! string index (fix:+ index 1))
          (%substring-downcase! string (fix:+ index 1) end)))))
 \f
+;;;; CamelCase support
+
+(define (camel-case-string->lisp string)
+  (call-with-input-string string
+    (lambda (input)
+      (call-with-narrow-output-string
+       (lambda (output)
+         (let loop ((prev #f))
+           (let ((c (read-char input)))
+             (if (not (eof-object? c))
+                 (begin
+                   (if (and prev (char-upper-case? c))
+                       (write-char #\- output))
+                   (write-char (char-downcase c) output)
+                   (loop c))))))))))
+
+(define (lisp-string->camel-case string #!optional upcase-initial?)
+  (call-with-input-string string
+    (lambda (input)
+      (call-with-narrow-output-string
+       (lambda (output)
+         (let loop
+             ((upcase?
+               (if (default-object? upcase-initial?)
+                   #t
+                   upcase-initial?)))
+           (let ((c (read-char input)))
+             (if (not (eof-object? c))
+                 (if (char-alphabetic? c)
+                     (begin
+                       (write-char (if upcase? (char-upcase c) c) output)
+                       (loop #f))
+                     (begin
+                       (if (or (char-numeric? c)
+                               (eq? c #\_))
+                           (write-char c output))
+                       (loop #t)))))))))))
+\f
 ;;;; Replace
 
 (define (string-replace string char1 char2)