From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Mon, 15 Mar 2010 20:15:01 +0000 (-0700)
Subject: Implement keyword objects.
X-Git-Tag: 20100708-Gtk~92
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6aae342611af936717d50c02444e712c7d83e868;p=mit-scheme.git

Implement keyword objects.
---

diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm
index 9774c3894..be8fca217 100644
--- a/src/runtime/keyword.scm
+++ b/src/runtime/keyword.scm
@@ -26,9 +26,46 @@ USA.
 
 (declare (usual-integrations))
 
+(define (initialize-package!)
+  (set! *keyword-intern-table* (make-string-hash-table)))
+
+(define *keyword-intern-table*)
 
 ;;; *KEYWORD-STYLE*
 ;;
 ;;  Should be one of DSSSL CL BOTH SRFI-88 or #f.
 (define *keyword-style* #f)
 
+(define-structure (keyword
+		   (constructor %make-keyword (name))
+		   (conc-name keyword/)
+		   (print-procedure (lambda (state object)
+				      (keyword-unparser state object))))
+  (name #f read-only #t))
+
+(define-guarantee keyword "Keyword object")
+
+(define (keyword-unparser state object)
+  (let ((port (unparser-state/port state)))
+    (case *keyword-style*
+      ((BOTH CL)
+       (write-char #\: port)
+       (write (keyword/name object) port))
+      ((DSSSL SRFI-88) 
+       (write (keyword/name object) port)
+       (write-char #\: port))
+      (else
+       (write-string "#[keyword " port)
+       (write (keyword/name object) port)
+       (write-string "]" port)))))
+
+(define (keyword->string keyword)
+  (guarantee-keyword keyword 'keyword->string)
+  (symbol->string (keyword/name keyword)))
+
+(define (string->keyword string)
+  (guarantee-string string 'string->keyword)
+  (or (hash-table/get *keyword-intern-table* string #f)
+      (let ((new-keyword (%make-keyword (string->symbol string))))
+	(hash-table/put! *keyword-intern-table* (string-copy string) new-keyword)
+	new-keyword)))
\ No newline at end of file
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index be0db5b8c..4cf3a4ca5 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -497,6 +497,7 @@ USA.
    (RUNTIME SIMPLE-FILE-OPS)
    (OPTIONAL (RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES!)
    ;; Syntax
+   (RUNTIME KEYWORD)
    (RUNTIME NUMBER-PARSER)
    (RUNTIME PARSER)
    ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD!)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 261aca154..21fb1a8d5 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -281,7 +281,11 @@ USA.
   (parent (runtime))
   (export ()
 	  *keyword-style*
-	  ))
+	  keyword?
+	  keyword->string
+	  string->keyword
+	  )
+  (initialization (initialize-package!)))
 
 (define-package (runtime miscellaneous-global)
   (files "global")