let /* Booleans */

    type bool = int
    var true  := 1
    var false := 0

    /* Settings */

    var IS_NIL_TRUTHY     : bool := false
    var HAS_NIL_SYMBOL    : bool := false
    var DEBUG_PRINT_STACK : bool := false


    /* Basic utility */

    function concatm ( s1: string
                     , s2: string
                     , s3: string
                     , s4: string
                     , s5: string ): string =
         concat(s1, concat(s2, concat(s3, concat(s4, s5))))

    function string_to_unsigned_int (str: string): int =
      let var value := 0
      in for i := 0 to size(str) - 1
          do value := value * 10 + (ord(substring(str, i, 1))-ord("0"))
       ; value
      end

    function string_to_int (str: string): int =
      if size(str) > 1 & substring(str, 0, 1) = "-"
      then - string_to_unsigned_int(substring(str, 1, size(str)-1))
      else   string_to_unsigned_int(str)

    function i2s (i: int): string =
      if i = 0 /* TAKEN FROM FREKSEN LISP. TODO REPLACE */
      then "0"
      else if i < 0
      then concat("-", i2s(-i))
      else if i < 10
      then chr(ord("0") + i)
      else concat(i2s(i / 10),
                  chr(ord("0") + i - (i / 10) * 10))

    function int_to_string (i: int): string = i2s(i)

    function is_integer_string (s: string): int =
      s = int_to_string(string_to_int(s))

    function max (a: int, b: int): int =
      if a > b then a else b

    function min (a: int, b: int): int =
      if a < b then a else b

    function safe_substring (str: string, i_start: int, i_end: int): string =
      ( i_start := max(0, i_start)
      ; i_end   := min(size(str) - 1, i_end)
      ; substring(str, i_start, i_end - i_start + 1) )

    /* Scheme value system */

    type type_type = int

    type scheme_value = { typ   : type_type
                        , val_i : int
                        , val_s : string
                        , val_e : scheme_environment
                        , val_car : scheme_value
                        , val_cdr : scheme_value

                        , pos_l: int
                        , pos_r: int }

    type vm_env_key  = string
    type vm_env_elem = scheme_value
    type vm_env = { key: vm_env_key, value: vm_env_elem, next: vm_env }
    type scheme_environment = vm_env

    var type_integer   := 0
    var type_string    := 1
    var type_symbol    := 2
    var type_closure   := 3
    var type_nil       := 4
    var type_false     := 5
    var type_true      := 6
    var type_pair      := 7

    function value_to_string (base_v: scheme_value): string =
      let function val_rec (v          : scheme_value
                           , req_paren : bool): string =
            if v = nil
               then ( print("Error in value_to_string: Got nil value.\n")
                    ; "<???>" )
            else if v.typ = type_integer
               then int_to_string(v.val_i)

            else if v.typ = type_string
               then concat("\"", concat(v.val_s, "\""))

            else if v.typ = type_symbol
               then v.val_s

            else if v.typ = type_closure
               then concat("<fun at ", concat(int_to_string(v.val_i), ">"))

            else if v.typ = type_nil
               then "()"

            else if v.typ = type_false
               then "#f"

            else if v.typ = type_true
               then "#t"

            else if v.typ = type_pair & v.val_cdr.typ = type_nil
               then let
                    in concatm ( if req_paren then "(" else ""
                               , val_rec(v.val_car, true)
                               , if req_paren then ")" else ""
                               , ""
                               , "" )
                    end

            else if v.typ = type_pair
               then let var is_real := v.val_cdr.typ = type_pair
                    in concatm ( if req_paren then "(" else ""
                               , val_rec(v.val_car, true)
                               , if is_real then " " else " . "
                               , val_rec(v.val_cdr, not(is_real))
                               , if req_paren then ")" else "" )
                    end

            else ( print("Error in value_to_string: Unknown type.\n")
                 ; "<???>" )
      in val_rec(base_v, true)
      end

    function is_truthy (e: scheme_value): bool =
        e <> nil
      & e.typ <> type_false
      & (IS_NIL_TRUTHY | e.typ <> type_nil)

    function is_integer (e: scheme_value): bool =
      e <> nil & e.typ = type_integer

    function is_string (e: scheme_value): bool =
      e <> nil &e.typ = type_string

    function is_function (e: scheme_value): bool =
      e <> nil &e.typ = type_closure

    function is_pair (e: scheme_value): bool =
      e <> nil &e.typ = type_pair

    function is_symbol (e: scheme_value): bool =
      e <> nil &e.typ = type_symbol

    function int_val (i: int): scheme_value =
      scheme_value { typ   = type_integer
                   , val_i = i
                   , val_s = ""
                   , val_e = nil

                   , val_car = nil
                   , val_cdr = nil

                   , pos_l = -1
                   , pos_r = -1 }

    function str_val (s: string): scheme_value =
      scheme_value { typ   = type_string
                   , val_i = 0
                   , val_s = s
                   , val_e = nil
                   , val_car = nil
                   , val_cdr = nil

                   , pos_l = -1
                   , pos_r = -1 }


    function fun_val (i: int, env: scheme_environment): scheme_value =
      scheme_value { typ   = type_closure
                   , val_i = i
                   , val_s = ""
                   , val_e = env
                   , val_car = nil
                   , val_cdr = nil

                   , pos_l = -1
                   , pos_r = -1 }

    function bool_val (i: int): scheme_value =
       scheme_value { typ = if (i <> 0)
                            then type_true
                            else type_false
                    , val_i = i <> 0
                    , val_s = ""
                    , val_e = nil
                    , val_car = nil
                    , val_cdr = nil

                    , pos_l = -1
                    , pos_r = -1 }

    function pair_val (car: scheme_value, cdr: scheme_value): scheme_value =
       scheme_value { typ = type_pair
                    , val_i = 0
                    , val_s = ""
                    , val_e = nil
                    , val_car = car
                    , val_cdr = cdr

                    , pos_l = -1
                    , pos_r = -1 }

    function sym_val (sym: string): scheme_value =
       scheme_value { typ = type_symbol
                    , val_i = 0
                    , val_s = sym
                    , val_e = nil
                    , val_car = nil
                    , val_cdr = nil

                    , pos_l = -1
                    , pos_r = -1 }

    function nil_val (): scheme_value =
       scheme_value { typ   = type_nil
                    , val_i = 0
                    , val_s = ""
                    , val_e = nil
                    , val_car = nil
                    , val_cdr = nil

                    , pos_l = -1
                    , pos_r = -1 }

    var VALUE_UNSPECIFIED := nil_val()

    /* Parsing */

    type sexp_ast = scheme_value

    function parse_string (str: string): sexp_ast =
      let var index := 0

          function is_ws (index: int): int =
            let var ascii := ord(substring(str, index, 1))
            in ascii = 32 | ascii = 9 | ascii = 10
            end

          function is_left_paren (index: int): int =
            let var ascii := ord(substring(str, index, 1))
            in ascii = 40
            end

          function is_right_paren (index: int): int =
            let var ascii := ord(substring(str, index, 1))
            in ascii = 41
            end

          function is_comment_start (index: int): int =
            let var ascii := ord(substring(str, index, 1))
            in ascii = ord(";")
            end

          function is_tick (index: int): int =
            let var ascii := ord(substring(str, index, 1))
            in ascii = ord("'")
            end

          function is_symbol (index: int): int =
            let var ascii := ord(substring(str, index, 1))
            in not ( ascii = 9
                   | ascii = 10
                   | ascii = 32
                   | ascii = 40
                   | ascii = 41
                   | ascii = ord("'") )
            end

          function sexp_nil (pos_l: int, pos_r: int): sexp_ast =
              sexp_ast { typ   = type_nil
                       , val_i = 0
                       , val_s = ""
                       , val_e = nil
                       , val_car   = nil
                       , val_cdr   = nil
                       , pos_l = pos_l
                       , pos_r = pos_r }

          function sexp_atom (sym: string, pos_l: int, pos_r: int): sexp_ast =
              let var val := if sym = "#f"
                               then bool_val(0)
                             else if sym = "#t"
                               then bool_val(1)
                             else if is_integer_string(sym)
                               then int_val(string_to_int(sym))
                             else sym_val(sym)
              in val.pos_l := pos_l
               ; val.pos_r := pos_r
               ; val
              end

          function sexp_quote (datum: sexp_ast, pos_l: int, pos_r: int): sexp_ast =
              sexp_pair( sexp_atom( "quote", pos_l, pos_r)
                       , sexp_pair( datum, sexp_nil(pos_l, pos_r)
                                  , pos_l, pos_r)
                       , pos_l, pos_r )

          function sexp_pair ( car: sexp_ast
                             , cdr: sexp_ast
                             , pos_l: int
                             , pos_r: int): sexp_ast =
              sexp_ast { typ   = type_pair
                       , val_i = 0
                       , val_s = ""
                       , val_e = nil
                       , val_car   = car
                       , val_cdr   = cdr
                       , pos_l = pos_l
                       , pos_r = pos_r }

          function ignore_ws () =
            /* Ignore whitespace */
            if index < size(str) & is_ws(index)
              then (index := index + 1; ignore_ws())

            /* Handle comments, ignore until newline */
            else if is_comment_start(index)
              then ( while ord(substring(str, index, 1)) <> ord("\n")
                        do index := index + 1
                   ; ignore_ws())


          function parse_rec (): sexp_ast =
            ( ignore_ws()
            ; if is_symbol(index)
                then  let var index_start := index
                      in while is_symbol(index)
                            do index := index + 1
                       ; sexp_atom( substring(str, index_start, index - index_start)
                                  , index_start
                                  , index - 1 )
                      end

              else if is_tick(index)
                then  let var index_start := index
                          var datum := ( index := index + 1
                                       ; parse_rec() )
                          var exp   := sexp_quote(datum, index_start, index)

                      in exp
                      end

              else if is_left_paren(index)
                then  let var sexp      : sexp_ast := nil
                          var sexp_last : sexp_ast := nil
                          var index_start := index
                          var most_right  := index

                      in index := index + 1 /* Position after index */
                       ; while index < size(str) & not(is_right_paren(index))
                            do let var parsed := parse_rec()
                                   var link := sexp_pair( parsed
                                                        , sexp_nil(index, index)
                                                        , parsed.pos_l
                                                        , parsed.pos_r )

                                   /* Initial link */
                               in if sexp = nil
                                  then ( sexp_last     := link
                                       ; sexp          := sexp_last )

                                    /* In case of . syntax. For
                                     * example: (a . b) */
                                    /* TODO: Below is ugly! */
                                  else if parsed.typ = type_symbol
                                        & parsed.val_s = "."
                                    then ( index := index + 1
                                         ; sexp_last.val_cdr := parse_rec()
                                         ; link.pos_r := sexp_last.val_cdr.pos_r )

                                    /* Continue along with sexp
                                     * parsing */
                                  else ( sexp_last.val_cdr := link
                                       ; sexp_last     := sexp_last.val_cdr )
                                ; most_right    := max(link.pos_r, most_right)
                                ; ignore_ws()
                               end

                       /* Error handling */
                       ; if index >= size(str)
                               then parse_error("Misaligned parenthesis")
                         /*else if index = index_start + 1
                               then parse_error("Encountered unit
                               expression (); is not allowed
                               Scheme.")*/

                       /* Give correct positions */
                       ; sexp_last := sexp
                       ; while sexp_last <> nil
                            do ( sexp_last.pos_r := most_right
                               ; sexp_last       := sexp_last.val_cdr )
                       ; if sexp <> nil
                         then ( sexp.pos_l := sexp.pos_l - 1
                              ; sexp.pos_r := sexp.pos_r + 1 )

                       /* Continue with stuff */
                       ; index := index + 1
                       ; if sexp = nil
                         then sexp_nil(index_start, most_right)
                         else sexp
                      end
              else (parse_error("Error: I don't even!"); nil))

          function parse_error(errmsg: string) =
            let
            in print("Tiger-scheme parse error\n    ")
             ; print(errmsg)
             ; print("\n    At index: ")
             ; print(int_to_string(index))
             ; print("\n    Nearby:   ")
             ; print(safe_substring(str, index-10, index+10))
             ; print("\n")
            end

      in parse_rec()
      end

    function sexp_ast_to_string (ast: sexp_ast): string =
      let function tostr_rec (ast: sexp_ast, nil_implicit: int): string =
            if ast = nil then "SOMEBODY FUCKED UP"
            else if ast.typ = type_nil & nil_implicit
                 then ""
            else if ast.typ = type_pair & ast.val_car.typ <> type_pair
                 then let var s_left  := tostr_rec(ast.val_car, 0)
                          var s_right := tostr_rec(ast.val_cdr, 1)
                      in concat(s_left, if s_right <> ""
                                        then concat(" ", s_right)
                                        else "")
                      end

            else if ast.typ = type_pair
                 then let var s_left  := tostr_rec(ast.val_car, 0)
                          var s_right := tostr_rec(ast.val_cdr, 1)
                      in concat("(",
                         concat(s_left,
                         concat(")", if s_right <> ""
                                     then concat(" ", s_right)
                                     else "")))
                      end
            else ast.val_s
      in concat("(", concat(tostr_rec(ast, 0), ")"))
      end

   /**** Instructions ****/

   type vm_insn = { opcode: int
                  , arg1: int
                  , arg2: string
                  , arg3: scheme_value
                  , pos_l: int
                  , pos_r: int }

   type vm_tape_tape = array of vm_insn
   type vm_tape      = { length: int, tape: vm_tape_tape }

   type vm_insn_info = { opcode    : int
                       , mnemonic  : string
                       , uses_arg1 : int
                       , uses_arg2 : int
                       , uses_arg3 : int }
   type vm_insn_info_l = array of vm_insn_info

   var OPCODE_ADD    := 0
   var OPCODE_PUSH   := 1
   var OPCODE_GOTO   := 2
   var OPCODE_CSKIP  := 3
   var OPCODE_DUPL   := 4
   var OPCODE_SWITCH := 5
   var OPCODE_MULT   := 6
   var OPCODE_LOAD   := 7
   var OPCODE_CALL   := 9
   var OPCODE_RET    := 10
   var OPCODE_DGOTO  := 11
   var OPCODE_DEF    := 12
   var OPCODE_SETG   := 8
   var OPCODE_DEFFUN := 13
   var OPCODE_POP    := 14
   var OPCODE_GEQ    := 15
   var OPCODE_OUTPUT := 17
   var OPCODE_TOSTR  := 18
   var OPCODE_CONS   := 19
   var OPCODE_CAR    := 20
   var OPCODE_CDR    := 16
   var OPCODE_SET    := 21
   var OPCODE_FRSTR  := 22
   var OPCODE_COMPILE:= 23

   var vm_insn_num_opcodes  := 0
   var vm_insn_info :=
     let var expected_number_opcodes := 30
         var a := vm_insn_info_l [expected_number_opcodes] of nil
         function code ( opcode    : int
                       , mnemonic  : string
                       , uses_arg1 : int
                       , uses_arg2 : int
                       , uses_arg3 : int ) =
            ( if a[opcode] <> nil
              then print(concatm( "Error: Overwriting previously defined opcode information!\n    Opcode: "
                                , int_to_string(opcode)
                                , " with previous mnenomic "
                                , a[opcode].mnemonic
                                , "\n"))
            ; a[opcode] := vm_insn_info  { opcode   = opcode
                                         , mnemonic  = mnemonic
                                         , uses_arg1 = uses_arg1
                                         , uses_arg2 = uses_arg2
                                         , uses_arg3 = uses_arg3 }
            ; vm_insn_num_opcodes := vm_insn_num_opcodes + 1 )

     in code(OPCODE_ADD,    "ADD",     0, 0, 0)
      ; code(OPCODE_PUSH,   "PUSH",    0, 0, 1)
      ; code(OPCODE_GOTO,   "GOTO",    1, 0, 0)
      ; code(OPCODE_DGOTO,  "DGOTO",   1, 0, 0)
      ; code(OPCODE_CSKIP,  "CSKIP",   0, 0, 0)
      ; code(OPCODE_DUPL,   "DUPL",    1, 0, 0)
      ; code(OPCODE_SWITCH, "SWITCH",  0, 0, 0)
      ; code(OPCODE_MULT,   "MULT",    0, 0, 0)
      ; code(OPCODE_LOAD,   "LOAD",    0, 1, 0)

      ; code(OPCODE_CALL,   "CALL",    1, 0, 0)
      ; code(OPCODE_RET,    "RET",     1, 0, 0)

      ; code(OPCODE_DEF,    "DEF",     0, 1, 0)
      ; code(OPCODE_SETG,   "SETG",    0, 1, 0)
      ; code(OPCODE_DEFFUN, "DEFFUN",  1, 0, 0)
      ; code(OPCODE_POP,    "POP",     0, 0, 0)
      ; code(OPCODE_GEQ,    "GEQ",     0, 0, 0)

      ; code(OPCODE_CONS, "CONS",  0, 0, 0)
      ; code(OPCODE_CAR,  "CAR",   0, 0, 0)
      ; code(OPCODE_CDR,  "CDR",   0, 0, 0)
      ; code(OPCODE_SET,  "SET",   0, 1, 0)

      ; code(OPCODE_OUTPUT, "OUTPUT",  0, 0, 0)
      ; code(OPCODE_TOSTR,  "TOSTR",   0, 0, 0)
      ; code(OPCODE_FRSTR,  "FRSTR",   0, 0, 0)

      ; code(OPCODE_COMPILE,"COMPILE",   0, 0, 0)

      ; for i := 1 to expected_number_opcodes - 1
        do if a[i] <> nil & a[i-1] = nil
           then print(concatm("Error: Opcode info array incorrectly initialized!\n  Opcode "
                             , int_to_string(i)
                             , " is declared, but "
                             , int_to_string(i-1)
                             , " is not!"))

      ; print("Virtual Machine possess ")
      ; print(int_to_string(vm_insn_num_opcodes))
      ; print(" instructions. Has space for ")
      ; print(int_to_string(expected_number_opcodes))
      ; print(".\n")
      ; a
     end

   function noop_insn (pos_l: int, pos_r: int): vm_insn =
      vm_insn { opcode = OPCODE_DGOTO
              , arg1   = 1
              , arg2   = ""
              , arg3   = nil
              , pos_l  = pos_l
              , pos_r  = pos_r }

   /**** Compile to VM ****/

   type vm_insn_list_link = { insn: vm_insn, next: vm_insn_list_link }
   type vm_insn_list      = { first: vm_insn_list_link, last: vm_insn_list_link }

   function concat_lists (a: vm_insn_list, b: vm_insn_list): vm_insn_list =
     ( if a = nil
          then print("Error: Impossible concat\n")
       else if b = nil | b.first = nil
          then ()
       else if (a.first = nil & a.last <> nil) | (a.first <> nil & a.last = nil)
          then print(concatm( "Error: Instruction list invariant not maintained! First is "
                            , if a.first = nil then "" else "not "
                            ,  "nil, second is "
                            , if a.last = nil then "" else "not "
                            , "nil\n"))
       else if a.first = nil
          then ( a.first := b.first
               ; a.last  := b.last )
       else ( a.last.next := b.first
            ; a.last      := b.last )
     ; a )

   function single_insn (insn: vm_insn): vm_insn_list =
       let var link := vm_insn_list_link { insn = insn, next = nil }
       in vm_insn_list { first = link, last = link }
       end

   function app_insn (insns: vm_insn_list, opcode:int, arg1: int, arg2: string, pos_l: int, pos_r: int) =
      ( concat_lists(insns, single_insn(vm_insn { opcode = opcode
                                                , arg1   = arg1
                                                , arg2   = arg2
                                                , arg3   = nil
                                                , pos_l  = pos_l
                                                , pos_r  = pos_r }))
      ; ())

   function app_insn2 (insns: vm_insn_list, opcode:int, arg3: scheme_value, pos_l: int, pos_r: int) =
      ( concat_lists(insns, single_insn(vm_insn { opcode = opcode
                                                , arg1   = 0
                                                , arg2   = ""
                                                , arg3   = arg3
                                                , pos_l  = pos_l
                                                , pos_r  = pos_r }))
      ; ())

   function tail_position (prev_insns: vm_insn_list, return_now: bool, pos_l: int, pos_r: int) =
     if return_now
       then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r)

   function tail_position_one (insn: vm_insn, return_now: bool, pos_l: int, pos_r: int): vm_insn_list =
     let var insns := single_insn(insn)
     in tail_position(insns, return_now, pos_l, pos_r)
      ; insns
     end

   function insn_list_length (insns: vm_insn_list): int =
     let var len  := 0
         var head := insns.first
     in while head <> nil
           do ( len  := len + 1
              ; head := head.next )
      ; len
     end


   var STD_LIB_ENV: vm_env := nil
   var STD_LIB_ID_FUNCTION: scheme_value := nil

   var STD_LIB := let var first_insn := noop_insn(-1, -1)

                      var std_insns  := single_insn(first_insn)

                      function app (opcode: int, arg1: int, arg2: string) =
                           app_insn(std_insns, opcode, arg1, arg2, -1, -1)

                      function app2 (opcode: int, arg3: scheme_value) =
                           app_insn2(std_insns, opcode, arg3, -1, -1)

                      function stdval (name: string, value: scheme_value) =
                        STD_LIB_ENV := vm_env { key   = name
                                              , value = value
                                              , next  = STD_LIB_ENV }

                      function tape_pos (): int =
                        insn_list_length(std_insns)

                      function stdfun (name: string) =
                        stdval(name, fun_val(tape_pos(), nil))

                  in ()

                     /* Nil */
                   ; if HAS_NIL_SYMBOL
                     then stdval("nil", nil_val())

                    /* Identity function */
                   ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
                   ; app(OPCODE_RET,    1, "")

                    /* Useful standard functions */
                   ; stdfun("display")
                   ; app(OPCODE_TOSTR,  0, "")
                   ; app(OPCODE_OUTPUT, 0, "")
                   ; app2(OPCODE_PUSH,  VALUE_UNSPECIFIED)
                   ; app(OPCODE_RET,    1, "")

                   ; stdfun("newline")
                   ; app2(OPCODE_PUSH,  str_val("\n"))
                   ; app(OPCODE_OUTPUT, 0, "")
                   ; app2(OPCODE_PUSH,  VALUE_UNSPECIFIED)
                   ; app(OPCODE_RET,    1, "")

                   ; stdfun("cons")
                   ; app(OPCODE_CONS,   0, "")
                   ; app(OPCODE_RET,    1, "")

                   ; stdfun("car")
                   ; app(OPCODE_CAR,    0, "")
                   ; app(OPCODE_RET,    1, "")

                   ; stdfun("cdr")
                   ; app(OPCODE_CDR,    0, "")
                   ; app(OPCODE_RET,    1, "")

                   ; first_insn.arg1 := insn_list_length(std_insns)
                   ; std_insns
                  end


   function compile_to_vm (ast: sexp_ast): vm_tape =
     let function list (head: vm_insn_list_link): vm_insn_list =
           let var tail := head
           in while tail <> nil & tail.next <> nil
                 do tail := tail.next
            ; vm_insn_list { first = head, last = tail }
           end

         function copy_list (ls: vm_insn_list): vm_insn_list =
           list(ls.first)

         function atom_to_insn (sym: scheme_value, pos_l: int, pos_r: int): vm_insn =
            if sym = nil
                then ( print("Error in atom_to_list: Got nil as sym!\n")
                     ; nil )
            else if is_symbol(sym)
                then vm_insn { opcode = OPCODE_LOAD
                             , arg1   = 0
                             , arg2   = sym.val_s
                             , arg3   = nil
                             , pos_l  = pos_l
                             , pos_r  = pos_r }
            else vm_insn { opcode = OPCODE_PUSH
                         , arg1   = 0
                         , arg2   = ""
                         , arg3   = sym
                         , pos_l  = pos_l
                         , pos_r  = pos_r }

         function is_postfix (ast: sexp_ast): int =
             (ast <> nil)
           & (ast.typ = type_pair)
           & (ast.val_car <> nil)
           & (ast.val_car.typ <> type_pair)
           & (ast.val_car.val_s = "+" | ast.val_car.val_s = "*" | ast.val_car.val_s = ">=")

         function op_insn (opcode: int, pos_l: int, pos_r: int): vm_insn =
            vm_insn { opcode = opcode
                    , arg1   = 0
                    , arg2   = ""
                    , arg3   = nil
                    , pos_l  = pos_l
                    , pos_r  = pos_r }

         function compile_postfix ( sym      : string
                                  , num_args : int
                                  , insns    : vm_insn_list
                                  , pos_l    : int
                                  , pos_r    : int
                                  , tail_call: bool ): vm_insn_list =
           let var insn := if sym = "+" then  op_insn(OPCODE_ADD,  pos_l, pos_r)
                      else if sym = "*" then  op_insn(OPCODE_MULT, pos_l, pos_r)
                      else if sym = ">=" then op_insn(OPCODE_GEQ, pos_l, pos_r)
                      else (print("Unknown special form"); nil)

           in concat_lists(insns, single_insn(insn))
            ; tail_position(insns, tail_call, pos_l, pos_r)
            ; insns
           end

         function sexp_ast_length(insns: vm_insn_list): int =
           let function rec (insns: vm_insn_list_link, sum: int): int =
                 if insns = nil then sum
                                else rec(insns.next, 1 + sum)
           in rec(insns.first, 0)
           end

         function set_tree_positions ( ast: sexp_ast
                                     , pos_l: int
                                     , pos_r: int ) =
              /* Useful for setting the positions of generated AST. */
              if ast <> nil
                then ( ast.pos_l := pos_l
                     ; ast.pos_r := pos_r
                     ; if ast.typ = type_pair
                         then ( set_tree_positions( ast.val_cdr, pos_l, pos_r)
                              ; set_tree_positions( ast.val_car, pos_l, pos_r) ))

         function sexp_is_list_of_type ( ast: sexp_ast
                                       , subtype: type_type ): bool =
           if ast = nil
             then false
           else if ast.typ = type_nil
             then true
           else ast.typ = type_pair
              & ast.val_car <> nil
              & ast.val_car.typ = subtype
              & sexp_is_list_of_type(ast.val_cdr, subtype)

         function sexp_is_literals_list ( ast: sexp_ast ): bool =
           sexp_is_list_of_type(ast, type_symbol)

         function sexp_is_ellipsis ( ast: sexp_ast ): bool =
             ast <> nil
           & ast.typ = type_symbol
           & ast.val_s = "..."

         function sexp_list_length (ast: sexp_ast): bool =
           if ast = nil | not(ast.typ = type_pair | ast.typ = type_nil)
             then false
           else if ast.typ = type_nil
             then 0
           else  let var len := sexp_list_length(ast.val_cdr)
                 in if len < 0
                    then len
                    else len + 1
                 end

         function sexp_is_pattern_datum (ast: sexp_ast): bool =
             ast <> nil
           & ( ast.typ = type_integer
             | ast.typ = type_string
             | ast.typ = type_true
             | ast.typ = type_false
             /* TODO: character */)

         function sexp_is_pattern_id (ast: sexp_ast): bool =
           ast <> nil & ast.typ = type_symbol
                      & not(sexp_is_ellipsis(ast))

         function sexp_is_pattern ( ast: sexp_ast ): bool =
           if ast = nil
             then false

           /* Pattern Datum */
           else if sexp_is_pattern_datum(ast)
             then true

           /* The empty list '() is a pattern */
           else if ast.typ = type_nil
             then true

           /* Ensure it is a pair */
           else if ast.typ <> type_pair
                 | ast.val_car = nil
                 | ast.val_cdr = nil
             then false

           /* List of patterns: (<pattern> ...) */
           /* Non-proper list of patterns: (<pattern> ... . <pattern>) */
           else if ast.typ = type_pair
                 & sexp_is_pattern(ast.val_car)
                 & sexp_is_pattern(ast.val_cdr)
             then true

           /* (<pattern> ... <pattern> <ellipsis>) */
           else if ast.typ = type_pair
                 & sexp_is_pattern (ast.val_car)
                 & sexp_is_ellipsis(ast.val_cdr.val_car)
                 & ast.val_cdr.val_cdr.typ = type_nil
             then true

             /* TODO: Hashtag notation
                (https://people.csail.mit.edu/jaffer/r5rs/Pattern-language.html)
             */

           else false

         function sexp_is_template ( ast: sexp_ast ): bool =
           if ast = nil
             then false

           /* Pattern Datum */
           else if sexp_is_pattern_datum(ast)
             then true

           /* The empty list '() is a template */
           else if ast.typ = type_nil
             then true

           /* Ensure it is a pair */
           else if ast.typ <> type_pair
                 | ast.val_car = nil
                 | ast.val_cdr = nil
             then false

           /* List of templates: (<template_element> ...) */
           /* Pair of templates: (<template_element> . <template>) */
           /* Where <template_element> is <template> */
           else if ast.typ = type_pair
                 & sexp_is_template(ast.val_car)
                 & ast.val_cdr.typ = type_pair
                 & sexp_is_ellipsis(ast.val_cdr.val_car)
                 & sexp_is_pattern(ast.val_cdr.val_cdr)
             then true

           /* List of templates: (<template_element> ...) */
           /* Pair of templates: (<template_element> . <template>) */
           /* Where <template_element> is <template> <ellipsis> */
           else if ast.typ = type_pair
                 & sexp_is_template(ast.val_car)
                 & sexp_is_pattern(ast.val_cdr)
             then true

             /* TODO: Hashtag notation
                (https://people.csail.mit.edu/jaffer/r5rs/Pattern-language.html)
             */

           else false

         function sexp_is_syntax_rule (ast: sexp_ast): bool =
             ast <> nil
           & ast.typ = type_pair
           & sexp_is_pattern(ast.val_car)
           & ast.val_cdr <> nil
           & ast.val_cdr.typ = type_pair
           & ast.val_cdr.val_cdr.typ = type_nil
           & sexp_is_template(ast.val_cdr.val_car)

         function sexp_is_syntax_rules (ast: sexp_ast): bool =
           if ast <> nil | ast.typ <> type_pair
             then false

           else if ast.val_car.typ   = type_symbol
                 & ast.val_car.val_s = "syntax-rules"
                 & ast.val_cdr.typ   = type_pair
                 & sexp_is_literals_list(ast.val_cdr.val_car)
             then let var rule_head := ast.val_cdr.val_cdr
                      var correct   := true
                  in while correct
                         & rule_head.typ <> type_nil

                        do ( if not( rule_head.typ = type_pair
                                   & sexp_is_syntax_rule(rule_head.val_car) )
                             then correct := false
                           ; rule_head := rule_head.val_cdr )
                   ; correct
                  end

           else false

         function compile_syntax_rules (ast: sexp_ast): vm_insn_list =
           let
           in if sexp_is_syntax_rules(ast)
              then  compile_rec(STD_LIB_ID_FUNCTION, false)
              else ( compile_error("Syntax of syntax-rules usage is incorrect.", ast)
                   ; compile_rec(VALUE_UNSPECIFIED, false) )
           end

         function compile_define_syntax (ast: sexp_ast): vm_insn_list =
           let var symbol     := ast.val_cdr.val_car.val_s
               var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false)

               var pos_l := ast.pos_l
               var pos_r := ast.pos_r

           /* TODO: Improve below */
           in app_insn(insns_body, OPCODE_POP, 0, "", pos_l, pos_r)
            ; app_insn2(insns_body, OPCODE_PUSH, VALUE_UNSPECIFIED, pos_l, pos_r)
            ; insns_body
           end

         function compile_define (ast: sexp_ast): vm_insn_list =

           /* Standard define form: (define <variable> <expression>) */
           if ast.val_cdr.val_car.typ = type_symbol
            & ast.val_cdr.val_cdr.val_cdr.typ = type_nil
             then let var symbol     := ast.val_cdr.val_car.val_s
                      var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false)

                      var pos_l := ast.pos_l
                      var pos_r := ast.pos_r

                 in app_insn (insns_body, OPCODE_SETG, 0, symbol, pos_l, pos_r)
                  ; app_insn2(insns_body, OPCODE_PUSH, VALUE_UNSPECIFIED, pos_l, pos_r)
                  ; insns_body
                 end

           /* Below handles both special forms of define, by
            * transforming structure: */
           /* (define (<variable> <formals>)  <body>) */
           /* (define (<variable> . <formal>) <body>) */
           else if ast.val_cdr.val_car.typ = type_pair
                 & ast.val_cdr.val_car.val_car.typ = type_symbol
                 & ast.val_cdr.val_cdr.val_cdr.typ = type_nil
             then let var alt_ast :=   pair_val( ast.val_car,
                                        pair_val( ast.val_cdr.val_car.val_car,
                                        pair_val( pair_val( sym_val("lambda"),
                                                  pair_val( ast.val_cdr.val_car.val_cdr
                                                          , ast.val_cdr.val_cdr)),
                                        nil_val())))

                   in set_tree_positions(alt_ast, ast.pos_l, ast.pos_r)
                    /*; print("Transformed:\n    From: ")
                    ; print(value_to_string(ast))
                    ; print("\n    Into: ")
                    ; print(value_to_string(alt_ast))
                    ; print("\n") */
                    ; compile_define(alt_ast)
                   end

           /* TODO: Support all variations */

           else (compile_error( "Define does not fit correct form. Should be one of:\n\
                                \        (define <variable> <expression>)\n\
                                \        (define (<variable> <formals>) <body>)\n\
                                \        (define (<variable> . <formal>) <body>)"
                              , ast)
                ; list(nil))


         function compile_rec (ast: sexp_ast, can_tail_call: int): vm_insn_list =
           if ast = nil then  nil

             /* Throw error on free standing (). Must be either
              * quoted, or exist in special form. */
           else if ast.typ = type_nil then
             ( compile_error("Attempting to compile free-standing (). This is not allowed.\n    Must use \"'()\", if nil value is wanted.", ast)
             ; nil )

             /* Handle numbers and other constants */
           else if ast.typ <> type_pair then
             tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r)
                              , can_tail_call, ast.pos_l, ast.pos_r )

             /* If statements */
           else if ast.val_car <> nil
                 & ast.val_car.val_s = "if"
             then let var insns_test := compile_rec(ast.val_cdr.val_car, false)
                      var insns_then := compile_rec(ast.val_cdr.val_cdr.val_car,     can_tail_call)
                      var insns_else := if ast.val_cdr.val_cdr.val_cdr.typ = type_pair
                                        then compile_rec(ast.val_cdr.val_cdr.val_cdr.val_car, can_tail_call)
                                        else compile_rec(VALUE_UNSPECIFIED, can_tail_call)

                      var jump_then := sexp_ast_length(insns_then) + 1
                      var jump_else := sexp_ast_length(insns_else) + 1 + 1

                      var pos_l := ast.pos_l
                      var pos_r := ast.pos_r

                 in app_insn(insns_test, OPCODE_CSKIP, 0, "" , pos_l, pos_r)
                  ; app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
                  ; concat_lists(insns_test, insns_else)
                  ; app_insn(insns_test, OPCODE_DGOTO, jump_then, "" , pos_l, pos_r)
                  ; concat_lists(insns_test, insns_then)
                  ; insns_test
                 end

             /* Define statements */
           else if ast.val_car <> nil & ast.val_car.val_s = "define"
             then compile_define(ast)

             /* Syntax define statements */
           else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
             then compile_define_syntax(ast)

             /* Syntax rules expression */
           else if ast.val_car <> nil & ast.val_car.val_s = "syntax-rules"
             then compile_syntax_rules(ast)

             /* Begin expressions */
           else if ast.val_car <> nil & ast.val_car.val_s = "begin"
             then let var insns := vm_insn_list { first = nil, last = nil }
                      var head  := ast.val_cdr

                 in while head <> nil & head.typ = type_pair
                       do ( if head <> ast.val_cdr
                            then app_insn(insns, OPCODE_POP, 0, "", ast.pos_l, ast.pos_r)
                          ; concat_lists(insns, compile_rec(head.val_car, false))
                          ; head := head.val_cdr )
                  ; insns
                 end

             /* Quote expressions */
           else if ast.val_car <> nil & ast.val_car.val_s = "quote"
             then let var datum := ast.val_cdr.val_car

                 in tail_position_one( vm_insn { opcode = OPCODE_PUSH
                                               , arg1   = 0
                                               , arg2   = ""
                                               , arg3   = datum
                                               , pos_l  = ast.pos_l
                                               , pos_r  = ast.pos_r }
                                     , can_tail_call
                                     , ast.pos_l
                                     , ast.pos_r)
                 end

             /* Set statements */
           else if ast.val_car <> nil & ast.val_car.val_s = "set!"
             then let var sym       := ast.val_cdr.val_car.val_s
                      var exp_insns := compile_rec(ast.val_cdr.val_cdr.val_car, false)

                 in app_insn (exp_insns, OPCODE_SET, 0, sym, ast.pos_l, ast.pos_r)
                  ; app_insn2(exp_insns, OPCODE_PUSH, VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)
                  ; exp_insns
                 end

             /* Lambda expressions */
           else if ast.val_car <> nil & ast.val_car.val_s = "lambda"
             then let var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, true)

                      var pos_l := ast.pos_l
                      var pos_r := ast.pos_r

                      function build_insns_arguments (args: sexp_ast, derp: vm_insn_list_link): vm_insn_list_link =
                        if args = nil
                         | args.typ = type_nil
                         | args.val_car = nil
                         then derp
                        else
                          build_insns_arguments( args.val_cdr
                                               , vm_insn_list_link { insn = vm_insn { opcode = OPCODE_DEF
                                                                                    , arg1 = 0
                                                                                    , arg2 = args.val_car.val_s
                                                                                    , arg3 = nil
                                                                                    , pos_l = pos_l
                                                                                    , pos_r = pos_r }
                                                                   , next = derp })

                      var insns_ass_args := list(build_insns_arguments(ast.val_cdr.val_car, nil))

                      var jump_lambda := sexp_ast_length(insns_body)
                                       + sexp_ast_length(insns_ass_args)
                                       + 1

                      var insns := vm_insn_list { first = nil, last = nil }

                 in app_insn(insns, OPCODE_DEFFUN, 2, "", pos_l, pos_r)
                  ; app_insn(insns, OPCODE_DGOTO, jump_lambda, "" , pos_l, pos_r)
                  ; concat_lists(insns, insns_ass_args)
                  ; concat_lists(insns, insns_body)
                  ; insns
                 end

             /* Call expressions */
           else  let var num_args   := 0
                     var args_insns := vm_insn_list { first = nil, last = nil }
                     var ast_iter   := ast.val_cdr

                     var pos_l := ast.pos_l
                     var pos_r := ast.pos_r

                 in while ast_iter <> nil & ast_iter.typ = type_pair
                       do ( concat_lists(args_insns, compile_rec(ast_iter.val_car, false))
                          ; num_args := num_args + 1
                          ; ast_iter := ast_iter.val_cdr )
                  ; if is_postfix(ast)
                    then compile_postfix (ast.val_car.val_s, num_args, args_insns, pos_l, pos_r, can_tail_call)
                    else let
                             var insns_head := compile_rec(ast.val_car, false)
                             /* Below we choose whether to call
                              * normally, or tail calling (identical
                              * to returning) */
                             var call_op    := if can_tail_call
                                                  then OPCODE_RET
                                                  else OPCODE_CALL
                         in concat_lists( insns_head, args_insns)
                          ; app_insn( insns_head, call_op, num_args, "", pos_l, pos_r)
                          ; insns_head
                         end
                 end

         function compile_error(errmsg: string, errast: sexp_ast) =
          let
          in print("Tiger-scheme compile error\n    ")
           ; print(errmsg)
           ; print("\n    For scheme: ")
           ; print(value_to_string(errast))
           ; print("\n")
          end

         function insn_list_to_tape (insns: vm_insn_list): vm_tape =
           let var length := insn_list_length(insns)
               var tape   := vm_tape_tape [length] of nil
               var index  := 0
               var head   := insns.first
           in while index < length
                 do ( tape[index] := head.insn
                    ; index       := index + 1
                    ; head        := head.next )
            ; vm_tape { length = length, tape = tape }
           end

     in insn_list_to_tape( concat_lists(copy_list(STD_LIB)
                         , compile_rec(ast, true)))
     end

   function optimize_vm_tape (real_tape: vm_tape): vm_tape =
     let var len   := real_tape.length
         var tape  := real_tape.tape
     in for index := 0 to len - 1
           do if tape[index+0].opcode = OPCODE_PUSH
               & tape[index+1].opcode = OPCODE_POP
                  then ( tape[index+0] := noop_insn( tape[index+0].pos_l
                                                   , tape[index+0].pos_r )
                       ; tape[index+1] := noop_insn( tape[index+1].pos_l
                                                   , tape[index+1].pos_r ))
              else if tape[index+0].opcode = OPCODE_DEF
                    & tape[index+1].opcode = OPCODE_LOAD
                    & tape[index+0].arg2 = tape[index+1].arg2
                  then ( tape[index+1] := tape[index+0]
                       ; tape[index+0] := vm_insn { opcode = OPCODE_DUPL
                                                  , arg1   = 0
                                                  , arg2   = ""
                                                  , arg3   = nil
                                                  , pos_l  = tape[index+1].pos_l
                                                  , pos_r  = tape[index+1].pos_r })
      ; real_tape
     end

   function insn_to_string (insn: vm_insn): string =
     if insn = nil
         then ( print("Encountered missing opcode in insn_to_string!\n")
              ; "!!!" )
     else if insn.opcode < 0
           | vm_insn_num_opcodes <= insn.opcode
           | vm_insn_info[insn.opcode] = nil

         then ( print(concatm( "Encountered unknown opcode "
                             , int_to_string(insn.opcode)
                             , " in insn_to_string!\n"
                             , "", ""))
              ; "???" )
     else if insn.opcode = OPCODE_DGOTO & insn.arg1 = 1
         then "NOOP"
     else
       let var info := vm_insn_info[insn.opcode]
       in concatm( info.mnemonic
                 , if info.uses_arg1
                   then concat(" ", int_to_string(insn.arg1))
                   else ""
                 , if info.uses_arg2
                   then concatm(" \"", insn.arg2, "\"", "", "")
                   else ""
                 , if info.uses_arg3
                   then concat(" ", value_to_string(insn.arg3))
                   else ""
                 , "")
       end

   function tape_to_string (tape: vm_tape): string =
     let var str   := "TAPE\n"
         var index := 0
         var real_tape := tape.tape
         var length    := tape.length
         var ln_width  := size(int_to_string(tape.length))

         function repeat (str: string, i: int): string =
           if i <= 0
             then ""
             else concat(str, repeat(str, i-1))

         function line_number (i: int): string =
           let var num_str := int_to_string(i)
           in concat(repeat(" ", ln_width-size(num_str)), num_str)
           end

     in while index < length
           do ( str := concatm( str
                              , line_number(index)
                              , "  "
                              , insn_to_string(real_tape[index])
                              , "\n")
              ; index := index + 1 )
      ; str := concat(str, "EPAT")
      ; str
     end

   /**** Virtual Machine ****/

   /* Stack */

   type vm_stack_elem = scheme_value
   type vm_stack_list = { value: vm_stack_elem, below: vm_stack_list }
   type vm_stack = { list: vm_stack_list }
   function stack_new(): vm_stack = vm_stack { list = nil }
   function stack_pop(stack: vm_stack): vm_stack_elem =
     if stack = nil
       then (print("Error in stack_pop: Not given stack!\n"); nil)
     else if stack.list = nil
       then nil
     else
       let var head  := stack.list.value
       in stack.list := stack.list.below
        ; head
       end
   function stack_seek_elem(stack: vm_stack, index: int): vm_stack_list =
     let var head  := stack.list
     in for index := 1 to index
           do if head <> nil
               then head := head.below
      ; head
     end
   function stack_destroy_elem(stack: vm_stack, index: int): vm_stack_elem =
     if index <= 0
       then let var value   := stack.list.value
            in stack.list   := stack.list.below
             ; value
            end
       else let var before  := stack_seek_elem(stack, index - 1)
            in if before = nil | before.below = nil
               then nil
               else let var value   := before.below.value
                     in before.below := before.below.below
                      ; value
                    end
            end
   function stack_push(stack: vm_stack, elem: vm_stack_elem) =
     stack.list := vm_stack_list { value = elem
                                 , below = stack.list }

   function stack_to_string (stack: vm_stack): string =
     let function iter (list: vm_stack_list): string =
            if list = nil then ""
            else concat(value_to_string(list.value), if list.below <> nil
                                                     then concat(", ", iter(list.below))
                                                     else "")

     in concat("[", concat(iter(stack.list), "]"))
     end

   /* Environments */

   var GLOBAL_ENV_SENTINEL := ""

   function env_new(): vm_env =
       vm_env { key   = GLOBAL_ENV_SENTINEL
              , value = bool_val(0)
              , next  = STD_LIB_ENV }

   function env_seek_elem(env: vm_env, key: vm_env_key): vm_env =
     let var head  := env
     in while head <> nil & head.key <> key
           do head := head.next
      ; head
     end

   function env_push(env: vm_env, key: vm_env_key, value: vm_env_elem): vm_env =
       vm_env { key   = key
              , value = value
              , next  = env }

   function global_env_push (env: vm_env, key: vm_env_key, value: vm_env_elem): vm_env =
       let
       in  if env.key <> GLOBAL_ENV_SENTINEL
           then print("Attempting to perform global push to non-global environment")
           else env.next := vm_env { key   = key
                                   , value = value
                                   , next  = env.next }
        ; env
       end


   function env_to_string (env: vm_env): string =
     let function iter (list: vm_env): string =
            if list = nil then ""
            else concat("(",
                 concat(list.key,
                 concat(": ",
                 concat(value_to_string(list.value), if list.next <> nil
                                                     then concat("), ", iter(list.next))
                                                     else ")"))))

     in concat("[", concat(iter(env), "]"))
     end

   /* Tape */

  /* Virtual Machine execution */

   function vm_run ( tape  : vm_tape
                   , ip    : int
                   , stack : vm_stack
                   , env   : vm_env
                   , source: string
                   , global_env : vm_env ) =

     let var tape_size := tape.length
         var tape      := tape.tape
         var continue  := true

         function vm_update () =
            if not(continue)
              then ()
            else if tape[ip] = nil
              then run_error("Missing instruction in tape")
            else if not (0 <= ip & ip < tape_size)
              then run_error("Instruction pointer out of bounds")

            /* Integer binary operators */
            else if let var op := tape[ip].opcode
                    in op = OPCODE_ADD | op = OPCODE_MULT | op = OPCODE_GEQ end
                  then let var opcode := tape[ip].opcode
                           var arg2 := stack_pop(stack)
                           var arg1 := stack_pop(stack)
                           var val: scheme_value := nil

                       in if not (is_integer(arg1)) then run_error("Argument #1 to binary operation was not integer")
                        ; if not (is_integer(arg2)) then run_error("Argument #2 to binary operation was not integer")
                        ; val := if opcode = OPCODE_ADD
                                      then int_val(arg1.val_i + arg2.val_i)
                                 else if opcode = OPCODE_MULT
                                      then int_val(arg1.val_i * arg2.val_i)
                                 else if opcode = OPCODE_GEQ
                                      then bool_val(arg1.val_i >= arg2.val_i)
                                 else (run_error("Impossible!"); bool_val(0))
                        ; stack_push(stack, val)
                        ; if ip >= 0 then ip := ip + 1
                       end

            else if tape[ip].opcode = OPCODE_PUSH
                  then ( stack_push(stack, tape[ip].arg3)
                       ; ip := ip + 1 )

            else if tape[ip].opcode = OPCODE_CSKIP
                  then let var arg1 := stack_pop(stack)
                       in ip := ip + if is_truthy(arg1)
                                     then 1
                                     else 2
                       end

            else if tape[ip].opcode = OPCODE_GOTO
                  then ip := tape[ip].arg1

            else if tape[ip].opcode = OPCODE_DGOTO
                  then ip := ip + tape[ip].arg1

            else if tape[ip].opcode = OPCODE_DUPL
                  then let var arg1 := stack_seek_elem(stack, tape[ip].arg1)
                       in if arg1 = nil
                          then run_error("Stack too shallow!")
                          else ( stack_push(stack, arg1.value)
                               ; ip := ip + 1 )
                       end

            else if tape[ip].opcode = OPCODE_SWITCH
                  then let var arg1 := stack_pop(stack)
                           var arg2 := stack_pop(stack)
                       in stack_push(stack, arg1)
                        ; stack_push(stack, arg2)
                        ; ip := ip + 1
                       end

            else if tape[ip].opcode = OPCODE_CALL
                  then let var call_name_pos  := stack_seek_elem(stack, tape[ip].arg1)
                           var return_ip      := ip + 1
                           var return_env     := env

                       in if call_name_pos = nil
                              then run_error("Stack too shallow!")
                          else if not(is_function(call_name_pos.value))
                              then run_error(concat("Cannot call ", value_to_string(call_name_pos.value)))
                          else ( ip                  := call_name_pos.value.val_i
                               ; env                 := call_name_pos.value.val_e
                               ; call_name_pos.value := fun_val(return_ip, return_env) )
                       end

            else if tape[ip].opcode = OPCODE_LOAD
                  then let var value_container  := env_seek_elem(env, tape[ip].arg2)
                       in if value_container <> nil
                          then ( stack_push(stack, value_container.value)
                               ; ip := ip + 1 )
                          else run_error(concatm( "Attempting to access unknown variable \""
                                                , tape[ip].arg2
                                                , "\"\n    Environment looks like "
                                                , env_to_string(env)
                                                , ""))
                       end

            else if tape[ip].opcode = OPCODE_DEF
                  then let var value    := stack_pop(stack)
                           var new_env  := env_push(env, tape[ip].arg2, value)
                       in env := new_env
                        ; ip  := ip + 1
                       end

            else if tape[ip].opcode = OPCODE_SETG
                  then let var value    := stack_pop(stack)
                           var new_env  := global_env_push(global_env, tape[ip].arg2, value)
                       in env := new_env
                        ; ip  := ip + 1
                       end

            else if tape[ip].opcode = OPCODE_DEFFUN
                  then ( stack_push(stack, fun_val(ip + tape[ip].arg1, env))
                       ; ip := ip + 1 )

            else if tape[ip].opcode = OPCODE_RET
                  then let var return_to  := stack_destroy_elem(stack, tape[ip].arg1)
                       in if return_to = nil
                              then run_error("Stack too shallow!")
                          else if not(is_function(return_to))
                              then run_error(concat("Cannot return to non-function value ", value_to_string(return_to)))
                          else ( ip                  := return_to.val_i
                               ; env                 := return_to.val_e)
                       end

            else if tape[ip].opcode = OPCODE_POP
                  then ( stack_pop(stack)
                       ; ip := ip + 1 )

            else if tape[ip].opcode = OPCODE_OUTPUT
                  then let var head := stack_pop(stack)
                       in if head = nil
                              then run_error("Stack too shallow!")
                          else if not(is_string(head))
                              then run_error(concat("Cannot output non-string value ", value_to_string(head)))
                          else ( print(head.val_s)
                               ; ip := ip + 1 )
                       end

            else if tape[ip].opcode = OPCODE_TOSTR
                  then let var head := stack_pop(stack)
                       in if head = nil then run_error("Stack too shallow!")
                         ; stack_push(stack, str_val(value_to_string(head)))
                         ; if ip >= 0 then ip := ip + 1
                       end

            else if tape[ip].opcode = OPCODE_CONS
                  then let var cdr := stack_pop(stack)
                           var car := stack_pop(stack)

                       in if cdr = nil | car = nil then  run_error("Stack too shallow!")
                         ; stack_push(stack, pair_val(car, cdr))
                         ; if ip >= 0 then ip := ip + 1
                       end

            else if tape[ip].opcode = OPCODE_CAR
                  then let var head := stack_pop(stack)
                       in if head = nil then run_error("Stack too shallow!")
                          else if not(is_pair(head))
                              then run_error(concat("Cannot index into non-pair value", value_to_string(head)))
                          else ( stack_push(stack, head.val_car)
                               ; ip := ip + 1 )
                       end

            else if tape[ip].opcode = OPCODE_CDR
                  then let var head := stack_pop(stack)
                       in if head = nil then run_error("Stack too shallow!")
                          else if not(is_pair(head))
                              then run_error(concat("Cannot index into non-pair value", value_to_string(head)))
                          else ( stack_push(stack, head.val_cdr)
                               ; ip := ip + 1 )
                       end

            else if tape[ip].opcode = OPCODE_SET
                  then let var head := stack_pop(stack)
                           var sym  := tape[ip].arg2
                           var elem := env_seek_elem(env, sym)
                       in if head = nil
                            then run_error("Stack too shallow!")
                          else if elem = nil
                            then run_error(concatm( "Attempting to set unknown variable \""
                                                  , sym
                                                  , "\"\n    Environment looks like "
                                                  , env_to_string(env)
                                                  , ""))
                          else ( elem.value := head
                               ; ip := ip + 1 )
                       end

            else run_error(concat("Encountered unknown opcode "
                                 , int_to_string(tape[ip].opcode)))

        function run_error(errmsg: string) =
          let
          in print("Tiger-scheme runtime error\n    ")
           ; print(errmsg)
           ; print("\n    At instruction ")
           ; print(int_to_string(ip))
           ; print(": ")
           ; print(insn_to_string(tape[ip]))
           ; print("\n    Scheme: ")
           ; print(safe_substring(source, tape[ip].pos_l, tape[ip].pos_r))
           ; print("\n")
           ; continue := false
          end

     in while continue
        do ( vm_update()
           ; if DEBUG_PRINT_STACK
             then  ( print("[")
                   ; print(int_to_string(ip))
                   ; print("]: ")
                   ; print(stack_to_string(stack))
                   ; print("\n") ))
     end

   /* Do stuff */

   var test_text :=
     /* TODO: Improve top-level parsing */
     let var text := "(begin "
         var char := "BAD SHIT HAPPENED"
     in while char <> ""
           do ( char := getchar()
              ; text := concat(text, char) )
      ; concat(text, " )")
     end

   var ignore     := ( print("** Parsing **\n")
                     ; print("Original : ")
                     ; print(test_text)
                     ; print("\n")
                     ; 1)
   var sexp_ast   := parse_string(test_text)
   var ignore     := ( print("Parsed   : ")
                     ; print(value_to_string(sexp_ast))
                     ; print("\n")
                     ; print("** Compilation **\n")
                     ; 1)
   var tape       := compile_to_vm(sexp_ast)
   var tape       := optimize_vm_tape(tape)
   var ignore     := ( print("Compiled!:\n")
                     ; print(tape_to_string(tape))
                     ; print("\n")
                     ; 1)
   var stack      := stack_new()
   var env        := env_new()

in ()

 ; print("\n** VM **\n")
 ; vm_run(tape, 0, stack, env, test_text, env)
 ; print("Stack: ")
 ; print(stack_to_string(stack))
 ; print("\n")

end