diff --git a/example.scm b/example.scm index 5d0e25e..1384013 100644 --- a/example.scm +++ b/example.scm @@ -37,13 +37,17 @@ ; Math +(define (= a b) + (if (<= a b) + (>= a b) + #f)) + (define (zero? x) (= x 0)) (define (positive? x) (> x 0)) (define (negative? x) (< x 0)) (define (odd? x) (= (mod x 2) 1)) (define (even? x) (= (mod x 2) 0)) - ; Test string (display "Hello World") (newline) @@ -162,9 +166,79 @@ (newline) (newline) -(display "* R5RS: Test if-expressions*") +(display "* R5RS: Test string *") (newline) +(display "Testing string-concat\n\tExpect: Hello World\n\tGotten: ") +(display (string-append "Hello" " " "World")) +(newline) + +(define (concat-string s sep) + (foldr (lambda (e a) (string-append (datum->string e) sep a)) + "" + s)) + +(define test + (lambda (name tests) + (begin (display name) + (display "\n\tExpect: ") + (display (concat-string (map car tests) " ")) + (display "\n\tGotten: ") + (display (concat-string (map cdr tests) " ")) + (newline)))) + +(define (header name) (display (string-append "\n * " name " *\n"))) + +(header "R5RS: Test equivalence") + +(define (list-tail ls index) + (if (zero? index) + ls + (list-tail (cdr ls) (+ index -1)))) + +(define (list-ref ls index) + (car (list-tail ls index))) + +(define do-stuffer + (lambda (name_i arg1_i arg2_i) + (lambda (x) + (cons (list-ref x name_i) + (eqv? (list-ref x arg1_i) + (list-ref x arg2_i)))))) + +(define eqv-test + (lambda (name tests) + (test name (append (map (do-stuffer 0 1 2) tests) + (map (do-stuffer 0 2 1) tests) + )))) + +(eqv-test "eqv? booleans" + '( + (#t #t #t) + (#t #f #f) + (#f #t #f) + (#f #f #t) + )) + +(eqv-test "eqv? inter-types" + '( + (#f 2 a) + (#f 4 "Derp") + (#f () (a b)) + (#f 9 ()) + )) + +(eqv-test "eqv? symbols" + '( + (#t hello hello) + (#t World wOrld) + (#f hello world) + (#f hello World) + )) + + +(header "R5RS: Test if-expressions") + (display "If-then exp!\n\tExpect: 6\n\tGotten: ") (display (* 3 (if #t 2 0))) (newline) diff --git a/tigerscheme.tig b/tigerscheme.tig index 3b74f16..66f0dfd 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -26,6 +26,14 @@ let /* Booleans */ , s5: string ): string = concat(s1, concat(s2, concat(s3, concat(s4, s5)))) + function concat6 ( s1: string + , s2: string + , s3: string + , s4: string + , s5: string + , s6: string ): string = + concat(concat5(s1, s2, s3, s4, s5), s6) + function concat8 ( s1: string , s2: string , s3: string @@ -146,7 +154,8 @@ let /* Booleans */ type vm_env = scheme_value type scheme_environment = vm_env - var type_integer := 0 + var type_any := 0 + var type_integer := 8 var type_string := 1 var type_symbol := 2 var type_closure := 3 @@ -155,6 +164,28 @@ let /* Booleans */ var type_true := 6 var type_pair := 7 + var type_info := + let var type_capacity := 10 + type type_info = array of string + var type_info := type_info[type_capacity] of "" + function new_type (type_id: int, type_name: string) = + type_info[type_id] := type_name + + in new_type(type_any, "*") + ; new_type(type_integer, "integer") + ; new_type(type_string, "string") + ; new_type(type_symbol, "symbol") + ; new_type(type_closure, "function") + ; new_type(type_nil, "'()") + ; new_type(type_false, "#f") + ; new_type(type_true, "#t") + ; new_type(type_pair, "pair") + ; type_info + end + + function type_id_to_name(id: int): string = + type_info[id] + function error_value_to_string(v: scheme_value): string = if v = nil then "" @@ -284,17 +315,23 @@ let /* Booleans */ , pos_l = pos_unknown , pos_r = pos_unknown } - - function fun_val (i: int, env: scheme_environment): scheme_value = + function restrictive_fun_val (i: int, env: scheme_environment, name: string, num_args: int, vararg: bool): scheme_value = + /* TODO: Implement system for tracking expected number of arguments to function */ scheme_value { typ = type_closure , val_i = i - , val_s = "" + , val_s = name , val_car = env , val_cdr = nil , pos_l = pos_unknown , pos_r = pos_unknown } + function named_fun_val (i: int, env: scheme_environment, name: string): scheme_value = + restrictive_fun_val(i, env, name, -1, false) + + function fun_val (i: int, env: scheme_environment): scheme_value = + named_fun_val(i, env, "") + var VAL_TRUE := scheme_value { typ = type_true , val_i = 1 @@ -329,6 +366,16 @@ let /* Booleans */ , pos_l = pos_unknown , pos_r = pos_unknown } + function string_val (str: string): scheme_value = + scheme_value { typ = type_string + , val_i = 0 + , val_s = str + , val_car = nil + , val_cdr = nil + + , pos_l = pos_unknown + , pos_r = pos_unknown } + function sym_val (sym: string): scheme_value = scheme_value { typ = type_symbol , val_i = 0 @@ -727,14 +774,18 @@ let /* Booleans */ var OPCODE_FRSTR := 22 var OPCODE_COMPILE:= 23 var OPCODE_SETENV := 24 + var OPCODE_GETENV := 30 var OPCODE_NUMEQ := 25 var OPCODE_TYPEOF := 26 var OPCODE_EXIT := 27 var OPCODE_EQV := 28 + var OPCODE_CONCAT := 29 + + var OPCODE_DEBUG := 31 var vm_insn_num_opcodes := 0 var vm_insn_info := - let var expected_number_opcodes := 30 + let var expected_number_opcodes := 40 var a := vm_insn_info_l [expected_number_opcodes] of nil function code ( opcode : int , mnemonic : string @@ -742,11 +793,12 @@ let /* Booleans */ , uses_arg2 : int , uses_arg3 : int ) = ( if a[opcode] <> nil - then print(concat5( "Error: Overwriting previously defined opcode information!\n Opcode: " - , int_to_string(opcode) - , " with previous mnenomic " - , a[opcode].mnemonic - , "\n")) + then ( print(concat5( "Error: Overwriting previously defined opcode information!\n Opcode: " + , int_to_string(opcode) + , " with previous mnenomic " + , a[opcode].mnemonic + , "\n")) + ; TRIGGERED_EXIT := true ) ; a[opcode] := vm_insn_info { opcode = opcode , mnemonic = mnemonic , uses_arg1 = uses_arg1 @@ -762,7 +814,7 @@ let /* Booleans */ ; 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_LOAD, "LOAD", 2, 1, 0) ; code(OPCODE_CALL, "CALL", 1, 0, 0) ; code(OPCODE_RET, "RET", 1, 0, 0) @@ -787,8 +839,12 @@ let /* Booleans */ ; code(OPCODE_COMPILE,"COMPILE", 0, 0, 0) ; code(OPCODE_SETENV, "SETENV", 0, 0, 0) + ; code(OPCODE_GETENV, "GETENV", 0, 0, 0) ; code(OPCODE_EXIT, "EXIT", 1, 0, 0) ; code(OPCODE_EQV, "EQV", 0, 0, 0) + ; code(OPCODE_CONCAT, "CONCAT", 0, 0, 0) + + ; code(OPCODE_DEBUG, "DEBUG", 1, 0, 0) ; for i := 1 to expected_number_opcodes - 1 do if a[i] <> nil & a[i-1] = nil @@ -950,7 +1006,10 @@ let /* Booleans */ insn_list_length(std_insns) function stdfun (name: string) = - stdval(name, fun_val(tape_pos(), nil)) + stdval(name, named_fun_val(tape_pos(), nil, name)) + + function stdfun2 (name: string, num_args: int, vararg: bool) = + stdval(name, restrictive_fun_val(tape_pos(), nil, name, num_args, vararg)) in () @@ -964,6 +1023,11 @@ let /* Booleans */ ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil) ; app(OPCODE_RET, 1, "") + /* R5RS: Equivalence */ + ; stdfun2("eqv?", 2, false) + ; app(OPCODE_EQV, 0, "") + ; app(OPCODE_RET, 1, "") + /* R5RS: Boolean */ ; stdfun("not") @@ -1073,6 +1137,20 @@ let /* Booleans */ /* TODO: Rest */ + /* R5RS: String */ + + ; stdfun("string?") + ; app(OPCODE_TYPEOF, 0, "") + ; app2(OPCODE_PUSH, int_val(type_string)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("string-append") + ; app(OPCODE_SWITCH, 0, "") + ; app(OPCODE_CONCAT, 0, "") + ; app(OPCODE_SWITCH, 0, "") + ; app(OPCODE_CONCAT, 0, "") + ; app(OPCODE_RET, 1, "") /* R5RS: Output */ @@ -1128,11 +1206,24 @@ let /* Booleans */ ; app(OPCODE_FRSTR, 0, "") ; app(OPCODE_RET, 1, "") + ; stdfun("datum->string") + ; app(OPCODE_TOSTR, 0, "") + ; app(OPCODE_RET, 1, "") + ; stdfun("set-env!") ; app(OPCODE_SWITCH, 0, "") ; app(OPCODE_SETENV, 0, "") ; app(OPCODE_RET, 1, "") + ; stdfun("get-env") + ; app(OPCODE_GETENV, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("debug-show-tape") + ; app(OPCODE_DEBUG, 1, "") + ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) + ; app(OPCODE_RET, 1, "") + ; stdfun("exit") ; app(OPCODE_EXIT, true, "") @@ -1266,17 +1357,32 @@ let /* Booleans */ function copy_list (ls: vm_insn_list): vm_insn_list = list(ls.first) - function atom_to_insn (sym: scheme_value, pos_l: pos, pos_r: pos): vm_insn = + function atom_to_insn ( sym: scheme_value + , pos_l: pos + , pos_r: pos + , expected_type: type_type ): vm_insn = if sym = nil then ( print("Error in atom_to_list: Got nil as sym!\n") ; nil ) + + else if expected_type <> 0 + & sym.typ <> type_symbol + & sym.typ <> expected_type + then ( print(concat5( "Error in atom_to_list: Expected " + , type_id_to_name(expected_type) + , " but got " + , value_to_string(sym) + , "!\n")) + ; nil ) + else if is_symbol(sym) then vm_insn { opcode = OPCODE_LOAD - , arg1 = 0 + , arg1 = expected_type , arg2 = sym.val_s , arg3 = nil , pos_l = pos_l , pos_r = pos_r } + else vm_insn { opcode = OPCODE_PUSH , arg1 = 0 , arg2 = "" @@ -1459,9 +1565,9 @@ let /* Booleans */ 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) + then compile_rec(STD_LIB_ID_FUNCTION, false, type_any) else ( compile_error("Syntax of syntax-rules usage is incorrect.", ast) - ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)) ) + ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)) ) end function compile_define (ast: sexp_ast): vm_insn_list = @@ -1470,7 +1576,7 @@ let /* Booleans */ 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 insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false, type_any) var pos_l := ast.pos_l var pos_r := ast.pos_r @@ -1538,7 +1644,7 @@ let /* Booleans */ & datum.val_cdr.val_cdr.typ <> type_nil then ( compile_error("Incorrect form of unquote", datum) ; nil ) - else compile_rec(datum.val_cdr.val_car, false) + else compile_rec(datum.val_cdr.val_car, false, type_any) else if datum.val_car.typ = type_pair & datum.val_car.val_car.typ = type_symbol @@ -1548,7 +1654,7 @@ let /* Booleans */ then ( compile_error("Incorrect form of unquote-splicing", datum) ; nil ) else let var insns := list(nil) - var insns_car := compile_rec(datum.val_car.val_cdr.val_car, false) + var insns_car := compile_rec(datum.val_car.val_cdr.val_car, false, type_any) var insns_cdr := compile_quasiquote(datum.val_cdr) in if insns_cdr = nil then insns_cdr := @@ -1559,7 +1665,7 @@ let /* Booleans */ , pos_l = datum.val_cdr.pos_l , pos_r = datum.val_cdr.pos_r } ) /* TODO: Below method to call append is risky */ - ; app_insn(insns, OPCODE_LOAD, 0, "append", datum.pos_l, datum.pos_r) + ; app_insn(insns, OPCODE_LOAD, type_closure, "append", datum.pos_l, datum.pos_r) ; concat_lists(insns, insns_car) ; concat_lists(insns, insns_cdr) ; app_insn(insns, OPCODE_CALL, 2, "", datum.pos_l, datum.pos_r) @@ -1596,7 +1702,9 @@ let /* Booleans */ ; insns_car ) end - function compile_rec (ast: sexp_ast, can_tail_call: int): vm_insn_list = + function compile_rec ( ast: sexp_ast + , can_tail_call: bool + , expected_type: type_type ): vm_insn_list = if ast = nil then nil /* Throw error on free standing (). Must be either @@ -1607,17 +1715,17 @@ let /* Booleans */ /* 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) + tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r, expected_type) , can_tail_call) /* 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) + 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) 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 tail_position_one( atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r) + then compile_rec(ast.val_cdr.val_cdr.val_cdr.val_car, can_tail_call, type_any) + 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 @@ -1641,7 +1749,7 @@ let /* Booleans */ /* Syntax define statements */ else if ast.val_car <> nil & 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))) + ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0))) /* Syntax rules expression */ @@ -1654,10 +1762,12 @@ let /* Booleans */ 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 ) + do let var is_last := head.val_cdr.typ <> type_pair + in concat_lists(insns, compile_rec(head.val_car, can_tail_call & is_last, type_any)) + ; if not(is_last) + then app_insn(insns, OPCODE_POP, 0, "", ast.pos_l, ast.pos_r) + ; head := head.val_cdr + end ; insns end @@ -1693,7 +1803,7 @@ let /* Booleans */ /* 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) + var exp_insns := compile_rec(ast.val_cdr.val_cdr.val_car, false, type_any) 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) @@ -1702,7 +1812,7 @@ let /* Booleans */ /* 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) + 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 @@ -1734,6 +1844,7 @@ let /* Booleans */ ; app_insn(insns, OPCODE_DGOTO, jump_lambda, "" , pos_l, pos_r) ; concat_lists(insns, insns_ass_args) ; concat_lists(insns, insns_body) + ; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r) ; insns end @@ -1760,7 +1871,7 @@ let /* Booleans */ ; 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) ) + ; compile_rec(stack_pop(stack), can_tail_call, type_any) ) end /* Call expressions */ @@ -1772,10 +1883,10 @@ let /* Booleans */ 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)) + do ( concat_lists(args_insns, compile_rec(ast_iter.val_car, false, type_any)) ; num_args := num_args + 1 ; ast_iter := ast_iter.val_cdr ) - ; let var insns_head := compile_rec(ast.val_car, false) + ; let var insns_head := compile_rec(ast.val_car, false, type_closure) /* Below we choose whether to call * normally, or tail calling (identical * to returning) */ @@ -1803,7 +1914,7 @@ let /* Booleans */ ; print("\n") end - var base_insns := compile_rec(ast, false) + var base_insns := compile_rec(ast, false, type_any) in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r) ; base_insns end @@ -1849,9 +1960,11 @@ let /* Booleans */ else let var info := vm_insn_info[insn.opcode] in concat5( info.mnemonic - , if info.uses_arg1 - then concat(" ", int_to_string(insn.arg1)) - else "" + , if info.uses_arg1 = 2 + then concat(" ", type_id_to_name(insn.arg1)) + else if info.uses_arg1 <> 0 + then concat(" ", int_to_string(insn.arg1)) + else "" , if info.uses_arg2 then concat5(" \"", insn.arg2, "\"", "", "") else "" @@ -1905,6 +2018,8 @@ let /* Booleans */ let var tape_info := tape var tape := tape.tape var continue := true + var fun_name := "" + var ignore := ( if DEBUG_PRINT_STACK then print("Entered VM instance\n") ; "") @@ -1994,9 +2109,10 @@ let /* Booleans */ 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 + then let var call_name_pos := stack_seek_elem(stack, tape[ip].arg1) + var return_ip := ip + 1 + var return_env := env + var called_fun_name := call_name_pos.value.val_s in if call_name_pos = nil then run_error("Stack too shallow!") @@ -2004,19 +2120,36 @@ let /* Booleans */ then run_error(concat("Cannot call ", value_to_string(call_name_pos.value))) else ( ip := call_name_pos.value.val_i ; env := call_name_pos.value.val_car - ; call_name_pos.value := fun_val(return_ip, return_env) ) + ; call_name_pos.value := named_fun_val(return_ip, return_env, fun_name) + ; fun_name := called_fun_name + ) end else if tape[ip].opcode = OPCODE_LOAD then let var value_container := env_seek_elem(env, tape[ip].arg2) - in if value_container <> nil - then ( stack_push(stack, value_container.val_car.val_cdr) - ; ip := ip + 1 ) - else run_error(concat5( "Attempting to access unknown variable \"" + var value := if value_container <> nil + & value_container.val_car <> nil + & value_container.val_car.val_cdr <>nil + then value_container.val_car.val_cdr + else nil + + in /* Variable not in environment */ + if value = nil + then run_error(concat5( "Attempting to access unknown variable \"" , tape[ip].arg2 , "\"\n Environment looks like " , env_to_string(env) , "")) + else if tape[ip].arg1 <> 0 + & tape[ip].arg1 <> value.typ + then run_error(concat6( "Attempting to access variable \"" + , tape[ip].arg2 + , "\" expecting to find " + , type_id_to_name(tape[ip].arg1) + , ", but found " + , value_to_string(value))) + else ( stack_push(stack, value) + ; ip := ip + 1 ) end else if tape[ip].opcode = OPCODE_DEF @@ -2029,7 +2162,13 @@ let /* Booleans */ 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 + in if false + then ( print("Defining new global \"") + ; print(tape[ip].arg2) + ; print("\" with value: ") + ; print(value_to_string(value)) + ; print("\n") ) + ; env := new_env ; ip := ip + 1 end @@ -2044,8 +2183,9 @@ let /* Booleans */ /* TODO: Improve */ continue := false else if not(is_function(return_to)) then run_error(concat("Cannot return to non-function value ", value_to_string(return_to))) - else ( ip := return_to.val_i - ; env := return_to.val_car) + else ( fun_name := return_to.val_s + ; ip := return_to.val_i + ; env := return_to.val_car) end else if tape[ip].opcode = OPCODE_POP @@ -2082,7 +2222,7 @@ let /* Booleans */ 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))) + 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 @@ -2091,7 +2231,7 @@ let /* Booleans */ 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))) + 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 @@ -2145,6 +2285,16 @@ let /* Booleans */ ; ip := ip + 1 end + else if tape[ip].opcode = OPCODE_GETENV + then let var stack_fun := stack_pop(stack) + in expect_value(stack_fun, "function") + ; if stack_fun.typ <> type_closure + then run_error(concat("Cannot get environment of non-function value ", value_to_string(stack_fun))) + + ; stack_push(stack, stack_fun.val_car) + ; ip := ip + 1 + end + else if tape[ip].opcode = OPCODE_TYPEOF then let var value := stack_pop(stack) in expect_value(value, "") @@ -2167,6 +2317,24 @@ let /* Booleans */ ; ip := ip + 1 end + else if tape[ip].opcode = OPCODE_CONCAT + then let var arg1 := stack_pop(stack) + var arg2 := stack_pop(stack) + + in expect_type(arg1, type_string, "argument #1 to concat") + ; expect_type(arg2, type_string, "argument #2 to concat") + ; stack_push(stack, string_val(concat(arg1.val_s, arg2.val_s))) + ; ip := ip + 1 + end + + else if tape[ip].opcode = OPCODE_DEBUG + then let var arg := stack_pop(stack) + + in if tape[ip].arg1 + then DEBUG_PRINT_TAPE := (arg = nil | is_truthy(arg)) + ; ip := ip + 1 + end + else run_error(concat("Encountered unknown opcode " , int_to_string(tape[ip].opcode))) @@ -2174,11 +2342,22 @@ let /* Booleans */ let in print("Tiger-scheme runtime error\n ") ; print(errmsg) - ; print("\n At instruction ") + ; print("\n") + + /* Function name? */ + ; if fun_name <> "" + then ( print(" In function \"") + ; print(fun_name) + ; print("\"\n")) + + /* Instruction position */ + ; print(" At instruction ") ; print(int_to_string(ip)) ; print(": ") ; print(insn_to_string(tape[ip])) ; print("\n") + + /* Tape information? */ ; if tape[ip] <> nil then let var repr_pos_l := pos_to_string(tape[ip].pos_l) var repr_pos_r := pos_to_string(tape[ip].pos_r)