#lang racket

(require "../compiler/il-structs.rkt"
         "../compiler/lexical-structs.rkt"
         "../compiler/arity-structs.rkt"
         "../simulator/simulator-structs.rkt"
         "../simulator/simulator-primitives.rkt"
         "../simulator/simulator.rkt")

(printf "test-simulator.rkt\n")


(define-syntax (test stx)
  (syntax-case stx ()
    [(_ actual exp)
     (with-syntax ([stx stx])
       (syntax/loc #'stx
         (begin
           (printf "Running ~s ..." (syntax->datum #'stx))
           (let ([results actual])
             (unless (equal? results exp)
               (raise-syntax-error #f (format "Expected ~s, got ~s" exp results)
                                   #'stx)))
           (printf "ok\n\n"))))]))


;; take n steps in evaluating the machine.
(define (step-n m n)
  (cond
    [(= n 0)
     m]
    [else
     (step! m)
     (step-n m (sub1 n))]))


;; run: machine -> machine
;; Run the machine to completion.
(define (run! m)
  (cond
    [(can-step? m)
     (step! m)
     (run! m)]
    [else
     m]))


;; Infinite loop
(let ([m (new-machine `(hello world ,(make-GotoStatement (make-Label 'hello)))
                      #f)])
  (test (machine-pc (step-n m 0)) 0)
  (test (machine-pc (step-n m 1)) 1)
  (test (machine-pc (step-n m 1)) 2)
  (test (machine-pc (step-n m 1)) 1)
  (test (machine-pc (step-n m 1)) 2)
  (test (machine-pc (step-n m 1)) 1))


;; Assigning to val
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42)))
                      #f)])
  (test (machine-val m) (make-undefined))
  (step! m)
  (test (machine-val m) 42))

;; Assigning to proc
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const 42)))
                      #f)])
  (test (machine-proc m) (make-undefined))
  (step! m)
  (test (machine-proc m) 42))


;; Assigning to a environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 1 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42)))
                       #f)]
       [m (run! m)])
  (test (machine-env m) '(42)))

;; Assigning to a boxed environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))))]
       [m (run! m)])
  (test (machine-env m) (list (box 42))))



;; Copying boxes over
(let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))
                         ,(make-PushEnvironment 1 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                         (make-EnvLexicalReference 1 #t))))]
       [m (run! m)])
  (test (machine-env m) (list 42 (box 42))))

(let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))
                         ,(make-PushEnvironment 1 #f)))]
       [m (run! m)])
  (test (machine-env m) (list (make-undefined)
                              (box 42))))
(let* ([m (new-machine `(,(make-PushEnvironment 1 #t)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #t) (make-Const 42))
                         ,(make-PushEnvironment 1 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                         (make-EnvLexicalReference 1 #f))))]
       [m (run! m)])
  (test (machine-env m) (list (box 42)
                              (box 42))))




;; Assigning to another environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 2 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))))]
       [m (run! m)])
  (test (machine-env m) `(,(make-undefined) 42)))


;; Assigning to another environment reference
(let* ([m (new-machine `(,(make-PushEnvironment 2 #f)
                         ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 42))))]
       [m (run! m)])
  (test (machine-env m) `(42 ,(make-undefined))))


;; PushEnv
(let ([m (new-machine `(,(make-PushEnvironment 20 #f)))])
  (test (machine-env (run! m)) (build-list 20 (lambda (i) (make-undefined)))))


;; PopEnv
(let ([m (new-machine `(,(make-PushEnvironment 20 #f)
                        ,(make-PopEnvironment (make-Const 20) (make-Const 0))))])
  (test (machine-env (run! m)) '()))

(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
                        ,(make-PopEnvironment (make-Const 1) (make-Const 0))))])
  (test (machine-env (run! m)) '("dewey" "louie")))

(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
                        ,(make-PopEnvironment (make-Const 1) (make-Const 1))))])
  (test (machine-env (run! m)) '("hewie" "louie")))

(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
                        ,(make-PopEnvironment (make-Const 1) (make-Const 2))))])
  (test (machine-env (run! m)) '("hewie" "dewey")))

(let* ([m (new-machine `(,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const "hewie"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const "dewey"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const "louie"))
                        ,(make-PopEnvironment (make-Const 2) (make-Const 1))))])
  (test (machine-env (run! m)) '("hewie")))



;; PushControl
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        foo 
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
                        bar
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
                        baz
                        ))])
  (test (machine-control (run! m))
        (list (make-CallFrame (make-LinkedLabel 'bar 'bar) #f (make-hasheq) (make-hasheq))
              (make-CallFrame (make-LinkedLabel 'foo 'foo) #f (make-hasheq) (make-hasheq)))))



;; PopControl
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        foo 
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
                        bar
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
                        baz
                        ,(make-PopControlFrame)
                        ))])
  (test (machine-control (run! m))
        (list (make-CallFrame (make-LinkedLabel 'foo 'foo) #f (make-hasheq) (make-hasheq)))))

(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        foo 
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
                        bar
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'bar 'bar))
                        baz
                        ,(make-PopControlFrame)
                        ,(make-PopControlFrame)))])
  (test (machine-control (run! m))
        (list)))





