Jmaa/tiger-scheme
1
0
Fork 0
Code

Added testing functionality and lots of debugging systems, which also resulted in a bunch of bug-fixes.

Browse Source
This commit is contained in:
Jon Michael Aanes 2018-12-28 19:52:57 +01:00
parent f9e1e18961
commit 7231ae67c0
2 changed files with 309 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
example.scm
View File

@ -37,13 +37,17 @@
; Math ; Math
(define (= a b)
(if (<= a b)
(>= a b)
#f))
(define (zero? x) (= x 0)) (define (zero? x) (= x 0))
(define (positive? x) (> x 0)) (define (positive? x) (> x 0))
(define (negative? x) (< x 0)) (define (negative? x) (< x 0))
(define (odd? x) (= (mod x 2) 1)) (define (odd? x) (= (mod x 2) 1))
(define (even? x) (= (mod x 2) 0)) (define (even? x) (= (mod x 2) 0))
; Test string ; Test string
(display "Hello World") (newline) (display "Hello World") (newline)
@ -162,9 +166,79 @@
(newline) (newline)
(newline) (newline)
(display "* R5RS: Test if-expressions*") (display "* R5RS: Test string *")
(newline) (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 "If-then exp!\n\tExpect: 6\n\tGotten: ")
(display (* 3 (if #t 2 0))) (display (* 3 (if #t 2 0)))
(newline) (newline)

287
tigerscheme.tig
View File

@ -26,6 +26,14 @@ let /* Booleans */
, s5: string ): string = , s5: string ): string =
concat(s1, concat(s2, concat(s3, concat(s4, s5)))) 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 function concat8 ( s1: string
, s2: string , s2: string
, s3: string , s3: string
@ -146,7 +154,8 @@ let /* Booleans */
type vm_env = scheme_value type vm_env = scheme_value
type scheme_environment = vm_env type scheme_environment = vm_env
var type_integer := 0 var type_any := 0
var type_integer := 8
var type_string := 1 var type_string := 1
var type_symbol := 2 var type_symbol := 2
var type_closure := 3 var type_closure := 3
@ -155,6 +164,28 @@ let /* Booleans */
var type_true := 6 var type_true := 6
var type_pair := 7 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 = function error_value_to_string(v: scheme_value): string =
if v = nil if v = nil
then "<TIGER NIL>" then "<TIGER NIL>"
@ -284,17 +315,23 @@ let /* Booleans */
, pos_l = pos_unknown , pos_l = pos_unknown
, pos_r = pos_unknown } , pos_r = pos_unknown }
function restrictive_fun_val (i: int, env: scheme_environment, name: string, num_args: int, vararg: bool): scheme_value =
function fun_val (i: int, env: scheme_environment): scheme_value = /* TODO: Implement system for tracking expected number of arguments to function */
scheme_value { typ = type_closure scheme_value { typ = type_closure
, val_i = i , val_i = i
, val_s = "" , val_s = name
, val_car = env , val_car = env
, val_cdr = nil , val_cdr = nil
, pos_l = pos_unknown , pos_l = pos_unknown
, pos_r = 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 := var VAL_TRUE :=
scheme_value { typ = type_true scheme_value { typ = type_true
, val_i = 1 , val_i = 1
@ -329,6 +366,16 @@ let /* Booleans */
, pos_l = pos_unknown , pos_l = pos_unknown
, pos_r = 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 = function sym_val (sym: string): scheme_value =
scheme_value { typ = type_symbol scheme_value { typ = type_symbol
, val_i = 0 , val_i = 0
@ -727,14 +774,18 @@ let /* Booleans */
var OPCODE_FRSTR := 22 var OPCODE_FRSTR := 22
var OPCODE_COMPILE:= 23 var OPCODE_COMPILE:= 23
var OPCODE_SETENV := 24 var OPCODE_SETENV := 24
var OPCODE_GETENV := 30
var OPCODE_NUMEQ := 25 var OPCODE_NUMEQ := 25
var OPCODE_TYPEOF := 26 var OPCODE_TYPEOF := 26
var OPCODE_EXIT := 27 var OPCODE_EXIT := 27
var OPCODE_EQV := 28 var OPCODE_EQV := 28
var OPCODE_CONCAT := 29
var OPCODE_DEBUG := 31
var vm_insn_num_opcodes := 0 var vm_insn_num_opcodes := 0
var vm_insn_info := 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 var a := vm_insn_info_l [expected_number_opcodes] of nil
function code ( opcode : int function code ( opcode : int
, mnemonic : string , mnemonic : string
@ -742,11 +793,12 @@ let /* Booleans */
, uses_arg2 : int , uses_arg2 : int
, uses_arg3 : int ) = , uses_arg3 : int ) =
( if a[opcode] <> nil ( if a[opcode] <> nil
then print(concat5( "Error: Overwriting previously defined opcode information!\n Opcode: " then ( print(concat5( "Error: Overwriting previously defined opcode information!\n Opcode: "
, int_to_string(opcode) , int_to_string(opcode)
, " with previous mnenomic " , " with previous mnenomic "
, a[opcode].mnemonic , a[opcode].mnemonic
, "\n")) , "\n"))
; TRIGGERED_EXIT := true )
; a[opcode] := vm_insn_info { opcode = opcode ; a[opcode] := vm_insn_info { opcode = opcode
, mnemonic = mnemonic , mnemonic = mnemonic
, uses_arg1 = uses_arg1 , uses_arg1 = uses_arg1
@ -762,7 +814,7 @@ let /* Booleans */
; code(OPCODE_DUPL, "DUPL", 1, 0, 0) ; code(OPCODE_DUPL, "DUPL", 1, 0, 0)
; code(OPCODE_SWITCH, "SWITCH", 0, 0, 0) ; code(OPCODE_SWITCH, "SWITCH", 0, 0, 0)
; code(OPCODE_MULT, "MULT", 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_CALL, "CALL", 1, 0, 0)
; code(OPCODE_RET, "RET", 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_COMPILE,"COMPILE", 0, 0, 0)
; code(OPCODE_SETENV, "SETENV", 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_EXIT, "EXIT", 1, 0, 0)
; code(OPCODE_EQV, "EQV", 0, 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 ; for i := 1 to expected_number_opcodes - 1
do if a[i] <> nil & a[i-1] = nil do if a[i] <> nil & a[i-1] = nil
@ -950,7 +1006,10 @@ let /* Booleans */
insn_list_length(std_insns) insn_list_length(std_insns)
function stdfun (name: string) = 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 () in ()
@ -964,6 +1023,11 @@ let /* Booleans */
; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil) ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
; app(OPCODE_RET, 1, "") ; app(OPCODE_RET, 1, "")
/* R5RS: Equivalence */
; stdfun2("eqv?", 2, false)
; app(OPCODE_EQV, 0, "")
; app(OPCODE_RET, 1, "")
/* R5RS: Boolean */ /* R5RS: Boolean */
; stdfun("not") ; stdfun("not")
@ -1073,6 +1137,20 @@ let /* Booleans */
/* TODO: Rest */ /* 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 */ /* R5RS: Output */
@ -1128,11 +1206,24 @@ let /* Booleans */
; app(OPCODE_FRSTR, 0, "") ; app(OPCODE_FRSTR, 0, "")
; app(OPCODE_RET, 1, "") ; app(OPCODE_RET, 1, "")
; stdfun("datum->string")
; app(OPCODE_TOSTR, 0, "")
; app(OPCODE_RET, 1, "")
; stdfun("set-env!") ; stdfun("set-env!")
; app(OPCODE_SWITCH, 0, "") ; app(OPCODE_SWITCH, 0, "")
; app(OPCODE_SETENV, 0, "") ; app(OPCODE_SETENV, 0, "")
; app(OPCODE_RET, 1, "") ; 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") ; stdfun("exit")
; app(OPCODE_EXIT, true, "") ; app(OPCODE_EXIT, true, "")
@ -1266,17 +1357,32 @@ let /* Booleans */
function copy_list (ls: vm_insn_list): vm_insn_list = function copy_list (ls: vm_insn_list): vm_insn_list =
list(ls.first) 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 if sym = nil
then ( print("Error in atom_to_list: Got nil as sym!\n") then ( print("Error in atom_to_list: Got nil as sym!\n")
; nil ) ; 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) else if is_symbol(sym)
then vm_insn { opcode = OPCODE_LOAD then vm_insn { opcode = OPCODE_LOAD
, arg1 = 0 , arg1 = expected_type
, arg2 = sym.val_s , arg2 = sym.val_s
, arg3 = nil , arg3 = nil
, pos_l = pos_l , pos_l = pos_l
, pos_r = pos_r } , pos_r = pos_r }
else vm_insn { opcode = OPCODE_PUSH else vm_insn { opcode = OPCODE_PUSH
, arg1 = 0 , arg1 = 0
, arg2 = "" , arg2 = ""
@ -1459,9 +1565,9 @@ let /* Booleans */
function compile_syntax_rules (ast: sexp_ast): vm_insn_list = function compile_syntax_rules (ast: sexp_ast): vm_insn_list =
let let
in if sexp_is_syntax_rules(ast) 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) 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 end
function compile_define (ast: sexp_ast): vm_insn_list = function compile_define (ast: sexp_ast): vm_insn_list =
@ -1470,7 +1576,7 @@ let /* Booleans */
if ast.val_cdr.val_car.typ = type_symbol if ast.val_cdr.val_car.typ = type_symbol
& ast.val_cdr.val_cdr.val_cdr.typ = type_nil & ast.val_cdr.val_cdr.val_cdr.typ = type_nil
then let var symbol := ast.val_cdr.val_car.val_s 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_l := ast.pos_l
var pos_r := ast.pos_r var pos_r := ast.pos_r
@ -1538,7 +1644,7 @@ let /* Booleans */
& datum.val_cdr.val_cdr.typ <> type_nil & datum.val_cdr.val_cdr.typ <> type_nil
then ( compile_error("Incorrect form of unquote", datum) then ( compile_error("Incorrect form of unquote", datum)
; nil ) ; 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 else if datum.val_car.typ = type_pair
& datum.val_car.val_car.typ = type_symbol & datum.val_car.val_car.typ = type_symbol
@ -1548,7 +1654,7 @@ let /* Booleans */
then ( compile_error("Incorrect form of unquote-splicing", datum) then ( compile_error("Incorrect form of unquote-splicing", datum)
; nil ) ; nil )
else let var insns := list(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) var insns_cdr := compile_quasiquote(datum.val_cdr)
in if insns_cdr = nil in if insns_cdr = nil
then insns_cdr := then insns_cdr :=
@ -1559,7 +1665,7 @@ let /* Booleans */
, pos_l = datum.val_cdr.pos_l , pos_l = datum.val_cdr.pos_l
, pos_r = datum.val_cdr.pos_r } ) , pos_r = datum.val_cdr.pos_r } )
/* TODO: Below method to call append is risky */ /* 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_car)
; concat_lists(insns, insns_cdr) ; concat_lists(insns, insns_cdr)
; app_insn(insns, OPCODE_CALL, 2, "", datum.pos_l, datum.pos_r) ; app_insn(insns, OPCODE_CALL, 2, "", datum.pos_l, datum.pos_r)
@ -1596,7 +1702,9 @@ let /* Booleans */
; insns_car ) ; insns_car )
end 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 if ast = nil then nil
/* Throw error on free standing (). Must be either /* Throw error on free standing (). Must be either
@ -1607,17 +1715,17 @@ let /* Booleans */
/* Handle numbers and other constants */ /* Handle numbers and other constants */
else if ast.typ <> type_pair then 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) , can_tail_call)
/* If statements */ /* If statements */
else if ast.val_car <> nil else if ast.val_car <> nil
& ast.val_car.val_s = "if" & ast.val_car.val_s = "if"
then let var insns_test := compile_rec(ast.val_cdr.val_car, false) 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) 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 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) 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) else tail_position_one( atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)
, can_tail_call) , can_tail_call)
var jump_then := sexp_ast_length(insns_then) + 1 var jump_then := sexp_ast_length(insns_then) + 1
@ -1641,7 +1749,7 @@ let /* Booleans */
/* Syntax define statements */ /* Syntax define statements */
else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax" else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
then ( compile_error("Please do not compile define-syntax", ast) 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 */ /* Syntax rules expression */
@ -1654,10 +1762,12 @@ let /* Booleans */
var head := ast.val_cdr var head := ast.val_cdr
in while head <> nil & head.typ = type_pair in while head <> nil & head.typ = type_pair
do ( if head <> ast.val_cdr do let var is_last := head.val_cdr.typ <> type_pair
then app_insn(insns, OPCODE_POP, 0, "", ast.pos_l, ast.pos_r) in concat_lists(insns, compile_rec(head.val_car, can_tail_call & is_last, type_any))
; concat_lists(insns, compile_rec(head.val_car, false)) ; if not(is_last)
; head := head.val_cdr ) then app_insn(insns, OPCODE_POP, 0, "", ast.pos_l, ast.pos_r)
; head := head.val_cdr
end
; insns ; insns
end end
@ -1693,7 +1803,7 @@ let /* Booleans */
/* Set statements */ /* Set statements */
else if ast.val_car <> nil & ast.val_car.val_s = "set!" else if ast.val_car <> nil & ast.val_car.val_s = "set!"
then let var sym := ast.val_cdr.val_car.val_s 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) 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) ; app_insn2(exp_insns, OPCODE_PUSH, VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)
@ -1702,7 +1812,7 @@ let /* Booleans */
/* Lambda expressions */ /* Lambda expressions */
else if ast.val_car <> nil & ast.val_car.val_s = "lambda" 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_l := ast.pos_l
var pos_r := ast.pos_r var pos_r := ast.pos_r
@ -1734,6 +1844,7 @@ let /* Booleans */
; app_insn(insns, OPCODE_DGOTO, jump_lambda, "" , 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_ass_args)
; concat_lists(insns, insns_body) ; concat_lists(insns, insns_body)
; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r)
; insns ; insns
end end
@ -1760,7 +1871,7 @@ let /* Booleans */
; nil ) ; nil )
else ( vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global) else ( vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global)
/* TODO: Assert that there is something on the stack */ /* 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 end
/* Call expressions */ /* Call expressions */
@ -1772,10 +1883,10 @@ let /* Booleans */
var pos_r := ast.pos_r var pos_r := ast.pos_r
in while ast_iter <> nil & ast_iter.typ = type_pair 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 ; num_args := num_args + 1
; ast_iter := ast_iter.val_cdr ) ; 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 /* Below we choose whether to call
* normally, or tail calling (identical * normally, or tail calling (identical
* to returning) */ * to returning) */
@ -1803,7 +1914,7 @@ let /* Booleans */
; print("\n") ; print("\n")
end 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) in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
; base_insns ; base_insns
end end
@ -1849,9 +1960,11 @@ let /* Booleans */
else else
let var info := vm_insn_info[insn.opcode] let var info := vm_insn_info[insn.opcode]
in concat5( info.mnemonic in concat5( info.mnemonic
, if info.uses_arg1 , if info.uses_arg1 = 2
then concat(" ", int_to_string(insn.arg1)) then concat(" ", type_id_to_name(insn.arg1))
else "" else if info.uses_arg1 <> 0
then concat(" ", int_to_string(insn.arg1))
else ""
, if info.uses_arg2 , if info.uses_arg2
then concat5(" \"", insn.arg2, "\"", "", "") then concat5(" \"", insn.arg2, "\"", "", "")
else "" else ""
@ -1905,6 +2018,8 @@ let /* Booleans */
let var tape_info := tape let var tape_info := tape
var tape := tape.tape var tape := tape.tape
var continue := true var continue := true
var fun_name := ""
var ignore := ( if DEBUG_PRINT_STACK var ignore := ( if DEBUG_PRINT_STACK
then print("Entered VM instance\n") then print("Entered VM instance\n")
; "") ; "")
@ -1994,9 +2109,10 @@ let /* Booleans */
end end
else if tape[ip].opcode = OPCODE_CALL else if tape[ip].opcode = OPCODE_CALL
then let var call_name_pos := stack_seek_elem(stack, tape[ip].arg1) then let var call_name_pos := stack_seek_elem(stack, tape[ip].arg1)
var return_ip := ip + 1 var return_ip := ip + 1
var return_env := env var return_env := env
var called_fun_name := call_name_pos.value.val_s
in if call_name_pos = nil in if call_name_pos = nil
then run_error("Stack too shallow!") 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))) then run_error(concat("Cannot call ", value_to_string(call_name_pos.value)))
else ( ip := call_name_pos.value.val_i else ( ip := call_name_pos.value.val_i
; env := call_name_pos.value.val_car ; 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 end
else if tape[ip].opcode = OPCODE_LOAD else if tape[ip].opcode = OPCODE_LOAD
then let var value_container := env_seek_elem(env, tape[ip].arg2) then let var value_container := env_seek_elem(env, tape[ip].arg2)
in if value_container <> nil var value := if value_container <> nil
then ( stack_push(stack, value_container.val_car.val_cdr) & value_container.val_car <> nil
; ip := ip + 1 ) & value_container.val_car.val_cdr <>nil
else run_error(concat5( "Attempting to access unknown variable \"" 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 , tape[ip].arg2
, "\"\n Environment looks like " , "\"\n Environment looks like "
, env_to_string(env) , 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 end
else if tape[ip].opcode = OPCODE_DEF else if tape[ip].opcode = OPCODE_DEF
@ -2029,7 +2162,13 @@ let /* Booleans */
else if tape[ip].opcode = OPCODE_SETG else if tape[ip].opcode = OPCODE_SETG
then let var value := stack_pop(stack) then let var value := stack_pop(stack)
var new_env := global_env_push(global_env, tape[ip].arg2, value) 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 ; ip := ip + 1
end end
@ -2044,8 +2183,9 @@ let /* Booleans */
/* TODO: Improve */ continue := false /* TODO: Improve */ continue := false
else if not(is_function(return_to)) else if not(is_function(return_to))
then run_error(concat("Cannot return to non-function value ", value_to_string(return_to))) then run_error(concat("Cannot return to non-function value ", value_to_string(return_to)))
else ( ip := return_to.val_i else ( fun_name := return_to.val_s
; env := return_to.val_car) ; ip := return_to.val_i
; env := return_to.val_car)
end end
else if tape[ip].opcode = OPCODE_POP else if tape[ip].opcode = OPCODE_POP
@ -2082,7 +2222,7 @@ let /* Booleans */
then let var head := stack_pop(stack) then let var head := stack_pop(stack)
in if head = nil then run_error("Stack too shallow!") in if head = nil then run_error("Stack too shallow!")
else if not(is_pair(head)) 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) else ( stack_push(stack, head.val_car)
; ip := ip + 1 ) ; ip := ip + 1 )
end end
@ -2091,7 +2231,7 @@ let /* Booleans */
then let var head := stack_pop(stack) then let var head := stack_pop(stack)
in if head = nil then run_error("Stack too shallow!") in if head = nil then run_error("Stack too shallow!")
else if not(is_pair(head)) 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) else ( stack_push(stack, head.val_cdr)
; ip := ip + 1 ) ; ip := ip + 1 )
end end
@ -2145,6 +2285,16 @@ let /* Booleans */
; ip := ip + 1 ; ip := ip + 1
end 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 else if tape[ip].opcode = OPCODE_TYPEOF
then let var value := stack_pop(stack) then let var value := stack_pop(stack)
in expect_value(value, "") in expect_value(value, "")
@ -2167,6 +2317,24 @@ let /* Booleans */
; ip := ip + 1 ; ip := ip + 1
end 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 " else run_error(concat("Encountered unknown opcode "
, int_to_string(tape[ip].opcode))) , int_to_string(tape[ip].opcode)))
@ -2174,11 +2342,22 @@ let /* Booleans */
let let
in print("Tiger-scheme runtime error\n ") in print("Tiger-scheme runtime error\n ")
; print(errmsg) ; 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(int_to_string(ip))
; print(": ") ; print(": ")
; print(insn_to_string(tape[ip])) ; print(insn_to_string(tape[ip]))
; print("\n") ; print("\n")
/* Tape information? */
; if tape[ip] <> nil then ; if tape[ip] <> nil then
let var repr_pos_l := pos_to_string(tape[ip].pos_l) let var repr_pos_l := pos_to_string(tape[ip].pos_l)
var repr_pos_r := pos_to_string(tape[ip].pos_r) var repr_pos_r := pos_to_string(tape[ip].pos_r)