Implemented basic macros
This commit is contained in:
parent
344746cc64
commit
b278001eeb
18
example.scm
18
example.scm
|
@ -143,8 +143,26 @@
|
||||||
(display "* Testing Macro system *")
|
(display "* Testing Macro system *")
|
||||||
(newline)
|
(newline)
|
||||||
|
|
||||||
|
; Test define-syntax
|
||||||
|
|
||||||
|
(display "Test define-syntax:\n Expect: 4 ()\n Gotten: ")
|
||||||
|
|
||||||
|
(define-syntax const
|
||||||
|
(lambda (so)
|
||||||
|
(cons 'lambda (cons '() (cdr so)))))
|
||||||
|
|
||||||
|
(define x (const 4))
|
||||||
|
(display (x))
|
||||||
|
(display " ")
|
||||||
|
(define x (const '()))
|
||||||
|
(display (x))
|
||||||
|
(display "\n")
|
||||||
|
|
||||||
; Test syntax-rules
|
; Test syntax-rules
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define-syntax and
|
(define-syntax and
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((and) #t)
|
((and) #t)
|
||||||
|
|
478
tigerscheme.tig
478
tigerscheme.tig
|
@ -10,6 +10,9 @@ let /* Booleans */
|
||||||
var IS_NIL_TRUTHY : bool := false
|
var IS_NIL_TRUTHY : bool := false
|
||||||
var HAS_NIL_SYMBOL : bool := false
|
var HAS_NIL_SYMBOL : bool := false
|
||||||
var DEBUG_PRINT_STACK : bool := false
|
var DEBUG_PRINT_STACK : bool := false
|
||||||
|
var DEBUG_PRINT_TAPE : bool := false
|
||||||
|
|
||||||
|
var TRIGGERED_EXIT : bool := false
|
||||||
|
|
||||||
/* Basic utility */
|
/* Basic utility */
|
||||||
|
|
||||||
|
@ -66,7 +69,9 @@ let /* Booleans */
|
||||||
function safe_substring (str: string, i_start: int, i_end: int): string =
|
function safe_substring (str: string, i_start: int, i_end: int): string =
|
||||||
( i_start := max(0, i_start)
|
( i_start := max(0, i_start)
|
||||||
; i_end := min(size(str) - 1, i_end)
|
; i_end := min(size(str) - 1, i_end)
|
||||||
; substring(str, i_start, i_end - i_start + 1) )
|
; if i_start > i_end
|
||||||
|
then ""
|
||||||
|
else substring(str, i_start, i_end - i_start + 1) )
|
||||||
|
|
||||||
/* Source positioning */
|
/* Source positioning */
|
||||||
|
|
||||||
|
@ -74,16 +79,23 @@ let /* Booleans */
|
||||||
function new_pos (line_num: int, at_char: int): pos =
|
function new_pos (line_num: int, at_char: int): pos =
|
||||||
pos { at_char = at_char, line_num = line_num }
|
pos { at_char = at_char, line_num = line_num }
|
||||||
function line_num (pos: pos): int = pos.line_num
|
function line_num (pos: pos): int = pos.line_num
|
||||||
function at_char (pos: pos): int = pos.at_char
|
function at_char (pos: pos): int =
|
||||||
|
if pos <> nil
|
||||||
|
then pos.at_char
|
||||||
|
else -1
|
||||||
|
|
||||||
function pos_delta_char (pos: pos, delta: int): pos =
|
function pos_delta_char (pos: pos, delta: int): pos =
|
||||||
new_pos( line_num(pos)
|
new_pos( line_num(pos)
|
||||||
, at_char (pos) + delta)
|
, at_char (pos) + delta)
|
||||||
|
|
||||||
var pos_unknown: pos := nil
|
var pos_unknown : pos := new_pos(-1, -1)
|
||||||
|
var pos_preamble: pos := new_pos(-2, -2)
|
||||||
|
|
||||||
function pos_to_string (pos: pos): string =
|
function pos_to_string (pos: pos): string =
|
||||||
if pos = pos_unknown
|
if pos = pos_unknown
|
||||||
then "unknown position"
|
then "unknown position"
|
||||||
|
else if pos = pos_preamble
|
||||||
|
then "preamble"
|
||||||
else
|
else
|
||||||
concat("line ", int_to_string(line_num(pos)))
|
concat("line ", int_to_string(line_num(pos)))
|
||||||
|
|
||||||
|
@ -531,32 +543,6 @@ let /* Booleans */
|
||||||
in parse_rec()
|
in parse_rec()
|
||||||
end
|
end
|
||||||
|
|
||||||
function sexp_ast_to_string (ast: sexp_ast): string =
|
|
||||||
let function tostr_rec (ast: sexp_ast, nil_implicit: int): string =
|
|
||||||
if ast = nil then "SOMEBODY FUCKED UP"
|
|
||||||
else if ast.typ = type_nil & nil_implicit
|
|
||||||
then ""
|
|
||||||
else if ast.typ = type_pair & ast.val_car.typ <> type_pair
|
|
||||||
then let var s_left := tostr_rec(ast.val_car, 0)
|
|
||||||
var s_right := tostr_rec(ast.val_cdr, 1)
|
|
||||||
in concat(s_left, if s_right <> ""
|
|
||||||
then concat(" ", s_right)
|
|
||||||
else "")
|
|
||||||
end
|
|
||||||
|
|
||||||
else if ast.typ = type_pair
|
|
||||||
then let var s_left := tostr_rec(ast.val_car, 0)
|
|
||||||
var s_right := tostr_rec(ast.val_cdr, 1)
|
|
||||||
in concat("(",
|
|
||||||
concat(s_left,
|
|
||||||
concat(")", if s_right <> ""
|
|
||||||
then concat(" ", s_right)
|
|
||||||
else "")))
|
|
||||||
end
|
|
||||||
else ast.val_s
|
|
||||||
in concat("(", concat(tostr_rec(ast, 0), ")"))
|
|
||||||
end
|
|
||||||
|
|
||||||
/**** Instructions ****/
|
/**** Instructions ****/
|
||||||
|
|
||||||
type vm_insn = { opcode: int
|
type vm_insn = { opcode: int
|
||||||
|
@ -605,6 +591,7 @@ let /* Booleans */
|
||||||
var OPCODE_SETENV := 24
|
var OPCODE_SETENV := 24
|
||||||
var OPCODE_NUMEQ := 25
|
var OPCODE_NUMEQ := 25
|
||||||
var OPCODE_TYPEOF := 26
|
var OPCODE_TYPEOF := 26
|
||||||
|
var OPCODE_EXIT := 27
|
||||||
|
|
||||||
var vm_insn_num_opcodes := 0
|
var vm_insn_num_opcodes := 0
|
||||||
var vm_insn_info :=
|
var vm_insn_info :=
|
||||||
|
@ -661,6 +648,7 @@ 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_EXIT, "EXIT", 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
|
||||||
|
@ -707,6 +695,12 @@ let /* Booleans */
|
||||||
; index := index + 1
|
; index := index + 1
|
||||||
; head := head.next )
|
; head := head.next )
|
||||||
; tape.filled := index
|
; tape.filled := index
|
||||||
|
; if DEBUG_PRINT_TAPE
|
||||||
|
then ( print("Appended new to tape: ")
|
||||||
|
; print(int_to_string(index_start))
|
||||||
|
; print(" to ")
|
||||||
|
; print(int_to_string(index))
|
||||||
|
; print("\n") )
|
||||||
; index_start
|
; index_start
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -775,19 +769,17 @@ let /* Booleans */
|
||||||
var ENV_STD : vm_env := ENV_EMPTY
|
var ENV_STD : vm_env := ENV_EMPTY
|
||||||
var STD_LIB_ID_FUNCTION: scheme_value := nil
|
var STD_LIB_ID_FUNCTION: scheme_value := nil
|
||||||
|
|
||||||
var STD_LIB := let var first_insn := noop_insn(pos_unknown, pos_unknown)
|
var STD_LIB := let var std_insns := vm_insn_list { first = nil, last = nil }
|
||||||
|
|
||||||
var std_insns := single_insn(first_insn)
|
|
||||||
|
|
||||||
function app (opcode: int, arg1: int, arg2: string) =
|
function app (opcode: int, arg1: int, arg2: string) =
|
||||||
app_insn(std_insns, opcode, arg1, arg2, pos_unknown, pos_unknown)
|
app_insn(std_insns, opcode, arg1, arg2, pos_preamble, pos_preamble)
|
||||||
|
|
||||||
function app2 (opcode: int, arg3: scheme_value) =
|
function app2 (opcode: int, arg3: scheme_value) =
|
||||||
app_insn2(std_insns, opcode, arg3, pos_unknown, pos_unknown)
|
app_insn2(std_insns, opcode, arg3, pos_preamble, pos_preamble)
|
||||||
|
|
||||||
function stdval (name: string, value: scheme_value) =
|
function stdval (name: string, value: scheme_value) =
|
||||||
ENV_STD := pair_val( pair_val( sym_val(name), value)
|
ENV_STD := pair_val( pair_val( sym_val(name), value)
|
||||||
, ENV_STD )
|
, ENV_STD )
|
||||||
|
|
||||||
function tape_pos (): int =
|
function tape_pos (): int =
|
||||||
insn_list_length(std_insns)
|
insn_list_length(std_insns)
|
||||||
|
@ -802,6 +794,8 @@ let /* Booleans */
|
||||||
then stdval("nil", nil_val())
|
then stdval("nil", nil_val())
|
||||||
|
|
||||||
/* Identity function */
|
/* Identity function */
|
||||||
|
; stdfun("syntax->datum")
|
||||||
|
; stdfun("datum->syntax")
|
||||||
; 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, "")
|
||||||
|
|
||||||
|
@ -949,12 +943,119 @@ let /* Booleans */
|
||||||
; app(OPCODE_SETENV, 0, "")
|
; app(OPCODE_SETENV, 0, "")
|
||||||
; app(OPCODE_RET, 1, "")
|
; app(OPCODE_RET, 1, "")
|
||||||
|
|
||||||
; first_insn.arg1 := insn_list_length(std_insns)
|
; stdfun("exit")
|
||||||
|
; app(OPCODE_EXIT, true, "")
|
||||||
|
|
||||||
; std_insns
|
; std_insns
|
||||||
end
|
end
|
||||||
|
|
||||||
|
/**** Virtual Machine ****/
|
||||||
|
|
||||||
function compile_to_vm (ast: sexp_ast): vm_insn_list =
|
/* Stack */
|
||||||
|
|
||||||
|
type vm_stack_elem = scheme_value
|
||||||
|
type vm_stack_list = { value: vm_stack_elem, below: vm_stack_list }
|
||||||
|
type vm_stack = { list: vm_stack_list }
|
||||||
|
function stack_new(): vm_stack = vm_stack { list = nil }
|
||||||
|
function stack_peak(stack: vm_stack): vm_stack_elem =
|
||||||
|
if stack = nil
|
||||||
|
then (print("Error in stack_peak: Not given stack!\n"); nil)
|
||||||
|
else if stack.list = nil
|
||||||
|
then nil
|
||||||
|
else stack.list.value
|
||||||
|
function stack_pop(stack: vm_stack): vm_stack_elem =
|
||||||
|
if stack = nil
|
||||||
|
then (print("Error in stack_pop: Not given stack!\n"); nil)
|
||||||
|
else if stack.list = nil
|
||||||
|
then nil
|
||||||
|
else
|
||||||
|
let var head := stack.list.value
|
||||||
|
in stack.list := stack.list.below
|
||||||
|
; head
|
||||||
|
end
|
||||||
|
function stack_seek_elem(stack: vm_stack, index: int): vm_stack_list =
|
||||||
|
let var head := stack.list
|
||||||
|
in for index := 1 to index
|
||||||
|
do if head <> nil
|
||||||
|
then head := head.below
|
||||||
|
; head
|
||||||
|
end
|
||||||
|
function stack_destroy_elem(stack: vm_stack, index: int): vm_stack_elem =
|
||||||
|
if index <= 0
|
||||||
|
then let var value := stack.list.value
|
||||||
|
in stack.list := stack.list.below
|
||||||
|
; value
|
||||||
|
end
|
||||||
|
else let var before := stack_seek_elem(stack, index - 1)
|
||||||
|
in if before = nil | before.below = nil
|
||||||
|
then nil
|
||||||
|
else let var value := before.below.value
|
||||||
|
in before.below := before.below.below
|
||||||
|
; value
|
||||||
|
end
|
||||||
|
end
|
||||||
|
function stack_push(stack: vm_stack, elem: vm_stack_elem) =
|
||||||
|
stack.list := vm_stack_list { value = elem
|
||||||
|
, below = stack.list }
|
||||||
|
|
||||||
|
function stack_to_string (stack: vm_stack): string =
|
||||||
|
let function iter (list: vm_stack_list): string =
|
||||||
|
if list = nil then ""
|
||||||
|
else concat(value_to_string(list.value), if list.below <> nil
|
||||||
|
then concat(", ", iter(list.below))
|
||||||
|
else "")
|
||||||
|
|
||||||
|
in concat("[", concat(iter(stack.list), "]"))
|
||||||
|
end
|
||||||
|
|
||||||
|
/* Environments */
|
||||||
|
|
||||||
|
var GLOBAL_ENV_SENTINEL := ""
|
||||||
|
|
||||||
|
function env_new(base_env: scheme_value): vm_env =
|
||||||
|
pair_val( pair_val( sym_val(GLOBAL_ENV_SENTINEL)
|
||||||
|
, bool_val(0))
|
||||||
|
, base_env )
|
||||||
|
|
||||||
|
function env_seek_elem(env: vm_env, key: string): vm_env =
|
||||||
|
let var head := env
|
||||||
|
in while head <> nil
|
||||||
|
& head.typ <> type_nil
|
||||||
|
& head.val_car.val_car.val_s <> key
|
||||||
|
|
||||||
|
do head := head.val_cdr
|
||||||
|
; if head <> nil
|
||||||
|
& head.typ <> type_nil
|
||||||
|
then head
|
||||||
|
else nil
|
||||||
|
end
|
||||||
|
|
||||||
|
function env_push(env: vm_env, key: string, value: vm_env_elem): vm_env =
|
||||||
|
pair_val( pair_val( sym_val(key)
|
||||||
|
, value)
|
||||||
|
, env )
|
||||||
|
|
||||||
|
function global_env_push (env: vm_env, key: string, value: vm_env_elem): vm_env =
|
||||||
|
let
|
||||||
|
in if env.val_car.val_s <> GLOBAL_ENV_SENTINEL
|
||||||
|
then print("Attempting to perform global push to non-global environment")
|
||||||
|
else env.val_cdr := pair_val( pair_val( sym_val(key)
|
||||||
|
, value)
|
||||||
|
, env.val_cdr )
|
||||||
|
; env
|
||||||
|
end
|
||||||
|
|
||||||
|
|
||||||
|
function env_to_string (env: vm_env): string =
|
||||||
|
value_to_string(env)
|
||||||
|
|
||||||
|
|
||||||
|
/**** Compilation ****/
|
||||||
|
|
||||||
|
function compile_to_vm ( ast: sexp_ast
|
||||||
|
, env_macro: scheme_environment
|
||||||
|
, macro_tape: vm_tape
|
||||||
|
, env_global: scheme_environment): vm_insn_list =
|
||||||
let function list (head: vm_insn_list_link): vm_insn_list =
|
let function list (head: vm_insn_list_link): vm_insn_list =
|
||||||
let var tail := head
|
let var tail := head
|
||||||
in while tail <> nil & tail.next <> nil
|
in while tail <> nil & tail.next <> nil
|
||||||
|
@ -1164,17 +1265,8 @@ let /* Booleans */
|
||||||
end
|
end
|
||||||
|
|
||||||
function compile_define_syntax (ast: sexp_ast): vm_insn_list =
|
function compile_define_syntax (ast: sexp_ast): vm_insn_list =
|
||||||
let var symbol := ast.val_cdr.val_car.val_s
|
( compile_error("Please do not compile define-syntax", ast)
|
||||||
var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false)
|
; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)))
|
||||||
|
|
||||||
var pos_l := ast.pos_l
|
|
||||||
var pos_r := ast.pos_r
|
|
||||||
|
|
||||||
/* TODO: Improve below */
|
|
||||||
in app_insn(insns_body, OPCODE_POP, 0, "", pos_l, pos_r)
|
|
||||||
; app_insn2(insns_body, OPCODE_PUSH, VALUE_UNSPECIFIED, pos_l, pos_r)
|
|
||||||
; insns_body
|
|
||||||
end
|
|
||||||
|
|
||||||
function compile_define (ast: sexp_ast): vm_insn_list =
|
function compile_define (ast: sexp_ast): vm_insn_list =
|
||||||
|
|
||||||
|
@ -1349,6 +1441,24 @@ let /* Booleans */
|
||||||
; insns
|
; insns
|
||||||
end
|
end
|
||||||
|
|
||||||
|
/* Macro applications */
|
||||||
|
else if ast.val_car <> nil
|
||||||
|
& ast.val_car.typ = type_symbol
|
||||||
|
& env_seek_elem(env_macro, ast.val_car.val_s) <> nil
|
||||||
|
then let var stack := stack_new()
|
||||||
|
var env_elem := env_seek_elem(env_macro, ast.val_car.val_s)
|
||||||
|
var fun := env_elem.val_car.val_cdr
|
||||||
|
in stack_push(stack, ast)
|
||||||
|
/*; print("Running ")
|
||||||
|
; print(value_to_string(fun))
|
||||||
|
; print(" as macro\n")*/
|
||||||
|
; if fun <> nil & fun.typ <> type_closure
|
||||||
|
then compile_error("Attempting to use non-function as macro function.", ast)
|
||||||
|
; 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)
|
||||||
|
end
|
||||||
|
|
||||||
/* Call expressions */
|
/* Call expressions */
|
||||||
else let var num_args := 0
|
else let var num_args := 0
|
||||||
var args_insns := vm_insn_list { first = nil, last = nil }
|
var args_insns := vm_insn_list { first = nil, last = nil }
|
||||||
|
@ -1389,7 +1499,9 @@ let /* Booleans */
|
||||||
; print("\n")
|
; print("\n")
|
||||||
end
|
end
|
||||||
|
|
||||||
in compile_rec(ast, true)
|
var base_insns := compile_rec(ast, false)
|
||||||
|
in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
|
||||||
|
; base_insns
|
||||||
end
|
end
|
||||||
|
|
||||||
function optimize_vm_tape (real_tape: vm_tape): vm_tape =
|
function optimize_vm_tape (real_tape: vm_tape): vm_tape =
|
||||||
|
@ -1417,7 +1529,7 @@ let /* Booleans */
|
||||||
|
|
||||||
function insn_to_string (insn: vm_insn): string =
|
function insn_to_string (insn: vm_insn): string =
|
||||||
if insn = nil
|
if insn = nil
|
||||||
then ( print("Encountered missing opcode in insn_to_string!\n")
|
then ( print("Encountered missing instruction in insn_to_string!\n")
|
||||||
; "!!!" )
|
; "!!!" )
|
||||||
else if insn.opcode < 0
|
else if insn.opcode < 0
|
||||||
| vm_insn_num_opcodes <= insn.opcode
|
| vm_insn_num_opcodes <= insn.opcode
|
||||||
|
@ -1445,12 +1557,13 @@ let /* Booleans */
|
||||||
, "")
|
, "")
|
||||||
end
|
end
|
||||||
|
|
||||||
function tape_to_string (tape: vm_tape): string =
|
function tape_to_string_range (tape: vm_tape, first:int, last:int): string =
|
||||||
let var str := "TAPE\n"
|
let var str := "TAPE\n"
|
||||||
var index := 0
|
var index := first
|
||||||
var real_tape := tape.tape
|
var real_tape := tape.tape
|
||||||
var length := tape.filled
|
var last := if last < 0 then tape.filled + last
|
||||||
var ln_width := size(int_to_string(tape.length))
|
else last
|
||||||
|
var ln_width := size(int_to_string(last))
|
||||||
|
|
||||||
function repeat (str: string, i: int): string =
|
function repeat (str: string, i: int): string =
|
||||||
if i <= 0
|
if i <= 0
|
||||||
|
@ -1462,7 +1575,7 @@ let /* Booleans */
|
||||||
in concat(repeat(" ", ln_width-size(num_str)), num_str)
|
in concat(repeat(" ", ln_width-size(num_str)), num_str)
|
||||||
end
|
end
|
||||||
|
|
||||||
in while index < length
|
in while index <= last
|
||||||
do ( str := concat5( str
|
do ( str := concat5( str
|
||||||
, line_number(index)
|
, line_number(index)
|
||||||
, " "
|
, " "
|
||||||
|
@ -1473,101 +1586,8 @@ let /* Booleans */
|
||||||
; str
|
; str
|
||||||
end
|
end
|
||||||
|
|
||||||
/**** Virtual Machine ****/
|
function tape_to_string (tape: vm_tape): string =
|
||||||
|
tape_to_string_range(tape, 0, tape.filled)
|
||||||
/* Stack */
|
|
||||||
|
|
||||||
type vm_stack_elem = scheme_value
|
|
||||||
type vm_stack_list = { value: vm_stack_elem, below: vm_stack_list }
|
|
||||||
type vm_stack = { list: vm_stack_list }
|
|
||||||
function stack_new(): vm_stack = vm_stack { list = nil }
|
|
||||||
function stack_pop(stack: vm_stack): vm_stack_elem =
|
|
||||||
if stack = nil
|
|
||||||
then (print("Error in stack_pop: Not given stack!\n"); nil)
|
|
||||||
else if stack.list = nil
|
|
||||||
then nil
|
|
||||||
else
|
|
||||||
let var head := stack.list.value
|
|
||||||
in stack.list := stack.list.below
|
|
||||||
; head
|
|
||||||
end
|
|
||||||
function stack_seek_elem(stack: vm_stack, index: int): vm_stack_list =
|
|
||||||
let var head := stack.list
|
|
||||||
in for index := 1 to index
|
|
||||||
do if head <> nil
|
|
||||||
then head := head.below
|
|
||||||
; head
|
|
||||||
end
|
|
||||||
function stack_destroy_elem(stack: vm_stack, index: int): vm_stack_elem =
|
|
||||||
if index <= 0
|
|
||||||
then let var value := stack.list.value
|
|
||||||
in stack.list := stack.list.below
|
|
||||||
; value
|
|
||||||
end
|
|
||||||
else let var before := stack_seek_elem(stack, index - 1)
|
|
||||||
in if before = nil | before.below = nil
|
|
||||||
then nil
|
|
||||||
else let var value := before.below.value
|
|
||||||
in before.below := before.below.below
|
|
||||||
; value
|
|
||||||
end
|
|
||||||
end
|
|
||||||
function stack_push(stack: vm_stack, elem: vm_stack_elem) =
|
|
||||||
stack.list := vm_stack_list { value = elem
|
|
||||||
, below = stack.list }
|
|
||||||
|
|
||||||
function stack_to_string (stack: vm_stack): string =
|
|
||||||
let function iter (list: vm_stack_list): string =
|
|
||||||
if list = nil then ""
|
|
||||||
else concat(value_to_string(list.value), if list.below <> nil
|
|
||||||
then concat(", ", iter(list.below))
|
|
||||||
else "")
|
|
||||||
|
|
||||||
in concat("[", concat(iter(stack.list), "]"))
|
|
||||||
end
|
|
||||||
|
|
||||||
/* Environments */
|
|
||||||
|
|
||||||
var GLOBAL_ENV_SENTINEL := ""
|
|
||||||
|
|
||||||
function env_new(): vm_env =
|
|
||||||
pair_val( pair_val( sym_val(GLOBAL_ENV_SENTINEL)
|
|
||||||
, bool_val(0))
|
|
||||||
, ENV_STD )
|
|
||||||
|
|
||||||
function env_seek_elem(env: vm_env, key: string): vm_env =
|
|
||||||
let var head := env
|
|
||||||
in while head <> nil
|
|
||||||
& head.typ <> type_nil
|
|
||||||
& head.val_car.val_car.val_s <> key
|
|
||||||
|
|
||||||
do head := head.val_cdr
|
|
||||||
; if head <> nil
|
|
||||||
& head.typ <> type_nil
|
|
||||||
then head
|
|
||||||
else nil
|
|
||||||
end
|
|
||||||
|
|
||||||
function env_push(env: vm_env, key: string, value: vm_env_elem): vm_env =
|
|
||||||
pair_val( pair_val( sym_val(key)
|
|
||||||
, value)
|
|
||||||
, env )
|
|
||||||
|
|
||||||
function global_env_push (env: vm_env, key: string, value: vm_env_elem): vm_env =
|
|
||||||
let
|
|
||||||
in if env.val_car.val_s <> GLOBAL_ENV_SENTINEL
|
|
||||||
then print("Attempting to perform global push to non-global environment")
|
|
||||||
else env.val_cdr := pair_val( pair_val( sym_val(key)
|
|
||||||
, value)
|
|
||||||
, env.val_cdr )
|
|
||||||
; env
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
function env_to_string (env: vm_env): string =
|
|
||||||
value_to_string(env)
|
|
||||||
|
|
||||||
/* Tape */
|
|
||||||
|
|
||||||
/* Virtual Machine execution */
|
/* Virtual Machine execution */
|
||||||
|
|
||||||
|
@ -1581,6 +1601,9 @@ 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 ignore := ( if DEBUG_PRINT_STACK
|
||||||
|
then print("Entered VM instance\n")
|
||||||
|
; "")
|
||||||
|
|
||||||
function expect_type(value: scheme_value, typ: type_type, name: string) =
|
function expect_type(value: scheme_value, typ: type_type, name: string) =
|
||||||
if value.typ <> typ
|
if value.typ <> typ
|
||||||
|
@ -1709,7 +1732,8 @@ let /* Booleans */
|
||||||
else if tape[ip].opcode = OPCODE_RET
|
else if tape[ip].opcode = OPCODE_RET
|
||||||
then let var return_to := stack_destroy_elem(stack, tape[ip].arg1)
|
then let var return_to := stack_destroy_elem(stack, tape[ip].arg1)
|
||||||
in if return_to = nil
|
in if return_to = nil
|
||||||
then run_error("Stack too shallow!")
|
then /*run_error("Stack too shallow!")*/
|
||||||
|
/* 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 ( ip := return_to.val_i
|
||||||
|
@ -1795,7 +1819,8 @@ let /* Booleans */
|
||||||
in if ast = nil
|
in if ast = nil
|
||||||
then run_error("Stack too shallow!")
|
then run_error("Stack too shallow!")
|
||||||
else
|
else
|
||||||
let var pos_of_fun := tape_append(tape_info, compile_to_vm(ast))
|
let var pos_of_fun :=
|
||||||
|
tape_append(tape_info, compile_to_vm(ast, nil, nil, nil)) /* TODO: env_macro */
|
||||||
in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY))
|
in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY))
|
||||||
; ip := ip + 1
|
; ip := ip + 1
|
||||||
end
|
end
|
||||||
|
@ -1823,32 +1848,44 @@ let /* Booleans */
|
||||||
; ip := ip + 1 )
|
; ip := ip + 1 )
|
||||||
end
|
end
|
||||||
|
|
||||||
|
else if tape[ip].opcode = OPCODE_EXIT
|
||||||
|
then ( if tape[ip].arg1
|
||||||
|
then TRIGGERED_EXIT := true
|
||||||
|
; continue := false )
|
||||||
|
|
||||||
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)))
|
||||||
|
|
||||||
function run_error(errmsg: string) =
|
function run_error (errmsg: string) =
|
||||||
let var repr_pos_l := pos_to_string(tape[ip].pos_l)
|
let
|
||||||
var repr_pos_r := pos_to_string(tape[ip].pos_r)
|
|
||||||
in print("Tiger-scheme runtime error\n ")
|
in print("Tiger-scheme runtime error\n ")
|
||||||
; print(errmsg)
|
; print(errmsg)
|
||||||
; print("\n At instruction ")
|
; print("\n 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 Scheme: ")
|
|
||||||
; print(safe_substring( source
|
|
||||||
, at_char(tape[ip].pos_l)
|
|
||||||
, at_char(tape[ip].pos_r) ))
|
|
||||||
; print("\n Source: ")
|
|
||||||
; print(repr_pos_l)
|
|
||||||
; if repr_pos_l <> repr_pos_r
|
|
||||||
then ( print(" to ")
|
|
||||||
; print(repr_pos_r) )
|
|
||||||
; print("\n")
|
; print("\n")
|
||||||
; continue := false
|
; 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)
|
||||||
|
in ()
|
||||||
|
; print(" Scheme: ")
|
||||||
|
; print(safe_substring( source
|
||||||
|
, at_char(tape[ip].pos_l)
|
||||||
|
, at_char(tape[ip].pos_r) ))
|
||||||
|
; print("\n")
|
||||||
|
; print(" Source: ")
|
||||||
|
; print(repr_pos_l)
|
||||||
|
; if repr_pos_l <> repr_pos_r
|
||||||
|
then ( print(" to ")
|
||||||
|
; print(repr_pos_r) )
|
||||||
|
; print("\n")
|
||||||
|
end
|
||||||
|
; continue := false
|
||||||
|
; TRIGGERED_EXIT := true
|
||||||
end
|
end
|
||||||
|
|
||||||
in while continue
|
in while continue & ip < tape_info.filled & not(TRIGGERED_EXIT)
|
||||||
do ( vm_update()
|
do ( vm_update()
|
||||||
; if DEBUG_PRINT_STACK
|
; if DEBUG_PRINT_STACK
|
||||||
then ( print("[")
|
then ( print("[")
|
||||||
|
@ -1856,49 +1893,92 @@ let /* Booleans */
|
||||||
; print("]: ")
|
; print("]: ")
|
||||||
; print(stack_to_string(stack))
|
; print(stack_to_string(stack))
|
||||||
; print("\n") ))
|
; print("\n") ))
|
||||||
|
|
||||||
|
; if DEBUG_PRINT_STACK
|
||||||
|
then print("Exit VM instance\n")
|
||||||
end
|
end
|
||||||
|
|
||||||
/* Do stuff */
|
/* Ready for running toplevel */
|
||||||
|
|
||||||
var test_text :=
|
|
||||||
/* TODO: Improve top-level parsing */
|
|
||||||
let var text := "(begin "
|
|
||||||
var char := "BAD SHIT HAPPENED"
|
|
||||||
in while char <> ""
|
|
||||||
do ( char := getchar()
|
|
||||||
; text := concat(text, char) )
|
|
||||||
; concat(text, " )")
|
|
||||||
end
|
|
||||||
|
|
||||||
var ignore := ( print("** Parsing **\n")
|
|
||||||
; print("Original : ")
|
|
||||||
; print(test_text)
|
|
||||||
; print("\n")
|
|
||||||
; 1)
|
|
||||||
var sexp_ast := parse_string(test_text)
|
|
||||||
var ignore := ( print("Parsed : ")
|
|
||||||
; print(value_to_string(sexp_ast))
|
|
||||||
; print("\n")
|
|
||||||
; print("** Compilation **\n")
|
|
||||||
; 1)
|
|
||||||
var tape := tape_new(1000)
|
var tape := tape_new(1000)
|
||||||
var ignore := ( tape_append(tape, STD_LIB)
|
var ignore := ( tape_append(tape, STD_LIB)
|
||||||
; tape_append(tape, compile_to_vm(sexp_ast))
|
|
||||||
; "Ignore!" )
|
; "Ignore!" )
|
||||||
|
|
||||||
/*var tape := optimize_vm_tape(tape)
|
|
||||||
var ignore := ( print("Compiled!:\n")
|
|
||||||
; print(tape_to_string(tape))
|
|
||||||
; print("\n")
|
|
||||||
; 1) */
|
|
||||||
|
|
||||||
var stack := stack_new()
|
var stack := stack_new()
|
||||||
var env := env_new()
|
|
||||||
|
|
||||||
in ()
|
/* Perform reading of toplevel */
|
||||||
|
|
||||||
|
function read_matching_parantheses (): string =
|
||||||
|
let var depth := 0
|
||||||
|
var char := "BAD SHIT HAPPENED"
|
||||||
|
var text := ""
|
||||||
|
in while char <> ""
|
||||||
|
do ( char := getchar()
|
||||||
|
; text := concat(text, char)
|
||||||
|
; if char = "("
|
||||||
|
then depth := depth + 1
|
||||||
|
else if char = ")"
|
||||||
|
then ( depth := depth - 1
|
||||||
|
; if depth = 0 then break ))
|
||||||
|
; text
|
||||||
|
end
|
||||||
|
|
||||||
|
var env_global := env_new(ENV_STD)
|
||||||
|
var env_macro := env_new(nil_val())
|
||||||
|
|
||||||
|
in print("Ready for the scheming Tiger?\n")
|
||||||
|
; let var text := "BAD SHIT HAPPENED"
|
||||||
|
var env := env_global
|
||||||
|
|
||||||
|
in while text <> "" & not(TRIGGERED_EXIT)
|
||||||
|
do let var text := read_matching_parantheses()
|
||||||
|
|
||||||
|
var macro_name := "" /* Not macro is "" */
|
||||||
|
|
||||||
|
var sexp := parse_string(text)
|
||||||
|
var sexp_compile :=
|
||||||
|
if sexp.typ = type_pair
|
||||||
|
& sexp.val_car.typ = type_symbol
|
||||||
|
& sexp.val_car.val_s = "define-syntax"
|
||||||
|
then ( macro_name := sexp.val_cdr.val_car.val_s
|
||||||
|
; sexp.val_cdr.val_cdr.val_car )
|
||||||
|
else sexp
|
||||||
|
|
||||||
|
var insns := compile_to_vm(sexp_compile, env_macro, tape, env_global)
|
||||||
|
var start_index := tape_append(tape, insns)
|
||||||
|
in ()
|
||||||
|
/*print("Parsed: ")
|
||||||
|
; print(value_to_string(sexp))
|
||||||
|
; print("\n") */
|
||||||
|
|
||||||
|
; if DEBUG_PRINT_TAPE
|
||||||
|
then ( print("Tape:\n")
|
||||||
|
; print(tape_to_string_range(tape, start_index, -1))
|
||||||
|
; print("\n") )
|
||||||
|
|
||||||
|
; let var stack := stack_new()
|
||||||
|
var value : scheme_value := nil
|
||||||
|
in if 0 <= start_index
|
||||||
|
then vm_run(tape, start_index, stack, env, text, env_global)
|
||||||
|
|
||||||
|
; if macro_name <> ""
|
||||||
|
then ( value := stack_pop(stack)
|
||||||
|
/*; print("New macro \"")
|
||||||
|
; print(macro_name)
|
||||||
|
; print("\": ")
|
||||||
|
; print(value_to_string(value))
|
||||||
|
; print("\n")*/
|
||||||
|
; if value <> nil & value.typ <> type_closure
|
||||||
|
then ( print("Attempting to save non-function as macro!\n")
|
||||||
|
; TRIGGERED_EXIT := true )
|
||||||
|
; global_env_push( env_macro
|
||||||
|
, macro_name
|
||||||
|
, value )
|
||||||
|
; macro_name := "")
|
||||||
|
end
|
||||||
|
end
|
||||||
|
end
|
||||||
|
|
||||||
; print("\n** VM **\n")
|
|
||||||
; vm_run(tape, 0, stack, env, test_text, env)
|
|
||||||
; print("Stack: ")
|
; print("Stack: ")
|
||||||
; print(stack_to_string(stack))
|
; print(stack_to_string(stack))
|
||||||
; print("\n")
|
; print("\n")
|
||||||
|
|
Loading…
Reference in New Issue
Block a user