From 6cbad56ca6f22b14ec5cb71aed956ccef049c0a3 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 23 Sep 2008 23:59:23 +0000
Subject: [PATCH] Add basic support for converting between CamelCase and lisp
 syntax.

---
 v7/src/runtime/runtime.pkg |  4 +++-
 v7/src/runtime/string.scm  | 40 +++++++++++++++++++++++++++++++++++++-
 2 files changed, 42 insertions(+), 2 deletions(-)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 55fc550f5..5f419c0fe 100644
--- 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 e8e866aab..f693fa573 100644
--- 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)))))
 
+;;;; 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)))))))))))
+
 ;;;; Replace
 
 (define (string-replace string char1 char2)
-- 
2.25.1