From 4faad40a1bdfe9dd5aa6460f9538224dd5bba243 Mon Sep 17 00:00:00 2001 From: Jon Michael Aanes Date: Mon, 3 Dec 2018 15:06:12 +0100 Subject: [PATCH] "Initial" commit of Tiger Scheme. --- tigerscheme.tig | 1436 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1436 insertions(+) create mode 100644 tigerscheme.tig diff --git a/tigerscheme.tig b/tigerscheme.tig new file mode 100644 index 0000000..469bd99 --- /dev/null +++ b/tigerscheme.tig @@ -0,0 +1,1436 @@ + +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)) + + /* Scheme value system */ + + type scheme_value = { typ : int + , 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("")) + + 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.typ <> type_false & (IS_NIL_TRUTHY | e.typ <> type_nil) + + function is_integer (e: scheme_value): bool = + e.typ = type_integer + + function is_string (e: scheme_value): bool = + e.typ = type_string + + function is_function (e: scheme_value): bool = + e.typ = type_closure + + function is_pair (e: scheme_value): bool = + e.typ = type_pair + + function is_symbol (e: scheme_value): bool = + 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 + + function max (a:int, b:int): int = + if a > b then a else b + + 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 ( parse_error("Internal assertion failed") + ; sexp_nil(-1, -1)) + 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") + 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 := 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 stdfun (name: string) = + stdval(name, fun_val(insn_list_length(std_insns), nil)) + + in () + + /* Nil */ + ; if HAS_NIL_SYMBOL + then stdval("nil", nil_val()) + + /* 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 compile_define_syntax (ast: sexp_ast): vm_insn_list = + let var syntax_name := ast.val_cdr.val_car.val_s + var variables := ast.val_cdr.val_cdr.val_car.val_cdr.val_car + var rules := ast.val_cdr.val_cdr.val_car.val_cdr.val_cdr + + var check_1 := ( ast.val_cdr.val_cdr.val_cdr.typ = type_nil ) + var check_2 := ( ast.val_cdr.val_cdr.val_car.val_car.typ = type_symbol + & ast.val_cdr.val_cdr.val_car.val_car.val_s = "define-syntax") + /* TODO */ + in ( compile_error("define-syntax not implemented!", ast) + ; list(nil) ) + end + + function compile_define (ast: sexp_ast): vm_insn_list = + + /* Standard define form: (define ) */ + 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 ( ) ) */ + /* (define ( . ) ) */ + 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 )\n\ + \ (define ( ) )\n\ + \ (define ( . ) )" + , 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) + + /* 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(substring(source, tape[ip].pos_l, 1 + tape[ip].pos_r - tape[ip].pos_l)) + ; 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 +