#lang scheme/base
(require (planet "evector.scm" ("soegaard" "evector.plt" 1))
scheme/list
"../syntax/ast-core.ss"
"../syntax/ast-utils.ss"
"../runtime/runtime.ss"
"helpers.ss")
(provide (all-defined-out))
(define static-environment (make-parameter null))
(define current-with-statement (make-parameter #f))
(define scope-chain (datum->syntax #f 'scope-chain))
(define current-labels (make-parameter null))
(define enable-return? (make-parameter #f))
(define-struct arguments-alias (vector-id offset) #:transparent)
(define (extend-static-env ids refs env)
(append (map cons ids refs) env))
(define (make-bindings names [loc #f] [bindings #f])
(let* ([ids (map (lambda (name)
(if (symbol? name)
(make-Identifier loc name)
name))
names)]
[stx-ids (map Identifier->syntax ids)]
[static-bindings (if (not bindings)
(map (lambda (id) #f) stx-ids)
(map (lambda (binding)
(and (arguments-alias? binding) binding))
bindings))]
[extend (lambda (env)
(extend-static-env ids static-bindings env))])
(values stx-ids
(cond
[(and (current-with-statement) bindings)
(lambda (body)
(with-syntax ([scope-chain scope-chain]
[(prop ...)
(map (lambda (id binding)
(if (arguments-alias? binding)
(with-syntax ([v id]
[vec (arguments-alias-vector-id binding)]
[i (arguments-alias-offset binding)]
[(val) (generate-temporaries '(val))])
#'[v (lambda ()
(evector-ref vec i))
(lambda (val)
(evector-set! vec i val))
()])
(with-syntax ([v id]
[val binding])
#'[v val])))
stx-ids
bindings)]
[body body])
(syntax/loc (region->syntax loc)
(let ([scope-chain (cons (make-frame (object-table prop ...)) scope-chain)])
body))))]
[(current-with-statement)
(lambda (body)
(with-syntax ([scope-chain scope-chain]
[(v ...) stx-ids]
[(key ...) (map (compose symbol->string syntax->datum) stx-ids)]
[body body])
(syntax/loc (region->syntax loc)
(let ([scope-chain (cons (make-frame (object-table [v (void)] ...)) scope-chain)])
body))))]
[bindings
(lambda (body)
(with-syntax ([(vb ...) (filter-map (lambda (id binding)
(and (syntax? binding) id))
stx-ids bindings)]
[(e ...) (filter-map (lambda (binding)
(and (syntax? binding) binding))
bindings)]
[(va ...) (filter-map (lambda (id binding)
(and (arguments-alias? binding) id))
stx-ids bindings)]
[(vec ...) (filter-map (lambda (binding)
(and (arguments-alias? binding)
(arguments-alias-vector-id binding)))
bindings)]
[(i ...) (filter-map (lambda (binding)
(and (arguments-alias? binding)
(arguments-alias-offset binding)))
bindings)]
[body body])
(syntax/loc (region->syntax loc)
(let ([vb e] ...)
(let-syntax ([va (syntax-id-rules (set!)
[(set! v expr) (evector-set! vec i expr)]
[va (evector-ref vec i)])]
...)
body)))))]
[else
(lambda (body)
(with-syntax ([(v ...) stx-ids]
[body body])
(syntax/loc (region->syntax loc)
(let ([v (void)] ...)
body))))])
extend)))