1624 lines
64 KiB
Plaintext
1624 lines
64 KiB
Plaintext
|
|
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_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 () =
|
|
while index < size(str) & is_ws(index)
|
|
do index := index + 1
|
|
|
|
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 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_OUTPUT, "OUTPUT", 0, 0, 0)
|
|
; code(OPCODE_TOSTR, "TOSTR", 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)
|
|
|
|
; 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(concat("Error: Instruction list invariant not maintained! First is ", concat(if a.first = nil then "" else "not ", concat( "nil, second is ", concat(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
|
|
function vm_update () =
|
|
if tape[ip] = nil
|
|
then ip := -1
|
|
|
|
/* 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")
|
|
; ip := -1
|
|
end
|
|
|
|
in while 0 <= ip & ip < tape_size
|
|
do ( vm_update()
|
|
; if DEBUG_PRINT_STACK
|
|
then ( print("[")
|
|
; print(int_to_string(ip))
|
|
; print("]: ")
|
|
; print(stack_to_string(stack))
|
|
; print("\n") ))
|
|
; if not (0 <= ip & ip < tape_size)
|
|
then print("Died due to out of bounds instruction pointer.\n")
|
|
end
|
|
|
|
/* Do stuff */
|
|
|
|
var test_text := "(begin (define add-three (lambda (x y z) (+ (+ x z) y))) \
|
|
\ (define fac (lambda (x) (if (>= x 1) (* x (fac (+ x -1))) 1))) \
|
|
\ (define (faca x a) \
|
|
\ (if (>= x 1) \
|
|
\ (faca (+ x -1) (* x a)) \
|
|
\ a)) \
|
|
\ (define (f . l) (cdr l)) \
|
|
\ (define x 5) \
|
|
\ (define y '(1 2 3)) \
|
|
\ (display x) (newline) \
|
|
\ (display (fac x)) (newline) \
|
|
\ (display (faca x 1)) (newline) \
|
|
\ (display y) (newline) \
|
|
\ (display (car y)) (newline) \
|
|
\ (display (cdr y)) (newline) \
|
|
\ (set! x 10) \
|
|
\ (display x) (newline) \
|
|
|
|
\ (define-syntax and \
|
|
\ (syntax-rules ()\
|
|
\ ((and) #t)\
|
|
\ ((and test) test)\
|
|
\ ((and test1 test2 ...)\
|
|
\ (if test1 (and test2 ...) #f))))\
|
|
|
|
\ (display (and #t #t)) (newline) \
|
|
\ (display (and #f #t)) (newline) \
|
|
\ (display (and #f #f)) (newline) \
|
|
\ (display (and #t #f)) (newline) \
|
|
\) "
|
|
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
|
|
|