Added testing functionality and lots of debugging systems, which also resulted in a bunch of bug-fixes.
This commit is contained in:
parent
f9e1e18961
commit
7231ae67c0
78
example.scm
78
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)
|
||||
|
|
|
|||
265
tigerscheme.tig
265
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 "<TIGER NIL>"
|
||||
|
|
@ -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: "
|
||||
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 ()
|
||||
|
||||
|
|
@ -962,6 +1021,11 @@ let /* Booleans */
|
|||
; stdfun("syntax->datum")
|
||||
; stdfun("datum->syntax")
|
||||
; 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 */
|
||||
|
|
@ -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
|
||||
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)
|
||||
; concat_lists(insns, compile_rec(head.val_car, false))
|
||||
; head := head.val_cdr )
|
||||
; 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,7 +1960,9 @@ let /* Booleans */
|
|||
else
|
||||
let var info := vm_insn_info[insn.opcode]
|
||||
in concat5( info.mnemonic
|
||||
, if info.uses_arg1
|
||||
, 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
|
||||
|
|
@ -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")
|
||||
; "")
|
||||
|
|
@ -1997,6 +2112,7 @@ let /* Booleans */
|
|||
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,7 +2183,8 @@ 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
|
||||
else ( fun_name := return_to.val_s
|
||||
; ip := return_to.val_i
|
||||
; env := return_to.val_car)
|
||||
end
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user