From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Mon, 15 Mar 2010 19:26:46 +0000 (-0700)
Subject: Add support for quoting keyword-like symbols.
X-Git-Tag: 20100708-Gtk~93
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=64c3d6ab7fbf9e0e380f67e21634bfe84179662c;p=mit-scheme.git

Add support for quoting keyword-like symbols.
---

diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm
new file mode 100644
index 000000000..9774c3894
--- /dev/null
+++ b/src/runtime/keyword.scm
@@ -0,0 +1,34 @@
+#| -*-Scheme-*-
+
+Copyright (C) 2010 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Keywords
+;;; package: (runtime keyword)
+
+(declare (usual-integrations))
+
+
+;;; *KEYWORD-STYLE*
+;;
+;;  Should be one of DSSSL CL BOTH SRFI-88 or #f.
+(define *keyword-style* #f)
+
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c93993f69..261aca154 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -276,6 +276,13 @@ USA.
 	  int:remainder
 	  int:zero?))
 
+(define-package (runtime keyword)
+  (files "keyword")
+  (parent (runtime))
+  (export ()
+	  *keyword-style*
+	  ))
+
 (define-package (runtime miscellaneous-global)
   (files "global")
   (parent (runtime))
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 35444737d..9a9fb28d0 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -345,7 +345,8 @@ USA.
 		 non-canon-symbol-quoted))
 	    (fix:= (string-length s) 0)
 	    (and (char-set-member? char-set/number-leaders (string-ref s 0))
-		 (string->number s)))
+		 (string->number s))
+	    (looks-like-keyword? s))
 	(begin
 	  (*unparse-char #\|)
 	  (let ((end (string-length s)))
@@ -365,6 +366,17 @@ USA.
 	  (*unparse-char #\|))
 	(*unparse-string s))))
 
+(define (looks-like-keyword? string)
+  (case (environment-lookup *environment* '*KEYWORD-STYLE*)
+    ((BOTH) 
+     (or (char=? (string-ref string 0) #\:)
+	 (char=? (string-ref string (- (string-length string) 1)) #\:)))
+    ((CL)
+     (char=? (string-ref string 0) #\:))
+    ((DSSSL SRFI-88)
+     (char=? (string-ref string (- (string-length string) 1)) #\:))
+    (else #f)))
+
 (define (unparse/character character)
   (if (or *slashify?*
 	  (not (char-ascii? character)))