From 5b508bf75c4fd8eb8e740ac8574dd7e3baed5cff Mon Sep 17 00:00:00 2001 From: Jon Michael Aanes Date: Wed, 2 Jan 2019 18:33:03 +0100 Subject: [PATCH] Improved bytecode output when calling a locally defined lambda. --- tigerscheme.tig | 229 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 175 insertions(+), 54 deletions(-) diff --git a/tigerscheme.tig b/tigerscheme.tig index d740b88..579160c 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -13,6 +13,8 @@ let /* Booleans */ var DEBUG_PRINT_TAPE : bool := false var DEBUG_PRINT_PARSED : bool := false var DEBUG_PRINT_JUMPS : bool := false + var DEBUG_PRINT_MACRO : bool := true + var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false var ALLOW_TAPE_RESIZE : bool := true @@ -116,11 +118,14 @@ let /* Booleans */ 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 line_num (pos: pos): int = + if pos <> nil + then pos.line_num + else -3 function at_char (pos: pos): int = if pos <> nil then pos.at_char - else -1 + else -3 function pos_delta_char (pos: pos, delta: int): pos = new_pos( line_num(pos) @@ -128,9 +133,12 @@ let /* Booleans */ var pos_unknown : pos := new_pos(-1, -1) var pos_preamble: pos := new_pos(-2, -2) + var pos_bad : pos := new_pos(-3, -3) function pos_to_string (pos: pos): string = - if pos = pos_unknown + if pos <> nil + then "no position" + else if pos = pos_unknown then "unknown position" else if pos = pos_preamble then "preamble" @@ -403,6 +411,13 @@ let /* Booleans */ & b.typ = type_integer & a.val_i = b.val_i + function scheme_value_is_proper_list (ls: scheme_value): bool = + if ls = nil + then false + else ls.typ = type_nil + | ls.typ = type_pair + & scheme_value_is_proper_list(ls.val_cdr) + /* evq? See for definition: * https://people.csail.mit.edu/jaffer/r5rs/Equivalence-predicates.html * */ @@ -594,7 +609,9 @@ let /* Booleans */ function parse_rec (): sexp_ast = ( ignore_ws() - ; if is_symbol(index) + ; if index >= size(str) + then (parse_error("Reached end of string"); nil) + else if is_symbol(index) then let var start_pos := new_pos(line_number, index) in while index < size(str) & is_symbol(index) do index := index + 1 @@ -726,7 +743,9 @@ let /* Booleans */ ; print("\n") end - in parse_rec() + in if size(str) > 0 + then parse_rec() + else (parse_error("Nothing to parse. Given string empty!"); nil) end /**** Instructions ****/ @@ -781,6 +800,7 @@ let /* Booleans */ var OPCODE_EXIT := 27 var OPCODE_EQV := 28 var OPCODE_CONCAT := 29 + var OPCODE_FORGET := 32 var OPCODE_DEBUG := 31 @@ -821,6 +841,7 @@ let /* Booleans */ ; code(OPCODE_RET, "RET", 1, 0, 0) ; code(OPCODE_DEF, "DEF", 0, 1, 0) + ; code(OPCODE_FORGET, "FORGET", 1, 0, 0) ; code(OPCODE_SETG, "SETG", 0, 1, 0) ; code(OPCODE_DEFFUN, "DEFFUN", 1, 0, 0) ; code(OPCODE_POP, "POP", 0, 0, 0) @@ -988,6 +1009,7 @@ let /* Booleans */ , 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 @@ -1253,6 +1275,15 @@ let /* Booleans */ ; stdfun("exit") ; app(OPCODE_EXIT, true, "") + /* Misc??? */ + ; stdfun("symbol?") + ; app(OPCODE_TYPEOF, 0, "") + ; app2(OPCODE_PUSH, int_val(type_symbol)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_RET, 1, "") + + + ; std_insns end @@ -1348,6 +1379,9 @@ let /* Booleans */ , value) , env ) + function env_pop(env: vm_env): vm_env = + env.val_cdr + 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 @@ -1728,6 +1762,17 @@ let /* Booleans */ ; insns_car ) end + function compile_load_of_arguments ( insns: vm_insn_list + , sexp_args: sexp_ast + , pos_l: pos + , pos_r: pos) = + if sexp_args = nil + | sexp_args.typ = type_nil + | sexp_args.val_car = nil + then () + else ( compile_load_of_arguments(insns, sexp_args.val_cdr, pos_l, pos_r) + ; app_insn(insns, OPCODE_DEF, 0, sexp_args.val_car.val_s, pos_l, pos_r) ) + function compile_rec ( ast: sexp_ast , can_tail_call: bool , expected_type: type_type ): vm_insn_list = @@ -1744,8 +1789,13 @@ let /* Booleans */ tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r, expected_type) , can_tail_call) + else if ast.val_car = nil + | ast.val_cdr = nil + then ( compile_error("Attemping to compile malformed ast", ast) + ; nil ) + /* If statements */ - else if ast.val_car <> nil + else if ast.val_car.typ = type_symbol & ast.val_car.val_s = "if" then let var insns_test := compile_rec(ast.val_cdr.val_car, false, type_any) var insns_then := compile_rec(ast.val_cdr.val_cdr.val_car, can_tail_call, type_any) @@ -1754,36 +1804,43 @@ let /* Booleans */ else tail_position_one( atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0) , can_tail_call) - var jump_then := sexp_ast_length(insns_then) + 1 - var jump_else := sexp_ast_length(insns_else) + 1 + 1 + var jump_then := sexp_ast_length(insns_then) + 1 + (if can_tail_call then 0 else 1) + var jump_else := sexp_ast_length(insns_else) + 1 var pos_l := ast.pos_l var pos_r := ast.pos_r - in app_insn(insns_test, OPCODE_CSKIP, 2, "" , 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) + in app_insn(insns_test, OPCODE_CSKIP, jump_then, "" , pos_l, pos_r) ; concat_lists(insns_test, insns_then) + ; if not(can_tail_call) + then app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r) + ; concat_lists(insns_test, insns_else) ; insns_test end /* Define statements */ - else if ast.val_car <> nil & ast.val_car.val_s = "define" + else if ast.val_car.typ = type_symbol + & 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" + else if ast.val_car.typ = type_symbol + & ast.val_car.val_s = "define-syntax" then ( compile_error("Please do not compile define-syntax", ast) ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0))) /* 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" + /* TODO: Implement using macroes, when those are + * available. */ + else if ast.val_car.typ = type_symbol + & ast.val_car.val_s = "begin" then let var insns := vm_insn_list { first = nil, last = nil } var head := ast.val_cdr @@ -1798,7 +1855,8 @@ let /* Booleans */ end /* Quote expressions */ - else if ast.val_car <> nil & ast.val_car.val_s = "quote" + else if ast.val_car.typ = type_symbol + & ast.val_car.val_s = "quote" then let var datum := ast.val_cdr.val_car in tail_position_one( vm_insn { opcode = OPCODE_PUSH @@ -1811,7 +1869,8 @@ let /* Booleans */ end /* Quasi-Quote expressions */ - else if ast.val_car <> nil & ast.val_car.val_s = "quasiquote" + else if ast.val_car.typ = type_symbol + & ast.val_car.val_s = "quasiquote" then let var datum := ast.val_cdr.val_car var insns := compile_quasiquote(datum) @@ -1827,7 +1886,8 @@ let /* Booleans */ end /* Set statements */ - else if ast.val_car <> nil & ast.val_car.val_s = "set!" + else if ast.val_car.typ = type_symbol + & 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, type_any) @@ -1837,46 +1897,30 @@ let /* Booleans */ end /* Lambda expressions */ - else if ast.val_car <> nil & ast.val_car.val_s = "lambda" + else if ast.val_car.typ = type_symbol + & ast.val_car.val_s = "lambda" + then let var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, true, type_any) 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) + + sexp_list_length(ast.val_cdr.val_car) + 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) + ; compile_load_of_arguments(insns, ast.val_cdr.val_car, pos_l, pos_r) ; concat_lists(insns, insns_body) ; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r) ; insns end /* Macro applications */ - else if ast.val_car <> nil - & ast.val_car.typ = type_symbol + else if ast.val_car.typ = type_symbol & ast.val_car.val_s <> "" & env_seek_elem(env_macro, ast.val_car.val_s) <> nil then let var stack := stack_new() @@ -1895,11 +1939,61 @@ let /* Booleans */ , ast) ; TRIGGERED_EXIT := true ; nil ) - else ( vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global) - /* TODO: Assert that there is something on the stack */ - ; compile_rec(stack_pop(stack), can_tail_call, type_any) ) + else let var derp: scheme_value := nil + in vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global) + ; /* TODO: Assert that there is something on the stack */ + derp := stack_pop(stack) + ; if DEBUG_PRINT_MACRO + then ( print("Macro expanded to: ") + ; print(value_to_string(derp)) + ; print("\n") ) + ; compile_rec(derp, can_tail_call, type_any) + end end + /* Call-lambda expressions: A system for binding local + * variables */ + /* Lambda expressions */ + else if ast.val_car.typ = type_pair + & ast.val_car.val_car.typ = type_symbol + & ast.val_car.val_car.val_s = "lambda" + + /* Does not support non-proper lists, currently: */ + & scheme_value_is_proper_list (ast.val_car.val_cdr.val_car) + then + let var pos_l := ast.pos_l + var pos_r := ast.pos_r + + var insns := vm_insn_list { first = nil, last = nil } + + var num_required_args := sexp_list_length (ast.val_car.val_cdr.val_car) + var num_given_args := sexp_list_length (ast.val_cdr) + /* TODO: Give error when numbers of arguments does + * not match */ + + var ast_iter := ast.val_cdr + + in () + + /* First compile arguments onto stack */ + ; while ast_iter <> nil & ast_iter.typ = type_pair + do ( concat_lists(insns, compile_rec(ast_iter.val_car, false, type_any)) + ; ast_iter := ast_iter.val_cdr ) + + /* Then assign them to variables */ + ; print(concat(value_to_string(ast.val_car.val_cdr.val_car), "\n")) + ; compile_load_of_arguments(insns, ast.val_car.val_cdr.val_car, pos_l, pos_r) + + /* Perform body */ + ; concat_lists(insns, compile_rec(ast.val_car.val_cdr.val_cdr.val_car, can_tail_call, type_any)) + + /* Forget variables again */ + ; app_insn(insns, OPCODE_FORGET, num_required_args, "", pos_l, pos_r) + + /* Return instructions */ + ; insns + end + /* Call expressions */ else let var num_args := 0 var args_insns := vm_insn_list { first = nil, last = nil } @@ -1926,8 +2020,8 @@ let /* Booleans */ 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) + let var repr_pos_l := pos_to_string(if errast = nil then nil else errast.pos_l) + var repr_pos_r := pos_to_string(if errast = nil then nil else errast.pos_r) in print("Tiger-scheme compile error\n ") ; print(errmsg) ; print("\n For scheme: ") @@ -1940,8 +2034,12 @@ let /* Booleans */ ; print("\n") end - var base_insns := compile_rec(ast, false, type_any) - in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r) + var base_insns := + if ast = nil + then (compile_error("Given ast was nil!", ast); nil) + else compile_rec(ast, false, type_any) + in if ast <> nil + then app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r) ; base_insns end @@ -2163,9 +2261,12 @@ let /* Booleans */ if value = nil then run_error(concat5( "Attempting to access unknown variable \"" , tape[ip].arg2 - , "\"\n Environment looks like " - , env_to_string(env) - , "")) + , "\"\n" + , "" + , if DEBUG_SHOW_FULL_ENVIRONMENT + then concat( "\tEnvironment looks like " + , env_to_string(env)) + else "")) else if tape[ip].arg1 <> 0 & tape[ip].arg1 <> value.typ then run_error(concat6( "Attempting to access variable \"" @@ -2185,6 +2286,11 @@ let /* Booleans */ ; ip := ip + 1 end + else if tape[ip].opcode = OPCODE_FORGET + then ( for i := 1 to tape[ip].arg1 + do env := env_pop(env) + ; ip := ip + 1 ) + 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) @@ -2450,14 +2556,26 @@ let /* Booleans */ let var depth := 0 var char := "BAD SHIT HAPPENED" var text := "" + var comment_mode := false in while char <> "" do ( char := getchar() ; text := concat(text, char) - ; if char = "(" + ; if comment_mode + & char = "\n" + then comment_mode := false + else if comment_mode + then () /* Do nothing */ + + /* We can assume that comment mode is not enabled for + * these: */ + else if char = "(" then depth := depth + 1 else if char = ")" then ( depth := depth - 1 - ; if depth = 0 then break )) + ; if depth = 0 then break ) + else if char = ";" + then comment_mode := true + ) ; text end @@ -2473,9 +2591,12 @@ in print("Ready for the scheming Tiger?\n") var macro_name := "" /* Not macro is "" */ - var sexp := parse_string(text) + var sexp := if size(text) > 0 + then parse_string(text) + else nil var sexp_compile := - if sexp.typ = type_pair + if sexp <> nil + & sexp.typ = type_pair & sexp.val_car.typ = type_symbol & sexp.val_car.val_s = "define-syntax" then ( macro_name := sexp.val_cdr.val_car.val_s