Implement keyword objects.

diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm
index 9774c38945a374add5092271888c0ad0c57f4e03..be8fca217786afdb90a45497f9a5fb4c4a2a60e2 100644 (file)
--- a/src/runtime/keyword.scm
+++ b/src/runtime/keyword.scm
@@ -26,9 +26,46 @@ USA.
 
 (declare (usual-integrations))
 \f
+(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 be0db5b8c4aac8e19cf8c7e2f6962d2722b2aecc..4cf3a4ca54d02658f7a9836ae7e50923a42cab37 100644 (file)
--- 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 261aca1545eede54b27e2949dedda2a7f99985f9..21fb1a8d57b87a9487bd1debd0b45ff05a0ce42f 100644 (file)
--- 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")