Add support for quoting keyword-like symbols.

diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm
new file mode 100644 (file)
index 0000000..9774c38
--- /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))
+\f
+
+;;; *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 c93993f69b5fc4c39a4f0adb91e1aa9eb2592c26..261aca1545eede54b27e2949dedda2a7f99985f9 100644 (file)
--- 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 35444737da23a878cad2fefa6bfb9e54dc9f727b..9a9fb28d09a1749bc6b9ac687e17f98e9c7d1ea7 100644 (file)
--- 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)))