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.
;; 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
(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))))))
;; 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))
\f
;;;; LET-like
(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.
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")
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?
(parent (runtime syntax))
(export (runtime syntax)
make-local-identifier-renamer
- rename-top-level-identifier
with-identifier-renaming))
(define-package (runtime syntax output)
(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)))
((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))
(environment-define-macro env identifier item))
(define (rename identifier)
- (rename-top-level-identifier identifier))
+ identifier)
(make-senv get-type get-runtime lookup store rename))
\f
-;;; 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)))
-\f
;;; Keyword environments are used to make keywords that represent items.
(define (make-keyword-syntactic-environment name item)
(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))
unspecific))))
(define (rename identifier)
- (rename-top-level-identifier identifier))
+ identifier)
(make-senv get-type get-runtime lookup store rename)))
\f
(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
(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)))
\f
;;;; Post processing
(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
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)))))
\f
;;;; Compute substitution
(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))))
;;;; 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))
(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))))
\f
;;;; Utilities
projects / mit-scheme.git / commitdiff