Change keyword implementation to be based on symbols rather than structs.

diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm
index d8ce321265f4e3aaf09429435527f7b6ab1a8352..bf4ff18c5c352014bc22f1fb7127a59d2a4be80f 100644 (file)
--- a/src/runtime/keyword.scm
+++ b/src/runtime/keyword.scm
@@ -28,51 +28,25 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (initialize-package!)
-  (set! *keyword-intern-table* (make-string-hash-table))
-  unspecific)
 
-(define *keyword-intern-table*)
+;; Keywords are really interned symbols with a funny name.  We do it
+;; this way because we need to keep eq-ness when fasdumping and
+;; fasload them.  The self-evaluating property of keywords is handled
+;; by in the syntaxer which simply doesn't recognize them as
+;; identifiers.
 
-(define-structure (keyword
-                  (constructor %make-keyword (name))
-                  (conc-name keyword/)
-                  (print-procedure (lambda (state object)
-                                     (keyword-unparser state object))))
-  ;; logically, the name is a string, but
-  ;; we store it as a symbol so that the standard
-  ;; symbol-quoting conventions work.
-  (name #f read-only #t))
+(define-integrable keyword-prefix "#[keyword]")
 
-(define-guarantee keyword "Keyword object")
+(define (string->keyword string)
+  (guarantee-string string 'string->keyword)
+  (string->symbol (string-append keyword-prefix string)))
 
-(define (keyword-unparser state object)
-  (let ((port (unparser-state/port state)))
-    (case *parser-keyword-style*
-      ((PREFIX)
-       (write-char #\: port)
-       (write (keyword/name object) port))
-      ((SUFFIX)
-       (write (keyword/name object) port)
-       (write-char #\: port))
-      (else
-       (write-string "#[keyword " port)
-       (write (keyword/name object) port)
-       (write-string "]" port)))))
+(define (keyword? object)
+  (and (interned-symbol? object)
+       (string-prefix? keyword-prefix (symbol->string object))))
+
+(define-guarantee keyword "keyword")
 
 (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)))
-
-(define (symbol->keyword symbol)
-  (guarantee-symbol symbol 'symbol->keyword)
-  (string->keyword (symbol->string symbol)))
\ No newline at end of file
+  (string-tail (symbol->string keyword) (string-length keyword-prefix)))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6785ef6782fdf55d2efef560ce8f9129e60350eb..cc6e85d6acc67655848a6918ef89bf4ad8cfd095 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -291,10 +291,7 @@ USA.
   (export ()
          keyword?
          keyword->string
-         string->keyword
-         symbol->keyword
-         )
-  (initialization (initialize-package!)))
+         string->keyword))
 
 (define-package (runtime miscellaneous-global)
   (files "global")

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index af7537b812373d821549ec6542ccf4477d4eab3d..f5686332f5d76f4cdc1940c76302df30bc1ec860 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -113,7 +113,9 @@ USA.
 ;;;; Identifiers
 
 (define (identifier? object)
-  (or (symbol? object)
+  (or (and (symbol? object)
+          ;; This makes `:keyword' objects be self-evaluating.
+          (not (keyword? object)))
       (synthetic-identifier? object)))
 
 (define (synthetic-identifier? object)

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index a7b577796c92bb72a2d0b12e57dcb03ee1b1f756..5815a789c3ab56d4ebb5304f24f3e053826bcb51 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -336,35 +336,53 @@ USA.
          (unparse-symbol symbol)))))
 
 (define (unparse-symbol symbol)
-  (let ((s (symbol-name symbol)))
-    (if (or (string-find-next-char-in-set
-            s
-            (if (environment-lookup *environment*
-                                    '*PARSER-CANONICALIZE-SYMBOLS?*)
-                canon-symbol-quoted
-                non-canon-symbol-quoted))
-           (fix:= (string-length s) 0)
-           (and (char-set-member? char-set/number-leaders (string-ref s 0))
-                (string->number s))
-           (looks-like-keyword? s))
-       (begin
-         (*unparse-char #\|)
-         (let ((end (string-length s)))
-           (let loop ((start 0))
-             (if (fix:< start end)
-                 (let ((i
-                        (substring-find-next-char-in-set
-                         s start end
-                         char-set/symbol-quotes)))
-                   (if i
-                       (begin
-                         (*unparse-substring s start i)
-                         (*unparse-char #\\)
-                         (*unparse-char (string-ref s i))
-                         (loop (fix:+ i 1)))
-                       (*unparse-substring s start end))))))
-         (*unparse-char #\|))
-       (*unparse-string s))))
+  (if (keyword? symbol)
+      (unparse-keyword-name (keyword->string symbol))
+      (unparse-symbol-name (symbol-name symbol))))
+
+(define (unparse-keyword-name s)
+  (case (environment-lookup *environment* '*PARSER-KEYWORD-STYLE*)
+    ((PREFIX)
+     (*unparse-char #\:)
+     (unparse-symbol-name s))
+    ((SUFFIX)
+     (unparse-symbol-name s)
+     (*unparse-char #\:))
+    (else
+     (*unparse-string "#[keyword ")
+     (unparse-symbol-name s)
+     (*unparse-char #\]))))
+
+(define (unparse-symbol-name s)
+  (if (or (string-find-next-char-in-set
+          s
+          (if (environment-lookup *environment*
+                                  '*PARSER-CANONICALIZE-SYMBOLS?*)
+              canon-symbol-quoted
+              non-canon-symbol-quoted))
+         (fix:= (string-length s) 0)
+         (and (char-set-member? char-set/number-leaders (string-ref s 0))
+              (string->number s))
+         (and (fix:> (string-length s) 1)
+              (looks-like-keyword? s)))
+      (begin
+       (*unparse-char #\|)
+       (let ((end (string-length s)))
+         (let loop ((start 0))
+           (if (fix:< start end)
+               (let ((i
+                      (substring-find-next-char-in-set
+                       s start end
+                       char-set/symbol-quotes)))
+                 (if i
+                     (begin
+                       (*unparse-substring s start i)
+                       (*unparse-char #\\)
+                       (*unparse-char (string-ref s i))
+                       (loop (fix:+ i 1)))
+                     (*unparse-substring s start end))))))
+       (*unparse-char #\|))
+      (*unparse-string s)))
 
 (define (looks-like-keyword? string)
   (case (environment-lookup *environment* '*PARSER-KEYWORD-STYLE*)