tiger-scheme/tigerscheme.tig

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 concat5 ( s1: string
                     , s2: string
                     , s3: string
                     , s4: string
                     , s5: string ): string =
         concat(s1, concat(s2, concat(s3, concat(s4, s5))))

    function concat8 ( s1: string
                     , s2: string
                     , s3: string
                     , s4: string
                     , s5: string
                     , s6: string
                     , s7: string
                     , s8: string ): string =
         concat(s1, concat(s2, concat(s3, concat(s4, concat(s5, concat(s6, concat(s7, s8)))))))

    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) )

    /* Source positioning */

    type pos = { at_char: int, line_num: int }
    function new_pos (line_num: int, at_char: int): pos =
      pos { at_char = at_char, line_num = line_num }
    function line_num (pos: pos): int = pos.line_num
    function at_char  (pos: pos): int = pos.at_char
    function pos_delta_char (pos: pos, delta: int): pos =
      new_pos( line_num(pos)
             , at_char (pos) + delta)

    var pos_unknown: pos := nil

    function pos_to_string (pos: pos): string =
      if pos = pos_unknown
        then "unknown position"
      else
        concat("line ", int_to_string(line_num(pos)))

    /* Scheme value system */

    type type_type = int

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

                        , pos_l: pos
                        , pos_r: pos }

    type vm_env_key  = scheme_value
    type vm_env_elem = scheme_value
    type vm_env      = scheme_value
    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 error_value_to_string(v: scheme_value): string =
      if v = nil
        then "<TIGER NIL>"
      else
        let
        in concat8( "<ERROR VALUE: TYPE "
                  , int_to_string(v.typ)
                  , if v.val_i <> 0
                    then concat("; I = ", int_to_string(v.val_i))
                    else ""
                  , if v.val_s <> ""
                    then concat("; S = ", (v.val_s))
                    else ""
                  , if v.val_car <> nil
                    then concat("; CAR = ", value_to_string(v.val_car))
                    else ""
                  , if v.val_cdr <> nil
                    then concat("; CDR = ", value_to_string(v.val_cdr))
                    else ""
                  , ""
                  , ">")
        end

    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")
                    ; error_value_to_string(v) )
            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 = nil
              then error_value_to_string(v)

            else if v.typ = type_pair & v.val_cdr <> nil & v.val_cdr.typ = type_nil
               then let
                    in concat5 ( 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 <> nil
                                     & v.val_cdr.typ = type_pair
                    in concat5 ( 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")
                 ; error_value_to_string(v) )
      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_car = nil
                   , val_cdr = nil

                   , pos_l = pos_unknown
                   , pos_r = pos_unknown }

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

                   , pos_l = pos_unknown
                   , pos_r = pos_unknown }


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

                   , pos_l = pos_unknown
                   , pos_r = pos_unknown }

    var VAL_TRUE :=
       scheme_value { typ = type_true
                    , val_i = 1
                    , val_s = ""
                    , val_car = nil
                    , val_cdr = nil

                    , pos_l = pos_unknown
                    , pos_r = pos_unknown }

    var VAL_FALSE :=
       scheme_value { typ = type_false
                    , val_i = 0
                    , val_s = ""
                    , val_car = nil
                    , val_cdr = nil

                    , pos_l = pos_unknown
                    , pos_r = pos_unknown }

    function bool_val (i: int): scheme_value =
       if (i <> 0) then VAL_TRUE
                   else VAL_FALSE

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

                    , pos_l = pos_unknown
                    , pos_r = pos_unknown }

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

                    , pos_l = pos_unknown
                    , pos_r = pos_unknown }

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

                    , pos_l = pos_unknown
                    , pos_r = pos_unknown }

    var VALUE_UNSPECIFIED := nil_val()

    /* Parsing */

    type sexp_ast = scheme_value

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

          function is_char (char: string, index: int): bool =
            let var ascii := ord(substring(str, index, 1))
            in ascii = ord(char)
            end

          function is_left_paren    (index: int): bool = is_char("(",  index)
          function is_right_paren   (index: int): bool = is_char(")",  index)
          function is_comment_start (index: int): bool = is_char(";",  index)
          function is_tick          (index: int): bool = is_char("'",  index)
          function is_goose_marks   (index: int): bool = is_char("\"", index)

          function is_ws (index: int): int =
            let var ascii := ord(substring(str, index, 1))
            in ascii = 32 | ascii = 9 | ascii = 10
            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("\"")
                   | ascii = ord("'")
                   | ascii = ord(";") )
            end

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

          function sexp_atom (sym: string, pos_l: pos, pos_r: pos): 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: pos, pos_r: pos): 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: pos
                             , pos_r: pos): sexp_ast =
              sexp_ast { typ   = type_pair
                       , val_i = 0
                       , val_s = ""
                       , val_car   = car
                       , val_cdr   = cdr
                       , pos_l = pos_l
                       , pos_r = pos_r }

          function sexp_string ( str: string
                               , pos_l: pos
                               , pos_r: pos): sexp_ast =
              sexp_ast { typ   = type_string
                       , val_i = 0
                       , val_s = str
                       , val_car = nil
                       , val_cdr = nil
                       , pos_l = pos_l
                       , pos_r = pos_r }

          function ignore_ws () =
            /* Do nothing when outside string */
            if index >= size(str)
              then ()

            /* Handle newline */
            else if is_char("\n", index)
              then ( line_number := line_number + 1
                   ; index       := index       + 1
                   ; ignore_ws() )

            /* Ignore whitespace */
            else 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 start_pos := new_pos(line_number, index)
                      in while is_symbol(index)
                            do index := index + 1
                       ; sexp_atom( safe_substring(str, at_char(start_pos), index-1)
                                  , start_pos
                                  , new_pos(line_number, index - 1) )
                      end

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

                      in exp
                      end

              else if is_goose_marks(index)
                then  let var start_pos := new_pos(line_number, index)
                          var string_str := ""
                          function app_str (new_str: string) =
                            string_str := concat(string_str, new_str)
                          /* TODO: Implement escape codes */

                      in index := index + 1
                       ; while not(is_goose_marks(index)) & index < size(str)
                            do if is_char("\\", index)          /*" Gotta love bad syntax files */
                               then ( if is_char("n", index+1)
                                          then app_str("\n")
                                      else if is_char("t", index+1)
                                          then app_str("\t")
                                      else print("Unknown escape code in string")
                                    ; index := index + 2 )
                               else ( app_str(substring(str, index, 1))
                                    ; index := index + 1 )

                       ; index := index + 1
                       ; sexp_string( string_str
                                    , start_pos
                                    , new_pos(line_number, index-1))
                      end

              else if is_left_paren(index)
                then  let var sexp      : sexp_ast := nil
                          var sexp_last : sexp_ast := nil
                          var start_pos : pos := new_pos(line_number, index)
                          var most_right: pos := start_pos

                      in index := index + 1 /* Position after index */
                       ; while index < size(str) & not(is_right_paren(index))
                            do let var parsed := parse_rec()
                                   var pos    := new_pos(line_number, index)
                                   var link := sexp_pair( parsed
                                                        , sexp_nil(pos, pos)
                                                        , 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    := if at_char(link.pos_r) > at_char(most_right)
                                                   then link.pos_r
                                                   else most_right
                                ; ignore_ws()
                               end

                       /* Error handling */
                       ; if index >= size(str)
                               then parse_error("Misaligned parenthesis")

                       /* 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 := pos_delta_char(sexp.pos_l, -1)
                              ; sexp.pos_r := pos_delta_char(sexp.pos_r,  1))

                       /* Continue with stuff */
                       ; index := index + 1
                       ; if sexp = nil
                         then sexp_nil( start_pos
                                      , 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: pos
                  , pos_r: pos }

   type vm_tape_tape = array of vm_insn
   type vm_tape      = { length: int
                       , filled: 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 OPCODE_SETENV := 24
   var OPCODE_NUMEQ  := 25
   var OPCODE_TYPEOF := 26

   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(concat5( "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_NUMEQ,  "NUMEQ",   0, 0, 0)
      ; code(OPCODE_TYPEOF, "TYPEOF",  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)
      ; code(OPCODE_SETENV, "SETENV",   0, 0, 0)

      ; for i := 1 to expected_number_opcodes - 1
        do if a[i] <> nil & a[i-1] = nil
           then print(concat5("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: pos, pos_r: pos): 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 tape_new (init_size: int): vm_tape =
     vm_tape { length = init_size
             , filled = 0
             , tape   = vm_tape_tape [init_size] of nil }

   function tape_append(tape: vm_tape, new_insns: vm_insn_list): int =
     let var head  := new_insns.first
         var index_start := tape.filled
         var index := index_start
         var real_tape := tape.tape
         /* TODO: Ensure enough space on tape for new additions. */
     in while head <> nil
           do ( real_tape[index] := head.insn
              ; index := index + 1
              ; head  := head.next )
      ; tape.filled := index
      ; index_start
     end

   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(concat5( "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: pos, pos_r: pos) =
      ( 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: pos, pos_r: pos) =
      ( 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: pos, pos_r: pos) =
     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: pos, pos_r: pos): 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 ENV_EMPTY : vm_env  := nil_val()
   var ENV_STD   : vm_env  := ENV_EMPTY
   var STD_LIB_ID_FUNCTION: scheme_value := nil

   var STD_LIB := let var first_insn := noop_insn(pos_unknown, pos_unknown)

                      var std_insns  := single_insn(first_insn)

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

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

                      function stdval (name: string, value: scheme_value) =
                        ENV_STD := pair_val( pair_val( sym_val(name), value)
                                               , ENV_STD )

                      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, "")

                    /* R5RS: Pairs and Lists */

                   ; stdfun("pair?")
                   ; app(OPCODE_TYPEOF,  0, "")
                   ; app2(OPCODE_PUSH,  int_val(type_pair))
                   ; app(OPCODE_NUMEQ,   0, "")
                   ; 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, "")

                   /* TODO: set-car! set-cdr! caar ... cddddr */

                   ; stdfun("null?")
                   ; app(OPCODE_TYPEOF,  0, "")
                   ; app2(OPCODE_PUSH,  int_val(type_nil))
                   ; app(OPCODE_NUMEQ,   0, "")
                   ; app(OPCODE_RET,     1, "")

                    /* R5RS: Numerical Operations */
                    /* TODO: Support more than integers */

                   ; stdfun("number?")
                   ; stdfun("complex?")
                   ; stdfun("real?")
                   ; stdfun("rational?")
                   ; stdfun("integer?")
                   ; app(OPCODE_TYPEOF,  0, "")
                   ; app2(OPCODE_PUSH,  int_val(type_integer))
                   ; app(OPCODE_NUMEQ,   0, "")
                   ; app(OPCODE_RET,     1, "")

                   ; stdfun("exact?")
                   ; app(OPCODE_POP, 0, "")
                   ; app2(OPCODE_PUSH, VAL_TRUE)
                   ; app(OPCODE_RET,     1, "")

                   ; stdfun("inexact?")
                   ; app(OPCODE_POP, 0, "")
                   ; app2(OPCODE_PUSH, VAL_FALSE)
                   ; app(OPCODE_RET,     1, "")

                   ; stdfun("+")
                   ; app(OPCODE_ADD, 0, "")
                   ; app(OPCODE_RET, 1, "")

                   ; stdfun("*")
                   ; app(OPCODE_MULT, 0, "")
                   ; app(OPCODE_RET,  1, "")

                   ; stdfun(">=")
                   ; app(OPCODE_GEQ, 0, "")
                   ; app(OPCODE_RET, 1, "")

                   ; stdfun("<=")
                   ; app(OPCODE_SWITCH, 0, "")
                   ; app(OPCODE_GEQ, 0, "")
                   ; app(OPCODE_RET, 1, "")

                   /* TODO: =, <, > */

                   /* Defined in scheme:
                      - zero?
                      - positive?
                      - negative?
                      - odd?
                      - even?
                   */
                   ; stdfun("zero?")
                   ; app2(OPCODE_PUSH, int_val(0))
                   ; app(OPCODE_NUMEQ,   0, "")
                   ; app(OPCODE_RET,     1, "")

                   /* TODO: Rest */


                    /* R5RS: Output */

                   ; stdfun("display")
                   ; app(OPCODE_DUPL,   0, "")
                   ; app(OPCODE_TYPEOF, 0, "")
                   ; app2(OPCODE_PUSH, int_val(type_string))
                   ; app(OPCODE_NUMEQ,  0, "")
                   ; app(OPCODE_CSKIP,  0, "")
                   ; app(OPCODE_DGOTO,  2, "")
                   ; app(OPCODE_TOSTR,  0, "")
                   ; app(OPCODE_OUTPUT, 0, "")
                   ; app2(OPCODE_PUSH,  VALUE_UNSPECIFIED)
                   ; app(OPCODE_RET,    1, "")

                   ; stdfun("write")
                   ; 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, "")

                    /* TODO: write-char */

                    /* R5RS: Other */

                   ; stdfun("eval")
                   ; app(OPCODE_SWITCH,  0, "")
                   ; app(OPCODE_COMPILE, 0, "")
                   ; app(OPCODE_SETENV,  0, "")
                   ; app(OPCODE_RET,     0, "")

                   ; stdfun("null-environment")
                   /* Signal error on unknown environment version */
                   ; app(OPCODE_POP, 0, "")
                   ; app2(OPCODE_PUSH, ENV_EMPTY)
                   ; app(OPCODE_RET,     1, "")

                   ; stdfun("scheme-report-environment")
                   ; stdfun("interaction-environment")
                   /* Signal error on unknown environment version */
                   ; app(OPCODE_POP, 0, "")
                   ; app2(OPCODE_PUSH, ENV_STD) /* Defined R5RS environement */
                   ; app(OPCODE_RET,     1, "")

                    /* Personal implementation functions */
                   ; stdfun("string->datum")
                   ; app(OPCODE_FRSTR,  0, "")
                   ; app(OPCODE_RET,    1, "")

                   ; stdfun("set-env!")
                   ; app(OPCODE_SWITCH,  0, "")
                   ; app(OPCODE_SETENV,  0, "")
                   ; app(OPCODE_RET,     1, "")

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


   function compile_to_vm (ast: sexp_ast): vm_insn_list =
     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: pos, pos_r: pos): 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 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: pos
                                     , pos_r: pos ) =
              /* 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)
                   ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)) )
           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 )
                  ; 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 var repr_pos_l := pos_to_string(errast.pos_l)
              var repr_pos_r := pos_to_string(errast.pos_r)
          in print("Tiger-scheme compile error\n    ")
           ; print(errmsg)
           ; print("\n    For scheme: ")
           ; print(value_to_string(errast))
           ; print("\n    Source pos: ")
           ; print(repr_pos_l)
           ; if repr_pos_l <> repr_pos_r
             then ( print(" to ")
                  ; print(repr_pos_r) )
           ; print("\n")
          end

     in 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(concat5( "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 concat5( info.mnemonic
                 , if info.uses_arg1
                   then concat(" ", int_to_string(insn.arg1))
                   else ""
                 , if info.uses_arg2
                   then concat5(" \"", 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.filled
         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 := concat5( 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 =
       pair_val( pair_val( sym_val(GLOBAL_ENV_SENTINEL)
                         , bool_val(0))
               , ENV_STD )

   function env_seek_elem(env: vm_env, key: string): vm_env =
     let var head  := env
     in while head <> nil
            & head.typ <> type_nil
            & head.val_car.val_car.val_s <> key

           do head := head.val_cdr
      ; if head <> nil
         & head.typ <> type_nil
            then head
        else nil
     end

   function env_push(env: vm_env, key: string, value: vm_env_elem): vm_env =
       pair_val( pair_val( sym_val(key)
                         , value)
               , env )

   function global_env_push (env: vm_env, key: string, value: vm_env_elem): vm_env =
       let
       in  if env.val_car.val_s <> GLOBAL_ENV_SENTINEL
           then print("Attempting to perform global push to non-global environment")
           else env.val_cdr := pair_val( pair_val( sym_val(key)
                                                 , value)
                                       , env.val_cdr )
        ; env
       end


   function env_to_string (env: vm_env): string =
     value_to_string(env)

   /* 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_info := tape
         var tape      := tape.tape
         var continue  := true

         function expect_type(value: scheme_value, typ: type_type, name: string) =
           if value.typ <> typ
             then run_error(concat5( name
                                   , " was not "
                                   , if typ = type_integer
                                     then "integer"
                                     else "???"
                                   , ": "
                                   , value_to_string(value)))

         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_info.filled)
              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_NUMEQ
                     | 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 expect_type(arg1, type_integer, "Argument #1 to binary operation")
                        ; expect_type(arg2, type_integer, "Argument #2 to binary operation")

                        ; 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 if opcode = OPCODE_NUMEQ
                                      then bool_val(arg1.val_i = arg2.val_i)
                                 else (run_error("Impossible!"); bool_val(0))

                        ; stack_push(stack, val)
                        ; 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_car
                               ; 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.val_car.val_cdr)
                               ; ip := ip + 1 )
                          else run_error(concat5( "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_car)
                       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(concat5( "Attempting to set unknown variable \""
                                                  , sym
                                                  , "\"\n    Environment looks like "
                                                  , env_to_string(env)
                                                  , ""))
                          else ( elem.val_car.val_cdr := head
                               ; ip := ip + 1 )
                       end

            else if tape[ip].opcode = OPCODE_FRSTR
                  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 parse non-string value ", value_to_string(head)))
                          else ( stack_push(stack, parse_string(head.val_s))
                               ; ip := ip + 1 )
                       end

            else if tape[ip].opcode = OPCODE_COMPILE
                  then let var ast := stack_pop(stack)
                       in if ast = nil
                              then run_error("Stack too shallow!")
                          else
                            let var pos_of_fun := tape_append(tape_info, compile_to_vm(ast))
                            in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY))
                             ; ip := ip + 1
                            end
                       end

            else if tape[ip].opcode = OPCODE_SETENV
                  then let var stack_fun := stack_pop(stack)
                           var stack_env := stack_pop(stack)
                       in if stack_fun = nil | stack_env = nil
                              then run_error("Stack too shallow!")
                          else if stack_fun.typ <> type_closure
                              then run_error(concat("Cannot set environment of non-function value ", value_to_string(stack_fun)))
                          else if stack_env.typ <> type_pair
                              then run_error(concat("Cannot use non-list value as environment: ", env_to_string(stack_env)))

                          else ( stack_push(stack, fun_val( stack_fun.val_i, stack_env ))
                               ; ip := ip + 1 )
                       end

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

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

        function run_error(errmsg: string) =
          let var repr_pos_l := pos_to_string(tape[ip].pos_l)
              var repr_pos_r := pos_to_string(tape[ip].pos_r)
          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
                                 , at_char(tape[ip].pos_l)
                                 , at_char(tape[ip].pos_r) ))
           ; print("\n    Source: ")
           ; print(repr_pos_l)
           ; if repr_pos_l <> repr_pos_r
             then ( print(" to ")
                  ; print(repr_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       := tape_new(1000)
   var ignore     := ( tape_append(tape, STD_LIB)
                     ; tape_append(tape, compile_to_vm(sexp_ast))
                     ; "Ignore!" )

   /*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