From: Chris Hanson Date: Sat, 27 Jan 2018 04:36:16 +0000 (-0800) Subject: Eliminate synthetic identifiers. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~298 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dce18e97a68a0a8793dad0da0bcff88f6132dd93;p=mit-scheme.git Eliminate synthetic identifiers. Now identifiers are either symbols or closures over symbols. Any operation on a closed identifier redirects to the appropriate environment, rather than trying to bind and/or lookup the closure itself in the environment. This greatly simplifies the identifier model, and makes the operation of the syntax processor much clearer. --- diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 519a2b2a5..30628f3b2 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -79,7 +79,7 @@ USA. ;; Force order -- bind names before classifying body. (let ((bvl (map-mit-lambda-list (lambda (identifier) - (bind-variable! environment identifier)) + (bind-variable environment identifier)) bvl))) (values bvl (compile-body-item @@ -143,7 +143,7 @@ USA. (lambda (form environment) (let ((name (cadr form))) (if (not (syntactic-environment/top-level? environment)) - (syntactic-environment/reserve environment name)) + (reserve-identifier environment name)) (variable-binder environment name (classify/expression (caddr form) environment)))))) @@ -155,18 +155,18 @@ USA. ;; User-defined macros at top level are preserved in the output. (if (and (keyword-value-item? item) (syntactic-environment/top-level? environment)) - (make-binding-item (rename-top-level-identifier name) item) + (make-binding-item name item) (make-body-item '())))) (define (keyword-binder environment name item) (if (not (keyword-item? item)) (syntax-error "Syntactic binding value must be a keyword:" name)) - (syntactic-environment/define environment name item)) + (bind-keyword environment name item)) (define (variable-binder environment name item) (if (keyword-item? item) (syntax-error "Variable binding value must not be a keyword:" name)) - (make-binding-item (bind-variable! environment name) item)) + (make-binding-item (bind-variable environment name) item)) ;;;; LET-like @@ -215,7 +215,7 @@ USA. (body (cddr form)) (binding-env (make-internal-syntactic-environment env))) (for-each (lambda (binding) - (syntactic-environment/reserve binding-env (car binding))) + (reserve-identifier binding-env (car binding))) bindings) ;; Classify right-hand sides first, in order to catch references to ;; reserved names. Then bind names prior to classifying body. diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 0faf0a036..a3722e3a6 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4399,13 +4399,16 @@ USA. syntactic-closure? syntax syntax* - syntax-error - synthetic-identifier?) + syntax-error) (export (runtime syntax) + bind-keyword + bind-variable classifier->keyword compile/expression compiler->keyword - lookup-identifier)) + lookup-identifier + raw-identifier? + reserve-identifier)) (define-package (runtime syntax items) (files "syntax-items") @@ -4454,14 +4457,13 @@ USA. syntactic-environment?) (export (runtime syntax) ->syntactic-environment - bind-variable! make-internal-syntactic-environment make-keyword-syntactic-environment make-partial-syntactic-environment make-top-level-syntactic-environment - null-syntactic-environment syntactic-environment->environment - syntactic-environment/define + syntactic-environment/bind-keyword + syntactic-environment/bind-variable syntactic-environment/lookup syntactic-environment/reserve syntactic-environment/top-level? @@ -4498,7 +4500,6 @@ USA. (parent (runtime syntax)) (export (runtime syntax) make-local-identifier-renamer - rename-top-level-identifier with-identifier-renaming)) (define-package (runtime syntax output) diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm index a8f3a738d..79321085f 100644 --- a/src/runtime/syntax-definitions.scm +++ b/src/runtime/syntax-definitions.scm @@ -35,7 +35,7 @@ USA. (define (create-bindings senv) (define (def name item) - (syntactic-environment/define senv name item)) + (bind-keyword senv name item)) (define (define-classifier name classifier) (def name (make-classifier-item classifier))) diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm index a34eaa53a..1f6c3d125 100644 --- a/src/runtime/syntax-environment.scm +++ b/src/runtime/syntax-environment.scm @@ -48,20 +48,20 @@ USA. ((senv-get-runtime senv))) (define (syntactic-environment/lookup senv identifier) - (guarantee identifier? identifier 'syntactic-environment/lookup) + (guarantee raw-identifier? identifier 'syntactic-environment/lookup) ((senv-lookup senv) identifier)) (define (syntactic-environment/reserve senv identifier) - (guarantee identifier? identifier 'syntactic-environment/reserve) + (guarantee raw-identifier? identifier 'syntactic-environment/reserve) ((senv-store senv) identifier (make-reserved-name-item))) -(define (syntactic-environment/define senv identifier item) - (guarantee identifier? identifier 'syntactic-environment/define) - (guarantee keyword-item? item 'syntactic-environment/define) +(define (syntactic-environment/bind-keyword senv identifier item) + (guarantee raw-identifier? identifier 'syntactic-environment/bind-keyword) + (guarantee keyword-item? item 'syntactic-environment/bind-keyword) ((senv-store senv) identifier item)) -(define (bind-variable! senv identifier) - (guarantee identifier? identifier 'bind-variable!) +(define (syntactic-environment/bind-variable senv identifier) + (guarantee raw-identifier? identifier 'syntactic-environment/bind-variable) (let ((rename ((senv-rename senv) identifier))) ((senv-store senv) identifier (make-variable-item rename)) rename)) @@ -92,32 +92,10 @@ USA. (environment-define-macro env identifier item)) (define (rename identifier) - (rename-top-level-identifier identifier)) + identifier) (make-senv get-type get-runtime lookup store rename)) -;;; Null environments are used only for synthetic identifiers. - -(define null-syntactic-environment - (let () - - (define (get-type) - 'null) - - (define (get-runtime) - (error "Can't evaluate in null environment.")) - - (define (lookup identifier) - (error "Can't lookup in null environment:" identifier)) - - (define (store identifier item) - (error "Can't bind in null environment:" identifier item)) - - (define (rename identifier) - (error "Can't rename in null environment:" identifier)) - - (make-senv get-type get-runtime lookup store rename))) - ;;; Keyword environments are used to make keywords that represent items. (define (make-keyword-syntactic-environment name item) @@ -138,7 +116,7 @@ USA. (define (rename identifier) (error "Can't rename in keyword environment:" identifier)) - (guarantee identifier? name 'make-keyword-environment) + (guarantee raw-identifier? name 'make-keyword-environment) (guarantee keyword-item? item 'make-keyword-environment) (make-senv get-type get-runtime lookup store rename)) @@ -171,7 +149,7 @@ USA. unspecific)))) (define (rename identifier) - (rename-top-level-identifier identifier)) + identifier) (make-senv get-type get-runtime lookup store rename))) diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm index 61eb325c1..995ceae8d 100644 --- a/src/runtime/syntax-rename.scm +++ b/src/runtime/syntax-rename.scm @@ -64,8 +64,7 @@ USA. (conc-name rename-database/)) (frame-number 0) (mapping-table (make-equal-hash-table) read-only #t) - (unmapping-table (make-strong-eq-hash-table) read-only #t) - (id-table (make-strong-eq-hash-table) read-only #t)) + (unmapping-table (make-strong-eq-hash-table) read-only #t)) (define (make-rename-id) (delay @@ -80,43 +79,21 @@ USA. (let ((mapping-table (rename-database/mapping-table renames))) (or (hash-table/get mapping-table key #f) (let ((mapped-identifier - (string->uninterned-symbol - (symbol->string (identifier->symbol identifier))))) + (string->uninterned-symbol (symbol->string identifier)))) (hash-table/put! mapping-table key mapped-identifier) (hash-table/put! (rename-database/unmapping-table renames) mapped-identifier key) mapped-identifier))))) -(define (rename-top-level-identifier identifier) - (if (symbol? identifier) - identifier - ;; Generate an uninterned symbol here and now, rather than - ;; storing anything in the rename database, because we are - ;; creating a top-level binding for a synthetic name, which must - ;; be globally unique. Using the rename database causes the - ;; substitution logic above to try to use an interned symbol - ;; with a nicer name. The decorations on this name are just - ;; that -- decorations, for human legibility. It is the use of - ;; an uninterned symbol that guarantees uniqueness. - (string->uninterned-symbol - (string-append "." - (symbol->string (identifier->symbol identifier)) - "." - (number->string (force (make-rename-id))))))) - -(define (rename->original identifier) +(define (rename->original rename) (let ((entry - (hash-table/get (rename-database/unmapping-table - (rename-db)) - identifier + (hash-table/get (rename-database/unmapping-table (rename-db)) + rename #f))) (if entry - (identifier->symbol (car entry)) - (begin - (if (not (symbol? identifier)) - (error:bad-range-argument identifier 'RENAME->ORIGINAL)) - identifier)))) + (car entry) + rename))) ;;;; Post processing @@ -125,11 +102,7 @@ USA. (compute-substitution expression (lambda (rename original) (hash-table/put! safe-set rename original))) - (alpha-substitute (unmapping->substitution safe-set) expression))) - -(define ((unmapping->substitution safe-set) rename) - (or (hash-table/get safe-set rename #f) - (finalize-mapped-identifier rename))) + (alpha-substitute (make-final-substitution safe-set) expression))) (define (mark-local-bindings bound body mark-safe!) (let ((free @@ -145,54 +118,43 @@ USA. bound) free)) -(define (finalize-mapped-identifier identifier) - (let ((entry - (hash-table/get (rename-database/unmapping-table - (rename-db)) - identifier - #f))) - (if entry - (let ((identifier (car entry)) - (frame-number (force (cdr entry)))) - (if (interned-symbol? identifier) - (map-interned-symbol identifier frame-number) - (map-uninterned-identifier identifier frame-number))) - (begin - (if (not (symbol? identifier)) - (error:bad-range-argument identifier - 'FINALIZE-MAPPED-IDENTIFIER)) - identifier)))) - -(define (map-interned-symbol symbol-to-map frame-number) - (symbol "." symbol-to-map "." frame-number)) - -(define (map-uninterned-identifier identifier frame-number) - (let ((table (rename-database/id-table (rename-db))) - (symbol (identifier->symbol identifier))) - (let ((alist (hash-table/get table symbol '()))) - (let ((entry (assv frame-number alist))) +(define (make-final-substitution safe-set) + (let ((uninterned-table (make-strong-eq-hash-table))) + + (define (finalize-renamed-identifier rename) + (guarantee identifier? rename 'finalize-renamed-identifier) + (let ((entry + (hash-table/get (rename-database/unmapping-table (rename-db)) + rename + #f))) (if entry - (let ((entry* (assq identifier (cdr entry)))) - (if entry* - (cdr entry*) - (let ((mapped-symbol - (map-indexed-symbol symbol - frame-number - (length (cdr entry))))) - (set-cdr! entry - (cons (cons identifier mapped-symbol) - (cdr entry))) - mapped-symbol))) - (let ((mapped-symbol (map-indexed-symbol symbol frame-number 0))) - (hash-table/put! table - symbol - (cons (list frame-number - (cons identifier mapped-symbol)) - alist)) - mapped-symbol)))))) - -(define (map-indexed-symbol symbol-to-map frame-number index-number) - (symbol "." symbol-to-map "." frame-number "-" index-number)) + (let ((original (car entry)) + (frame-id (force (cdr entry)))) + (if (interned-symbol? original) + (symbol "." original "." frame-id) + (finalize-uninterned original frame-id))) + rename))) + + (define (finalize-uninterned original frame-id) + (let ((bucket + (hash-table-intern! uninterned-table + original + (lambda () (list 'bucket))))) + (let ((entry (assv frame-id (cdr bucket)))) + (if entry + (cdr entry) + (let ((finalized + (symbol "." original + "." frame-id + "-" (length (cdr bucket))))) + (set-cdr! bucket + (cons (cons original finalized) + (cdr bucket))) + finalized))))) + + (lambda (rename) + (or (hash-table/get safe-set rename #f) + (finalize-renamed-identifier rename))))) ;;;; Compute substitution diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 41228ab45..18e9bc340 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -75,8 +75,7 @@ USA. (if (or (memq form free) ;LOOKUP-IDENTIFIER assumes this. (constant-form? form) (and (syntactic-closure? form) - (null? (syntactic-closure-free form)) - (not (identifier? (syntactic-closure-form form))))) + (null? (syntactic-closure-free form)))) form (%make-syntactic-closure senv free form)))) @@ -110,26 +109,46 @@ USA. ;;;; Identifiers (define (identifier? object) - (or (and (symbol? object) - ;; This makes `:keyword' objects be self-evaluating. - (not (keyword? object))) - (synthetic-identifier? object))) -(register-predicate! identifier? 'identifier) + (or (raw-identifier? object) + (closed-identifier? object))) + +(define (raw-identifier? object) + (and (symbol? object) + ;; This makes `:keyword' objects be self-evaluating. + (not (keyword? object)))) -(define (synthetic-identifier? object) +(define (closed-identifier? object) (and (syntactic-closure? object) - (identifier? (syntactic-closure-form object)))) + (null? (syntactic-closure-free object)) + (raw-identifier? (syntactic-closure-form object)))) + +(register-predicate! identifier? 'identifier) +(register-predicate! raw-identifier? 'raw-identifier '<= identifier?) +(register-predicate! closed-identifier? 'closed-identifier '<= identifier?) (define (make-synthetic-identifier identifier) - (close-syntax identifier null-syntactic-environment)) + (string->uninterned-symbol (symbol->string (identifier->symbol identifier)))) (define (identifier->symbol identifier) - (or (let loop ((identifier identifier)) - (if (syntactic-closure? identifier) - (loop (syntactic-closure-form identifier)) - (and (symbol? identifier) - identifier))) - (error:not-a identifier? identifier 'identifier->symbol))) + (cond ((raw-identifier? identifier) identifier) + ((closed-identifier? identifier) (syntactic-closure-form identifier)) + (else (error:not-a identifier? identifier 'identifier->symbol)))) + +(define (lookup-identifier identifier senv) + (cond ((raw-identifier? identifier) + (%lookup-raw-identifier identifier senv)) + ((closed-identifier? identifier) + (%lookup-raw-identifier (syntactic-closure-form identifier) + (syntactic-closure-senv identifier))) + (else + (error:not-a identifier? identifier 'lookup-identifier)))) + +(define (%lookup-raw-identifier identifier senv) + (let ((item (syntactic-environment/lookup senv identifier))) + (if (reserved-name-item? item) + (syntax-error "Premature reference to reserved name:" identifier)) + (or item + (make-variable-item identifier)))) (define (identifier=? environment-1 identifier-1 environment-2 identifier-2) (let ((item-1 (lookup-identifier identifier-1 environment-1)) @@ -145,19 +164,35 @@ USA. (eq? (variable-item/name item-1) (variable-item/name item-2)))))) -(define (lookup-identifier identifier environment) - (let ((item (syntactic-environment/lookup environment identifier))) - (cond (item - (if (reserved-name-item? item) - (syntax-error "Premature reference to reserved name:" identifier) - item)) - ((symbol? identifier) - (make-variable-item identifier)) - ((syntactic-closure? identifier) - (lookup-identifier (syntactic-closure-form identifier) - (syntactic-closure-senv identifier))) - (else - (error:not-a identifier? identifier 'lookup-identifier))))) +(define (reserve-identifier senv identifier) + (cond ((raw-identifier? identifier) + (syntactic-environment/reserve senv identifier)) + ((closed-identifier? identifier) + (syntactic-environment/reserve (syntactic-closure-senv identifier) + (syntactic-closure-form identifier))) + (else + (error:not-a identifier? identifier 'reserve-identifier)))) + +(define (bind-keyword senv identifier item) + (cond ((raw-identifier? identifier) + (syntactic-environment/bind-keyword senv identifier item)) + ((closed-identifier? identifier) + (syntactic-environment/bind-keyword + (syntactic-closure-senv identifier) + (syntactic-closure-form identifier) + item)) + (else + (error:not-a identifier? identifier 'bind-keyword)))) + +(define (bind-variable senv identifier) + (cond ((raw-identifier? identifier) + (syntactic-environment/bind-variable senv identifier)) + ((closed-identifier? identifier) + (syntactic-environment/bind-variable + (syntactic-closure-senv identifier) + (syntactic-closure-form identifier))) + (else + (error:not-a identifier? identifier 'bind-variable)))) ;;;; Utilities