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
|
; 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
287
tigerscheme.tig
|
|
@ -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)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user