From: Joe Marshall Date: Thu, 1 Apr 2010 00:36:51 +0000 (-0700) Subject: Change keyword implementation to be based on symbols rather than structs. X-Git-Tag: 20100708-Gtk~71^2~1 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=22dac4ed3c72491f2c305ce48a314ed91150bd60;p=mit-scheme.git Change keyword implementation to be based on symbols rather than structs. --- diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm index d8ce32126..bf4ff18c5 100644 --- a/src/runtime/keyword.scm +++ b/src/runtime/keyword.scm @@ -28,51 +28,25 @@ USA. (declare (usual-integrations)) -(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 6785ef678..cc6e85d6a 100644 --- 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 af7537b81..f5686332f 100644 --- 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 a7b577796..5815a789c 100644 --- 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*)