;; TestAndBranch: try the true branch
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const 42))
                        ,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'on-false)
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        ,(make-GotoStatement (make-Label 'end))
                        on-false
                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                        end))])
  (test (machine-val (run! m))
        'ok))
;; TestAndBranch: try the false branch
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const #f))
                        ,(make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) 'on-false)
                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                        ,(make-GotoStatement (make-Label 'end))
                        on-false
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        end))])
  (test (machine-val (run! m))
        'ok))
;; Test for primitive procedure
(let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const '+))
                        ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        ,(make-GotoStatement (make-Label 'end))
                        on-true
                        ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
                        end))])
  (test (machine-val (run! m))
        'ok))


;; ;; Give a primitive procedure in val
;; (let ([m (new-machine `(,(make-AssignImmediateStatement 'val (make-Const (lookup-primitive '+)))
;;                         ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
;;                         ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
;;                         ,(make-GotoStatement (make-Label 'end))
;;                         on-true
;;                         ,(make-AssignImmediateStatement 'val (make-Const 'ok))
;;                         end))])
;;   (test (machine-val (run! m))
;;         'ok))
;; ;; Give a primitive procedure in proc, but test val
;; (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
;;                         ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'on-true)
;;                         ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
;;                         ,(make-GotoStatement (make-Label 'end))
;;                         on-true
;;                         ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
;;                         end))])
;;   (test (machine-val (run! m))
;;         'not-a-procedure))
;; ;; Give a primitive procedure in proc and test proc
;; (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const (lookup-primitive '+)))
;;                         ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'proc)) 'on-true)
;;                         ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
;;                         ,(make-GotoStatement (make-Label 'end))
;;                         on-true
;;                         ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
;;                         end))])
;;   (test (machine-val (run! m))
;;         'a-procedure))





;; AssignPrimOpStatement
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))])
  (test (first (machine-env (run! m)))
        (make-toplevel '(+ - * =)
                       (list (lookup-primitive '+)
                             (lookup-primitive '-)
                             (lookup-primitive '*)
                             (lookup-primitive '=)))))

(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                        ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))))])
  (test (machine-env (run! m))
        (list (make-toplevel '(some-variable) (list "Danny")))))

(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another)))
                        ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))))])
  (test (machine-env (run! m))
        (list (make-toplevel '(some-variable another) (list (make-undefined) "Danny")))))

(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                        ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                        ,(make-PushEnvironment 5 #f)
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 5 0) (make-Reg 'val))))])
  (test (machine-env (run! m))
        (list (make-undefined) (make-undefined) (make-undefined) (make-undefined) (make-undefined)
              (make-toplevel '(some-variable) (list "Danny")))))




;; check-toplevel-bound
;; This should produce an error.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                        ,(make-PerformStatement (make-CheckToplevelBound! 0 0))))])
  (with-handlers ((exn:fail? (lambda (exn)
                               (void))))
    
    (run! m)
    (raise "I expected an error")))

;; check-toplevel-bound shouldn't fail here.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
                        ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
                        ,(make-PerformStatement (make-CheckToplevelBound! 0 0))))])
  (void (run! m)))



;; install-closure-values
(let ([m  
       (make-machine (make-undefined) 
                     (make-closure 'procedure-entry
                                   0
                                   (list 1 2 3)
                                   'procedure-entry)
                     (make-undefined)
                     (list true false) ;; existing environment holds true, false
                     '() 
                     0 
                     (list->vector `(,(make-PerformStatement (make-InstallClosureValues!))
                                     procedure-entry))
                     (make-hash)
                     0
                     (make-hash))])
  (test (machine-env (run! m))
        ;; Check that the environment has installed the expected closure values.
        (list 1 2 3 true false)))


