#lang scheme/base

(require (planet "evector.scm" ("soegaard" "evector.plt" 1))
         scheme/list
         scheme/match
         "../syntax/ast-core.ss"
         "../syntax/ast-utils.ss"
         "../runtime/runtime.ss"
         "helpers.ss")

(provide (all-defined-out))

(define (direct-eval? expr)
  (match expr
    [(struct VarReference (_ (struct Identifier (_ 'eval))))
     (and (not (current-with-statement))
          (not (memq 'eval (map (compose Identifier-name car) (static-environment)))))]
    [_ #f]))

;; static-environment : (parameterof (alistof Identifier (optional arguments-alias)))
(define static-environment (make-parameter null))

(define current-with-statement (make-parameter #f))

;; The (potentially dynamic) scope chain, only used underneath `with'.
(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)

;; extend-static-env : (listof Identifier) * (listof (optional syntax)) * env -> env
(define (extend-static-env ids refs env)
  (append (map cons ids refs) env))

;; make-bindings : (listof symbol) * [(optional region) * (optional (listof (union arguments-alias syntax)))]
(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)
                     ;; NOTE: We put the let-bindings outside since the let-syntax bindings
                     ;;       can't accidentally refer to the let-bound variables, but the
                     ;;       reverse is not necessarily true.
                     (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)))