#lang scheme/base

(require (planet "evector.scm" ("soegaard" "evector.plt" 1))
         (except-in srfi/1/list any)
         scheme/match
         "../syntax/ast-core.ss"
         "../syntax/ast-utils.ss"
         "../syntax/token.ss"
         "../syntax/exceptions.ss"
         "../../private/config.ss"
         "../runtime/runtime.ss"
         "../../debug.ss"
         "../syntax/parse.ss"
         "helpers.ss"
         "hoist.ss"
         "lexical-context.ss")

(provide compile-script compile-interaction compile-function-expression with-syntax-errors direct-eval)

(define (direct-eval args this scope)
  (if (zero? (evector-length args))
      (void)
      (eval (compile-script (parse-script (value->string (evector-ref args 0)))))))

;; TODO: is generate-temporaries guaranteed never to be captured?
;;  - perhaps not, because sometimes 'x57 == (generate-temporaries '(x))
;;  - perhaps so, if we always use non-forgeable names (e.g., with an illegal character)
;;  - but be careful about capture with string keys!

;; TODO: optimizations
;;   - don't capture return continuation if it's not used
;;   - remove unnecessary `void' if last statement in function is not an expression statement

(define-syntax-rule (syntax/loc* loc expr)
  (syntax/loc (region->syntax loc)
    expr))

;; loop? : Statement -> boolean
(define (loop? stmt)
  (or (DoWhileStatement? stmt)
      (WhileStatement? stmt)
      (ForStatement? stmt)
      (ForInStatement? stmt)))

;; ===========================================================================
;; COMPILER TOP-LEVEL
;; ===========================================================================

(define (with-syntax-errors thunk)
  (with-handlers ([exn:fail:syntax?
                   (lambda (exn)
                     (let* ([loc (exn:fail:syntax-location exn)]
                            [text (format "~a" (exn:fail:syntax-text exn))]
                            [stxloc (build-syntax (string->symbol text) loc)])
                       (raise-syntax-error 'parse (exn-message exn) stxloc stxloc)))])
    (thunk)))

;; compile-script : (listof SourceElement) -> syntax
(define (compile-script elts)
  (let*-values ([(funs vars stmts) (hoist-script elts)]
                [(definitions new-env) (compile-declarations funs vars)])
    (with-syntax ([(defn ...) definitions]
                  [scope-chain scope-chain]
                  [(s ...) (parameterize ([static-environment new-env])
                             (map compile-statement stmts))])
      #'(parameterize ([current-completion #f])
          (define scope-chain null)
          defn ... s ...
          (current-completion)))))

;; compile-interaction : (listof SourceElement) -> syntax
(define (compile-interaction elt)
  (let*-values ([(funs vars stmts) (hoist-script elt)]
                [(definitions new-env) (compile-declarations funs vars)])
    (with-syntax ([(defn ...) definitions]
                  [scope-chain scope-chain]
                  [(s ...) (parameterize ([static-environment new-env])
                             (map compile-statement stmts))]
                  [(previous-completion) (generate-temporaries '(previous-completion))])
      (static-environment new-env)
      #'(begin
          (define previous-completion (current-completion))
          (current-completion #f)
          (define scope-chain null)
          defn ... s ...
          (begin0
            (cond
              [(current-completion)
               => (lambda (v)
                    (object-set! global-object "it" v)
                    v)]
              [else #f])
            (current-completion previous-completion))))))

;; compile-function-expression : FunctionExpression -> syntax
(define (compile-function-expression expr)
  (match (hoist-expression expr)
    [(struct FunctionExpression/hoisted (loc name args body funs vars))
     (compile-function loc name args body funs vars)]))

;; compile-declarations : (listof FunctionDeclaration/hoisted) * (listof Identifier)
;;                     -> (listof syntax)
;;                        environment
;; compiles top-level declarations ONLY
(define (compile-declarations funs vars)
  (let* ([fun-ids (map FunctionDeclaration-name funs)]
         [all-ids (append fun-ids vars)]
         [new-env (append (map (lambda (id) (cons id #f)) all-ids)
                          (static-environment))]
         [definitions (with-syntax ([(var ...) (map Identifier->syntax all-ids)]
                                    [(var-key ...) (map Identifier->key all-ids)]
                                    [(init-e ...) (append (parameterize ([static-environment new-env])
                                                            (map compile-function-declaration funs))
                                                          (map (lambda (var) #'(void)) vars))])
                        (syntax->list #'((define-syntax var
                                           (syntax-id-rules (set!)
                                             [(set! var expr) (object-put! global-object var-key expr)]
                                             ;; TODO: does this object-get need to be guarded?
                                             [var (object-get global-object var-key)]))
                                         ...
                                         (set! var init-e) ...)))])
;        (for-each (lambda (defn)
;                    (fprintf (current-error-port) "defining: ~a~n" (syntax->datum defn)))
;                  definitions)
    (values definitions new-env)))

;; ===========================================================================
;; LVALUES
;; ===========================================================================

;; reference-expression? : Expression -> boolean
(define (reference-expression? expr)
  (or (VarReference? expr)
      (BracketReference? expr)
      (DotReference? expr)))

;; compile-deletion : Expression -> syntax
(define (compile-deletion expr)
  (match expr
    [(struct VarReference (loc id))
     (cond
       [(and (not (current-with-statement))
             (not (assf (lambda (i) (Identifier=? i id)) (static-environment))))
        #'(quote true)]
       [(current-with-statement)
        (with-syntax ([scope-chain scope-chain]
                      [key (Identifier->key id)])
          (syntax/loc (region->syntax loc)
            (scope-chain-delete! scope-chain key)))]
       [else
        #'(quote false)])]
    [(struct BracketReference (loc container key))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [(obj-val) (generate-temporaries '(obj-val))])
       (syntax/loc (region->syntax loc)
         (let ([obj-val (value->object container-e)])
           (object-delete! obj-val key-e))))]
    [(struct DotReference (loc container id))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (Identifier->key id)]
                   [(obj-val) (generate-temporaries '(obj-val))])
       (syntax/loc (region->syntax loc)
         (let ([obj-val (value->object container-e)])
           (object-delete! obj-val key-e))))]))

;; compile-assignment : Expression * syntax -> syntax
(define (compile-assignment lhs rhs-stx)
  (match lhs
    [(struct VarReference (loc id))
     (debug 'scope-resolution "looking for ~a in ~v" (Identifier-name id) (static-environment))
     (cond
       [(and (not (current-with-statement))
             (not (assf (lambda (i) (Identifier=? i id)) (static-environment))))
        (debug 'unbound-reference "~a unbound at ~a" (Identifier-name id) (region->string loc))
        (with-syntax ([key (Identifier->key id)]
                      [rhs-e rhs-stx]
                      [(val) (generate-temporaries '(val))])
          (syntax/loc (region->syntax loc)
            (let ([val rhs-e])
              (object-put! global-object key val)
              val)))]
       [(current-with-statement)
        (with-syntax ([scope-chain scope-chain]
                      [key (Identifier->key id)]
                      [rhs-e rhs-stx])
          (syntax/loc (region->syntax loc)
            (scope-chain-set! scope-chain key rhs-e)))]
       [else
        (with-syntax ([x (Identifier->syntax id)]
                      [(val) (generate-temporaries '(val))]
                      [rhs-e rhs-stx])
          (syntax/loc (region->syntax loc)
            (let ([val rhs-e])
              (set! x val)
              val)))])]
    [(struct BracketReference (loc container key))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [rhs-e rhs-stx]
                   [(container-val key-val) (generate-temporaries '(container-val key-val))])
       (syntax/loc (region->syntax loc)
         (let* ([container-val (value->object container-e)]
                [key-val key-e])
           (object-set! container-val key-val rhs-e))))]
    [(struct DotReference (loc container id))
     (with-syntax ([container-e (compile-expression container)]
                   [rhs-e rhs-stx]
                   [key-val (Identifier->key id)])
       (syntax/loc (region->syntax loc)
         (let ([container-val (value->object container-e)])
           (object-set! container-val key-val rhs-e))))]
    [_ (raise-syntax-error 'compile "invalid assignment left-hand side" (region->syntax (Term-location lhs)))]))

;; compile-lookup : reference-expression -> syntax
(define (compile-lookup expr)
  (match expr
    ;; TODO: binding forms should still introduce binding arrows under with
    ;;  - add name to static environment
    ;;  - compile ref to (if #f x (dynamic-lookup 'x))
    [(struct VarReference (loc id))
     (debug 'scope-resolution "looking for ~a in ~v" (Identifier-name id) (static-environment))
     (cond
       [(and (not (current-with-statement))
             (not (assf (lambda (i) (Identifier=? i id)) (static-environment))))
        (debug 'unbound-reference "~a unbound at ~a" (Identifier-name id) (region->string loc))
        (with-syntax ([stxloc (region->syntax loc)]
                      [key (Identifier->key id)])
          (syntax/loc (region->syntax loc)
            (or (object-get global-object key)
                (raise (make-exn:fail:contract:variable (format "~a is not defined" key)
                                                        (current-continuation-marks)
                                                        (string->symbol key))))))]
       [(current-with-statement)
        (with-syntax ([scope-chain scope-chain]
                      [key (Identifier->key id)])
          (syntax/loc (region->syntax loc)
            (or (scope-chain-get scope-chain key)
                (raise (make-exn:fail:contract:variable (format "~a is not defined" key)
                                                        (current-continuation-marks)
                                                        (string->symbol key))))))]
       [else (Identifier->syntax id)])]
    [(struct BracketReference (loc container key))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [(container-val) (generate-temporaries '(container-val))])
       (syntax/loc (region->syntax loc)
         (let ([container-val (value->object container-e)])
           (or (object-get container-val key-e) (void)))))]
    [(struct DotReference (loc container id))
     (with-syntax ([container-e (compile-expression container)]
                   [key-val (Identifier->key id)])
       (syntax/loc (region->syntax loc)
         (or (object-get container-e key-val) (void))))]))

;; ===========================================================================
;; COMPILER CORE
;; ===========================================================================

(define (compile-function-declaration decl)
  (match decl
    [(struct FunctionDeclaration/hoisted (loc name args body funs vars))
     (compile-function loc name args body funs vars)]))

;; TODO: handle return more gracefully (particularly invalid returns)

(define (compile-function loc name args body funs vars)
  (let ([arity (length args)])
    (with-syntax ([(func-object arg-vec args-object) (generate-temporaries '(func-object arg-vec args-object))])
      (let ([aliases (build-list arity (lambda (i)
                                         (make-arguments-alias #'arg-vec i)))])
        (let-values ([(arg-stx-ids add-args bind-args) (make-bindings args loc aliases)]
                     [(fun-stx-ids add-funs bind-funs) (make-bindings (map FunctionDeclaration-name funs) loc)]
                     [(var-stx-ids add-vars bind-vars) (make-bindings (cons (make-Identifier loc 'arguments) vars) loc)]
                     [(name-stx-id add-name bind-name) (make-bindings (if name (list name) null) loc)])
          (let ([new-static-env (bind-name (bind-args (bind-funs (bind-vars (static-environment)))))])
            (with-syntax ([return (datum->syntax #f 'return)]
                          [(s ...) (parameterize ([enable-return? #t]
                                                  [static-environment new-static-env])
                                     (map compile-statement body))]
                          [set-arguments!
                           (parameterize ([static-environment new-static-env])
                             (compile-assignment (make-VarReference loc (make-Identifier loc 'arguments)) #'args-object))]
                          [(set-nested-func! ...)
                           (parameterize ([static-environment new-static-env])
                             (map (lambda (fun)
                                    (compile-assignment (make-VarReference (Term-location fun) (FunctionDeclaration-name fun))
                                                        (compile-function-declaration fun)))
                                  funs))])
              (with-syntax ([body (quasisyntax/loc (region->syntax loc)
                                    (lambda (arg-vec)
                                      (let ([args-object (make-arguments-object func-object arg-vec)])
                                        #,(add-args
                                           (add-funs
                                            (add-vars
                                             (syntax/loc (region->syntax loc)
                                               (begin
                                                 set-arguments!
                                                 set-nested-func! ...
                                                 (parameterize ([current-completion #f])
                                                   (let/ec return
                                                     s ...
                                                     (void)))))))))))]
                            [arity arity])
                (if name
                    (with-syntax ([set-f! (parameterize ([static-environment new-static-env])
                                            (compile-assignment (make-VarReference loc name)
                                                                #'func-object))])
                      (add-name
                       (syntax/loc (region->syntax loc)
                         (letrec ([func-object (build-function arity body)])
                           set-f!
                           func-object))))
                    (syntax/loc (region->syntax loc)
                      (letrec ([func-object (build-function arity body)])
                        func-object)))))))))))

(define (compile-statement stmt)
  (match stmt
    [(struct BlockStatement/hoisted (loc stmts funs vars))
     (let-values ([(var-stx-ids add-args bind-args) (make-bindings vars loc)]
                  [(fun-stx-ids add-funs bind-funs) (make-bindings (map FunctionDeclaration-name funs) loc)])
       (let ([new-static-env (bind-args (bind-funs (static-environment)))])
         (with-syntax ([(f ...) fun-stx-ids]
                       [(fe ...) (parameterize ([static-environment new-static-env])
                                   (map compile-function-declaration funs))]
                       [(s ...) (parameterize ([static-environment new-static-env])
                                  (map compile-statement stmts))])
           (add-args
            (add-funs
             (syntax/loc (region->syntax loc)
               (begin
                 (set! f fe) ...
                 s ...
                 (current-completion))))))))]
    [(struct EmptyStatement (loc))
     (syntax/loc* loc
       #f)]
    [(struct ExpressionStatement (loc expr))
     (with-syntax ([e (compile-expression expr)])
       (syntax/loc* loc
         (complete! e)))]
    ;; TODO: test IfStatement
    [(struct IfStatement (loc test consequent alternate))
     (with-syntax ([test-e (compile-expression test)]
                   [consequent-s (compile-statement consequent)]
                   [alternate-s (if alternate (compile-statement alternate) #'#f)])
       (syntax/loc* loc
         (if (true-value? test-e)
             consequent-s
             alternate-s)))]
    ;; TODO: test loops
    [(? loop?)
     (with-syntax ([(break continue) (generate-temporaries '(break continue))])
       (parameterize ([current-labels (cons (list #f #'break #'continue)
                                            (current-labels))])
         (compile-loop stmt #'break #'continue)))]
    ;; TODO: test ContinueStatement
    [(struct ContinueStatement (loc #f))
     (cond
       [(ormap (lambda (tuple)
                 (and (pair? (cddr tuple))
                      (caddr tuple)))
               (current-labels))
        => (lambda (continue-id)
             (with-syntax ([continue continue-id])
               (syntax/loc* loc
                 (continue #f))))]
       [else (let ([stxloc (build-syntax 'continue loc)])
               (raise-syntax-error 'continue "invalid continue" stxloc stxloc))])]
    [(struct ContinueStatement (loc label))
     (cond
       [(null? (current-labels))
        (raise-syntax-error 'continue "invalid continue" (build-syntax 'continue loc))]
       [(assq (Identifier-name label) (current-labels))
        => (lambda (tuple)
             (if (pair? (cddr tuple))
                 (with-syntax ([continue (caddr tuple)])
                   (syntax/loc* loc
                     (continue #f)))
                 (raise-syntax-error 'continue "invalid label" (Identifier->syntax label))))]
       [else (raise-syntax-error 'continue "invalid label" (Identifier->syntax label))])]
    ;; TODO: test BreakStatement
    [(struct BreakStatement (loc #f))
     (when (null? (current-labels))
       (let ([stxloc (build-syntax 'break loc)])
         (raise-syntax-error 'break "invalid break" stxloc stxloc)))
     (with-syntax ([break (cadar (current-labels))])
       (syntax/loc* loc
         (break (current-completion))))]
    [(struct BreakStatement (loc label))
     (cond
       [(null? (current-labels))
        (raise-syntax-error 'break "invalid break" (build-syntax 'break loc))]
       [(assq (Identifier-name label) (current-labels))
        => (lambda (tuple)
             (with-syntax ([break (cadr tuple)])
               (syntax/loc* loc
                 (break (current-completion)))))]
       [else (raise-syntax-error 'break "invalid label" (Identifier->syntax label))])]
    [(struct ReturnStatement (loc value))
     (unless (enable-return?)
       (let ([stxloc (build-syntax 'return loc)])
         (raise-syntax-error 'return "invalid return" stxloc stxloc)))
     (with-syntax ([return (datum->syntax #f 'return)]
                   [e (if value
                          (compile-expression value)
                          #'(void))])
       (syntax/loc* loc
         (return e)))]
    [(struct LetStatement (loc bindings body))
     (let-values ([(var-stx-ids add-vars bind-vars)
                   (make-bindings (map VariableInitializer-id bindings)
                                  loc
                                  (map (compose compile-optional-expression VariableInitializer-init) bindings))])
       (with-syntax ([body (parameterize ([static-environment (bind-vars (static-environment))])
                             (compile-statement body))])
         (add-vars (syntax/loc (region->syntax loc) body))))]
    [(struct WithStatement (loc object body))
     (let* ([unique-entries (delete-duplicates (static-environment) (lambda (e1 e2)
                                                                      (Identifier=? (car e1) (car e2))))]
            [all-identifiers-in-scope (map car unique-entries)])
       (with-syntax ([scope-chain scope-chain]
                     ;; Shadow all bound variables with expressions that look them up in
                     ;; the dynamic environment, and have their binding arrows point to
                     ;; this with statement.
                     [(shadow-x ...) (map (lambda (id)
                                            (Identifier->syntax id (Term-location object)))
                                          all-identifiers-in-scope)]
                     ;; Uses of these variables will not be associated with source locations.
                     [(invisible-x ...) (map (lambda (id)
                                               (Identifier->syntax id #f))
                                             all-identifiers-in-scope)]
                     [(x-value ...) (map (lambda (entry)
                                           (let* ([id (car entry)]
                                                  [var (make-VarReference (Term-location id) id)])
                                             (compile-lookup var)))
                                         unique-entries)]
                     [(x-key ...) (map Identifier->key all-identifiers-in-scope)]
                     ;; The expression is evaluated with the current lexical environment.
                     [e (compile-expression object)]
                     ;; The body is evaluated in the syntactic context of the with statement
                     ;; and has an empty initial static environment.
                     [s (parameterize ([static-environment null]
                                       [current-with-statement stmt])
                          (compile-statement body))])
         (with-syntax ([base-chain (if (not (current-with-statement))
                                       #'(list (make-frame (object-table [invisible-x x-value] ...))
                                               global-object)
                                       #'scope-chain)])
           (syntax/loc (region->syntax loc)
             (let ([scope-chain (cons e base-chain)])
               (let-syntax ([shadow-x (syntax-id-rules (set!)
                                        [(set! shadow-x expr) (scope-chain-set! scope-chain x-key expr)]
                                        [shadow-x (or (scope-chain-get scope-chain x-key)
                                                      (raise (make-exn:fail:contract:variable
                                                              (format "~a is not defined" x-key)
                                                              (current-continuation-marks)
                                                              (string->symbol x-key))))])]
                            ...)
                 s))))))]
    ;; TODO: test SwitchStatement
    ;; TODO: what comparison is used on the values? any dynamic dispatch there?
    [(struct SwitchStatement (loc expr (list (struct CaseClause (_ qs as)) ...)))
     (with-syntax ([e (compile-expression expr)]
                   [(x v break falling-through?) (generate-temporaries '(x v break falling-through?))])
       (with-syntax ([(q ...) (map (lambda (q)
                                     (if q
                                         (with-syntax ([test-e (compile-expression q)])
                                           #'(lambda (x)
                                               (equal? x test-e)))
                                         #'(lambda (x) #t)))
                                   qs)])
         (parameterize ([current-labels (cons (list #f #'break) (current-labels))])
           (with-syntax ([((a ...) ...) (map (lambda (stmts)
                                               (map compile-statement stmts))
                                             as)])
             (syntax/loc* loc
               (let ([v e])
                 (let/ec break
                   (let ([falling-through? #f])
                     (when (or falling-through? (q v))
                       (set! falling-through? #t)
                       a ...)
                     ...
                     (current-completion)))))))))]
    ;; TODO: test LabelledStatement
    [(struct LabelledStatement (loc label (? loop? loop)))
     (let ([label-name (Identifier-name label)])
       (with-syntax ([(break continue) (generate-temporaries '(break continue))])
         (parameterize ([current-labels (cons (list label-name #'break #'continue)
                                              (current-labels))])
           (compile-loop loop #'break #'continue))))]
    [(struct LabelledStatement (loc label statement))
     (let ([label-name (Identifier-name label)])
       (with-syntax ([(break) (generate-temporaries '(break))])
         (parameterize ([current-labels (cons (list label-name #'break)
                                              (current-labels))])
           (with-syntax ([s (compile-statement statement)])
             (syntax/loc* loc
               (let/ec break s))))))]
    ;; TODO: test ThrowStatement
    [(struct ThrowStatement (loc value))
     (with-syntax ([stxloc (region->syntax loc)]
                   [e (compile-expression value)])
       (syntax/loc* loc
         (raise-runtime-exception stxloc e)))]
    ;; TODO: test TryStatement
    ;; TODO: add conditions to CatchClause ast and compile that too
    ;; TODO: need an error for try with no catch or finally
    ;; TODO: handle try/finally with return in finally
    [(struct TryStatement (loc body catches finally))
     (with-syntax ([body-s (compile-statement body)]
                   [(catch-e ...) (map compile-catch-clause catches)])
       (with-syntax ([try-catch #'(with-handlers ([exn:runtime? catch-e]
                                                  ...)
                                    body-s)])
         (if finally
             (with-syntax ([finally-s (compile-statement finally)])
               (syntax/loc* loc
                 (begin (dynamic-wind
                         void
                         (lambda () try-catch)
                         (lambda () finally-s))
                        (current-completion))))
             (syntax/loc* loc try-catch))))]
    ))

(define (compile-catch-clause clause)
  (match clause
    [(struct CatchClause (loc exn catch))
     (with-syntax ([(exn-value) (generate-temporaries '(exn-value))])
       (let-values ([(var-stx-ids add-var bind-var) (make-bindings (list exn)
                                                                   (Term-location exn)
                                                                   (list
                                                                    (syntax/loc (region->syntax loc)
                                                                      (exn:runtime-value exn-value))))])
         (with-syntax ([body (add-var (parameterize ([static-environment (bind-var (static-environment))])
                                        (compile-statement catch)))])
           (syntax/loc (region->syntax loc)
             (lambda (exn-value) body)))))]))

;; TODO: test loops
(define (compile-loop stmt break-id continue-id)
  (match stmt
    [(struct DoWhileStatement (loc body test))
     (with-syntax ([body-s (compile-statement body)]
                   [test-e (compile-expression test)]
                   [break break-id]
                   [continue continue-id])
       (syntax/loc* loc
         (let/ec break
           (let loop ()
             (let/ec continue body-s)
             (if (true-value? test-e)
                 (loop)
                 (current-completion))))))]
    [(struct WhileStatement (loc test body))
     (with-syntax ([test-e (compile-expression test)]
                   [body-s (compile-statement body)]
                   [break break-id]
                   [continue continue-id])
       (syntax/loc* loc
         (let/ec break
           (let loop ()
             (if (true-value? test-e)
                 (begin (let/ec continue body-s)
                        (loop))
                 (current-completion))))))]
    [(struct ForStatement (loc init test incr body))
     (with-syntax ([init-e (if init
                               (compile-expression init)
                               #'(void))]
                   [test-e (if test
                               (compile-expression test)
                               #'(quote true))]
                   [incr-e (if incr
                               (compile-expression incr)
                               #'(void))]
                   [body-s (compile-statement body)]
                   [break break-id]
                   [continue continue-id]
                   [(loop) (generate-temporaries '(loop))])
       (syntax/loc* loc
         (begin
           init-e
           (let/ec break
             (let loop ()
               (if (true-value? test-e)
                   (begin (let/ec continue body-s)
                          incr-e
                          (loop))
                   (current-completion)))))))]
    [(struct ForInStatement (loc lhs container body))
     (with-syntax ([(object next-key key) (generate-temporaries '(object next-key key))])
       (with-syntax ([container-e (compile-expression container)]
                     [update (compile-assignment lhs #'key)]
                     [body-s (compile-statement body)]
                     [break break-id]
                     [continue continue-id])
         (syntax/loc (region->syntax loc)
           (let/ec break
             (let* ([object container-e]
                    [next-key (object-keys-stream object)])
               (let loop ()
                 (let ([key (next-key)])
                   (if key
                       (begin
                         update
                         (let/ec continue body-s)
                         (loop))
                       (current-completion)))))))))]
    ))

(define (field-reference? x)
  (or (BracketReference? x)
      (DotReference? x)))

(define (compile-optional-expression expr)
  (if expr (compile-expression expr) #'(void)))

;; TODO: test cases for all expression forms
(define (compile-expression expr)
  (match expr
    [(struct StringLiteral (loc value))
     (build-syntax value loc)]
    [(struct NumericLiteral (loc value))
     (build-syntax value loc)]
    [(struct BooleanLiteral (loc value))
     (if value
         (syntax/loc* loc 'true)
         (syntax/loc* loc 'false))]
    [(struct NullLiteral (loc))
     (syntax/loc* loc '())]
    [(struct RegexpLiteral (loc pattern global? case-insensitive?))
     (begin (printf "expression not compiled: ~v~n" expr)
            #'"<<regular expression>>")]
    [(struct ArrayLiteral (loc elts))
     (with-syntax ([(e ...) (map compile-expression elts)])
       (syntax/loc* loc
         (build-array (evector e ...))))]
    [(struct ObjectLiteral (loc properties))
     (let ([names (map (lambda (prop)
                         (let ([name (car prop)])
                           (cond
                             [(NumericLiteral? name) (NumericLiteral-value name)]
                             [(StringLiteral? name) (StringLiteral-value name)]
                             [(Identifier? name) (Identifier->key name)])))
                       properties)]
           [values (map cdr properties)])
       (with-syntax ([(key ...) names]
                     [(e ...) (map compile-expression values)])
         (syntax/loc* loc
           (build-object
            (object-table [key e] ...)))))]
    [(struct ThisReference (loc))
     (syntax/loc (region->syntax loc)
       (current-this))]
    [(? reference-expression?)
     (compile-lookup expr)]
    [(struct NewExpression (loc constructor args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [constructor-e (compile-expression constructor)]
                   [(e ...) (map compile-expression args)]
                   [(ctor) (generate-temporaries '(ctor))])
       (syntax/loc* loc
         (let ([ctor constructor-e])
           (unless (object? ctor)
             (raise-runtime-type-error stxloc "constructor" ctor))
           ((object-construct ctor) (evector e ...)))))]
    [(struct PostfixExpression (loc operand op))
     (with-syntax ([op-e (if (eq? op '++) #'js:+ #'js:-)]
                   [operand-e (compile-expression operand)]
                   [update (compile-expression (make-AssignmentExpression loc
                                                                          operand
                                                                          (if (eq? op '++) '+= '-=)
                                                                          (make-NumericLiteral loc 1)))]
                   [(v) (generate-temporaries '(v))])
       (syntax/loc (region->syntax loc)
         (let ([v (value->number operand-e)])
           update
           v)))]
    [(struct PrefixExpression (loc op operand))
     (cond
       [(memq op '(++ --))
        (let ([op (if (eq? op '++) '+= '-=)])
          (compile-expression
           (make-AssignmentExpression loc operand op (make-NumericLiteral loc 1))))]
       [(eq? op 'delete)
        (compile-deletion operand)]
       [else
        (with-syntax ([op-e (operator->syntax op)]
                      [operand-e (compile-expression operand)])
          (syntax/loc* loc
            (op-e operand-e)))])]
    [(struct InfixExpression (loc left '&& right))
     (with-syntax ([left-e (compile-expression left)]
                   [right-e (compile-expression right)])
       (syntax/loc* loc
         (if (true-value? left-e) right-e 'false)))]
    [(struct InfixExpression (loc left '\|\| right))
     (with-syntax ([left-e (compile-expression left)]
                   [right-e (compile-expression right)]
                   [(tmp) (generate-temporaries '(tmp))])
       (syntax/loc* loc
         (let ([tmp left-e])
           (if (true-value? tmp) tmp right-e))))]
    [(struct InfixExpression (loc left op right))
     (with-syntax ([left-e (compile-expression left)]
                   [op-e (operator->syntax op)]
                   [right-e (compile-expression right)])
       (syntax/loc* loc
         (op-e left-e right-e)))]
    [(struct ConditionalExpression (loc test consequent alternate))
     (with-syntax ([test-e (compile-expression test)]
                   [consequent-e (compile-expression consequent)]
                   [alternate-e (compile-expression alternate)])
       (syntax/loc* loc
         (if test-e consequent-e alternate-e)))]
    [(struct AssignmentExpression (loc left '= right))
     (compile-assignment left (compile-expression right))]
    [(struct AssignmentExpression (loc left op right))
     (compile-expression
      (make-AssignmentExpression loc
                                 left
                                 '=
                                 (make-InfixExpression (Term-location right)
                                                       left
                                                       (assignment-operator->infix-operator op)
                                                       right)))]
    [(struct FunctionExpression/hoisted (loc name args body funs vars))
     (compile-function loc name args body funs vars)]
    [(struct LetExpression (loc bindings body))
     (let-values ([(var-stx-ids add-vars bind-vars) (make-bindings (map VariableInitializer-id bindings)
                                                                   loc
                                                                   (map (compose compile-expression VariableInitializer-init) bindings))])
       (with-syntax ([body (parameterize ([static-environment (bind-vars (static-environment))])
                             (compile-expression body))])
         (add-vars (syntax/loc (region->syntax loc) body))))]
    ;; TODO: inherit environment if definitely a call to `eval' (10.2.2)
    [(struct CallExpression (loc (and method (struct BracketReference (_ container key))) args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [(container-val key-val function-val) (generate-temporaries '(container-val key-val function-val))]
                   [(arg-e ...) (map compile-expression args)]
                   [(arg-val ...) (generate-temporaries args)])
       (syntax/loc (region->syntax loc)
         (let* ([container-val container-e]
                [key-val key-e]
                [function-val (object-get container-val key-val)]
                [arg-val arg-e] ...)
           (parameterize ([current-this container-val])
             ;; TODO: what if there is no method?!
             (call function-val
                   (evector arg-val ...)
                   (lambda (str1 str2)
                     (raise-runtime-type-error stxloc str1 str2)))))))]
    [(struct CallExpression (loc (struct DotReference (_ container id)) args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [container-e (compile-expression container)]
                   [key-val (Identifier->key id)]
                   [(container-val function-val) (generate-temporaries '(container-val function-val))]
                   [(arg-e ...) (map compile-expression args)]
                   [(arg-val ...) (generate-temporaries args)])
       (syntax/loc (region->syntax loc)
         (let* ([container-val container-e]
                [function-val (object-get container-val key-val)]
                [arg-val arg-e] ...)
           (parameterize ([current-this container-val])
             ;; TODO: what if there is no method?!
             (call function-val
                   (evector arg-val ...)
                   (lambda (str1 str2)
                     (raise-runtime-type-error stxloc str1 str2)))))))]
    [(struct CallExpression (loc (? direct-eval? function) args))
     (let* ([unique-entries (delete-duplicates (static-environment) (lambda (e1 e2)
                                                                      (Identifier=? (car e1) (car e2))))]
            [all-identifiers-in-scope (map car unique-entries)])
       (with-syntax ([scope-chain scope-chain]
                     [(invisible-x ...) (map (lambda (id)
                                               (Identifier->syntax id #f))
                                             all-identifiers-in-scope)]
                     [(x-value ...) (map (lambda (entry)
                                           (let* ([id (car entry)]
                                                  [var (make-VarReference (Term-location id) id)])
                                             (compile-lookup var)))
                                         unique-entries)]
                     [stxloc (region->syntax loc)]
                     [(arg-e ...) (map compile-expression args)]
                     [(function-val arg-val ...) (generate-temporaries (cons 'function-val args))])
         (with-syntax ([base-chain (if (not (current-with-statement))
                                       #'(list (make-frame (object-table [invisible-x x-value] ...))
                                               global-object)
                                       #'scope-chain)])
           (syntax/loc (region->syntax loc)
             (if (original-eval?)
                 (direct-eval (evector arg-e ...)
                              (current-this)
                              base-chain)
                 (let ([function-val (object-get global-object "eval")]
                       [arg-val arg-e] ...)
                   (parameterize ([current-this global-object])
                     (call function-val
                           (evector arg-val ...)
                           (lambda (str1 str2)
                             (raise-runtime-type-error stxloc str1 str2))))))))))]
    [(struct CallExpression (loc function args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [function-e (compile-expression function)]
                   [(arg-e ...) (map compile-expression args)]
                   [(function-val arg-val ...) (generate-temporaries (cons 'function-val args))])
       (syntax/loc (region->syntax loc)
         (let ([function-val function-e]
               [arg-val arg-e] ...)
           (parameterize ([current-this global-object])
             (call function-val
                   (evector arg-val ...)
                   (lambda (str1 str2)
                     (raise-runtime-type-error stxloc str1 str2)))))))]
    [(struct ParenExpression (loc expr))
     (compile-expression expr)]
    [(struct ListExpression (loc (list)))
     #'(void)]
    [(struct ListExpression (loc exprs))
     (with-syntax ([(e ...) (map compile-expression exprs)])
       (syntax/loc* loc
         (begin e ...)))]
    ))