;; get-compiled-procedure-entry
(let ([m 
       (make-machine (make-undefined) 
                     (make-closure 'procedure-entry 0 (list 1 2 3) 'procedure-entry)
                     (make-undefined)
                     (list true false) ;; existing environment holds true, false
                     '() 
                     0 
                     (list->vector `(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))))
                     (make-hash)
                     0
                     (make-hash))])
  (test (machine-val (run! m))
        'procedure-entry))


;; make-compiled-procedure, with empty closure set
(let ([m (new-machine `(,(make-AssignPrimOpStatement 
                          'val
                          (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
                        ,(make-GotoStatement (make-Label 'end))
                        procedure-entry
                        end
                        ))])
  (test (machine-val (run! m))
        (make-closure 'procedure-entry 0 (list) 'procedure-entry)))

;; make-compiled-procedure: Capturing a few variables.
(let ([m (new-machine `(,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 'curly))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
                        ,(make-AssignPrimOpStatement 
                          'val
                          (make-MakeCompiledProcedure 'procedure-entry 
                                                      0 
                                                      (list 0 2)
                                                      'procedure-entry))
                        ,(make-GotoStatement (make-Label 'end))
                        procedure-entry
                        end
                        ))])
  (test (machine-val (run! m))
        (make-closure 'procedure-entry 0 (list 'larry 'moe)
                      'procedure-entry)))

;; make-compiled-procedure: Capturing a toplevel.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
                        ,(make-AssignImmediateStatement 'val (make-Const "x"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
                        ,(make-AssignImmediateStatement 'val (make-Const "y"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))
                        ,(make-AssignImmediateStatement 'val (make-Const "z"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2) (make-Reg 'val))
                        ,(make-AssignPrimOpStatement 
                          'val
                          (make-MakeCompiledProcedure 'procedure-entry 
                                                      0
                                                      (list 0)
                                                      'procedure-entry))
                        ,(make-GotoStatement (make-Label 'end))
                        procedure-entry
                        end
                        ))])
  (test (machine-val (run! m))
        (make-closure 'procedure-entry 0 (list (make-toplevel '(x y z) (list "x" "y" "z")))
                      'procedure-entry)))

;; make-compiled-procedure: Capturing both a toplevel and some lexical values
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
                        ,(make-AssignImmediateStatement 'val (make-Const "x"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))
                        ,(make-AssignImmediateStatement 'val (make-Const "y"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))
                        ,(make-AssignImmediateStatement 'val (make-Const "z"))
                        ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2) (make-Reg 'val))

                        ,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 'curly))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
                        ,(make-AssignPrimOpStatement 
                          'val
                          (make-MakeCompiledProcedure 'procedure-entry 
                                                      0
                                                      (list 3 0 2)
                                                      'procedure-entry))
                        ,(make-PopEnvironment (make-Const 3) (make-Const 0))
                        ,(make-GotoStatement (make-Label 'end))
                        procedure-entry
                        end
                        ))])
  (test (machine-val (run! m))
        (make-closure 'procedure-entry 
                      0
                      (list (make-toplevel '(x y z) (list "x" "y" "z"))
                            'larry
                            'moe)
                      'procedure-entry)))


;; Test toplevel lookup
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
                        ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))))])
  (test (machine-val (run! m))
        (lookup-primitive '+)))

;; Test lexical lookup
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
                        ,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 'curly))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
                        
                        ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))))])
  (test (machine-val (run! m))
        'larry))
;; Another lexical lookup test
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
                        ,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 'curly))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f) (make-Const 'moe))
                        
                        ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 1 #f))))])
  (test (machine-val (run! m))
        'curly))

;; ApplyPrimitiveProcedure
;; Adding two numbers
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
                        ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
                        ,(make-PushEnvironment 2 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))
                        ,(make-AssignImmediateStatement 'argcount (make-Const 2))
                        ,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure))
                        after))])
  (test (machine-val (run! m))
        (+ 126389 42))
  
  (test (machine-env (run! m))
        (list 126389 42 (make-toplevel '(+) (list (lookup-primitive '+))))))


;; ControlStackLabel
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        foo
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo 'foo))
                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))))])
  (test (machine-proc (run! m))
        'foo))


;; ControlStackLabel
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
                        ,(make-GotoStatement (make-Reg 'proc))
                        foo-single
                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
                        ,(make-GotoStatement (make-Label 'end))
                        foo-multiple
                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
                        ,(make-GotoStatement (make-Label 'end))
                        end))])
  (test (machine-val (run! m))
        "single"))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        ,(make-PushControlFrame/Call (make-LinkedLabel 'foo-single 'foo-multiple))
                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
                        ,(make-GotoStatement (make-Reg 'proc))
                        foo-single
                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
                        ,(make-GotoStatement (make-Label 'end))
                        foo-multiple
                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
                        ,(make-GotoStatement (make-Label 'end))
                        end))])
  (test (machine-val (run! m))
        "multiple"))


(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        ,(make-PushControlFrame/Prompt default-continuation-prompt-tag
                                                       (make-LinkedLabel 'foo-single 'foo-multiple))
                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
                        ,(make-GotoStatement (make-Reg 'proc))
                        foo-single
                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
                        ,(make-GotoStatement (make-Label 'end))
                        foo-multiple
                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
                        ,(make-GotoStatement (make-Label 'end))
                        end))])
  (test (machine-val (run! m))
        "single"))
(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
                        ,(make-PushControlFrame/Prompt default-continuation-prompt-tag
                                                       (make-LinkedLabel 'foo-single 'foo-multiple))
                        ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
                        ,(make-GotoStatement (make-Reg 'proc))
                        foo-single
                        ,(make-AssignImmediateStatement 'val (make-Const "single"))
                        ,(make-GotoStatement (make-Label 'end))
                        foo-multiple
                        ,(make-AssignImmediateStatement 'val (make-Const "multiple"))
                        ,(make-GotoStatement (make-Label 'end))
                        end))])
  (test (machine-val (run! m))
        "multiple"))



;; Splicing
(let ([m (new-machine `(,(make-PushEnvironment 1 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                        (make-Const '(1 2 3)))
                        ,(make-AssignImmediateStatement 'argcount (make-Const 1))
                        ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 0)))))])
  (run! m)
  (test (machine-argcount m)
        3)
  (test (machine-env m)
        '(1 2 3)))
                      


(let ([m (new-machine `(,(make-PushEnvironment 3 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                        (make-Const "hello"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                                        (make-Const "world"))
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
                                                        (make-Const '(1 2 3)))
                        ,(make-AssignImmediateStatement 'argcount (make-Const 3))
                        ,(make-PerformStatement (make-SpliceListIntoStack! (make-Const 2)))))])
  (run! m)
  (test (machine-argcount m)
        5)
  (test (machine-env m)
        '("hello" "world" 1 2 3)))




;; Testing immediate pushing
(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
                                                            #f)))])
  (run! m)
  (test (machine-env m)
        '("this is a message")))

(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
                                                            #t)))])
  (run! m)
  (test (machine-env m)
        `(,(box "this is a message"))))


(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
                                                            #f)
                        ,(make-PushImmediateOntoEnvironment (make-Const "again")
                                                            #f)
                        ))])
  (run! m)
  (test (machine-env m)
        '("again" "this is a message")))

(let ([m (new-machine `(,(make-PushImmediateOntoEnvironment (make-Const "this is a message")
                                                            #f)
                        ,(make-PushImmediateOntoEnvironment (make-Const "again")
                                                            #t)
                        ))])
  (run! m)
  (test (machine-env m)
        `(,(box "again") "this is a message")))
                           





;; testing rest splicing
(let ([m (new-machine `(,(make-PushEnvironment 1 #f)
                        ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                                        (make-Const "hello"))
                        ,(make-AssignImmediateStatement 'argcount (make-Const 1))
                        ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0)
                                                                             (make-Const 1)))))])
  (run! m)
  (test (machine-argcount m)
        1)
  (test (machine-env m)
        (list (make-MutablePair "hello" null))))


(let ([m (new-machine 
          `(,(make-PushEnvironment 5 #f)
            ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
                                            (make-Const "hello"))
            ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
                                            (make-Const "world"))
            ,(make-AssignImmediateStatement (make-EnvLexicalReference 2 #f)
                                            (make-Const 'x))
            ,(make-AssignImmediateStatement (make-EnvLexicalReference 3 #f)
                                                        (make-Const 'y))
            ,(make-AssignImmediateStatement (make-EnvLexicalReference 4 #f)
                                            (make-Const 'z))
            ,(make-AssignImmediateStatement 'argcount (make-Const 5))
            ,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2)  (make-Const 3)))))])
  (run! m)
  (test (machine-argcount m)
        3)
  (test (machine-env m)
        (list "hello"
              "world"
              (make-MutablePair 'x (make-MutablePair 'y (make-MutablePair 'z null))))))







;; Check closure mismatch.  Make sure we're getting the right values from the test.
(let ([m (new-machine `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
                          'bad)
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        ,(make-GotoStatement (make-Label 'end))
                        bad
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        end))])
  (test (machine-val (run! m))
        'ok))

(let ([m (new-machine `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1))
                          'ok)
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        ,(make-GotoStatement (make-Label 'end))
                        ok
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        end))])
  (test (machine-val (run! m))
        'ok))

(let ([m (new-machine `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
                          'ok)
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        ,(make-GotoStatement (make-Label 'end))
                        ok
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        end))])
  (test (machine-val (run! m))
        'ok))

(let ([m (new-machine `(procedure-entry
                        ;; doesn't matter about the procedure entry...
                        ,(make-AssignPrimOpStatement 
                          'proc
                          (make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
                        ,(make-TestAndJumpStatement
                          (make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2))
                          'bad)
                        ,(make-AssignImmediateStatement 'val (make-Const 'ok))
                        ,(make-GotoStatement (make-Label 'end))
                        bad
                        ,(make-AssignImmediateStatement 'val (make-Const 'bad))
                        end))])
  (test (machine-val (run! m))
        'ok))