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 *")
|
||||
(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
|
||||
|
||||
|
||||
|
||||
|
||||
(define-syntax and
|
||||
(syntax-rules ()
|
||||
((and) #t)
|
||||
|
|
|
|||
460
tigerscheme.tig
460
tigerscheme.tig
|
|
@ -10,6 +10,9 @@ let /* Booleans */
|
|||
var IS_NIL_TRUTHY : bool := false
|
||||
var HAS_NIL_SYMBOL : bool := false
|
||||
var DEBUG_PRINT_STACK : bool := false
|
||||
var DEBUG_PRINT_TAPE : bool := false
|
||||
|
||||
var TRIGGERED_EXIT : bool := false
|
||||
|
||||
/* Basic utility */
|
||||
|
||||
|
|
@ -66,7 +69,9 @@ let /* Booleans */
|
|||
function safe_substring (str: string, i_start: int, i_end: int): string =
|
||||
( i_start := max(0, i_start)
|
||||
; 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 */
|
||||
|
||||
|
|
@ -74,16 +79,23 @@ let /* Booleans */
|
|||
function new_pos (line_num: int, at_char: int): pos =
|
||||
pos { at_char = at_char, line_num = 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 =
|
||||
new_pos( line_num(pos)
|
||||
, 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 =
|
||||
if pos = pos_unknown
|
||||
then "unknown position"
|
||||
else if pos = pos_preamble
|
||||
then "preamble"
|
||||
else
|
||||
concat("line ", int_to_string(line_num(pos)))
|
||||
|
||||
|
|
@ -531,32 +543,6 @@ let /* Booleans */
|
|||
in parse_rec()
|
||||
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 ****/
|
||||
|
||||
type vm_insn = { opcode: int
|
||||
|
|
@ -605,6 +591,7 @@ let /* Booleans */
|
|||
var OPCODE_SETENV := 24
|
||||
var OPCODE_NUMEQ := 25
|
||||
var OPCODE_TYPEOF := 26
|
||||
var OPCODE_EXIT := 27
|
||||
|
||||
var vm_insn_num_opcodes := 0
|
||||
var vm_insn_info :=
|
||||
|
|
@ -661,6 +648,7 @@ let /* Booleans */
|
|||
|
||||
; code(OPCODE_COMPILE,"COMPILE", 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
|
||||
do if a[i] <> nil & a[i-1] = nil
|
||||
|
|
@ -707,6 +695,12 @@ let /* Booleans */
|
|||
; index := index + 1
|
||||
; head := head.next )
|
||||
; 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
|
||||
end
|
||||
|
||||
|
|
@ -775,15 +769,13 @@ let /* Booleans */
|
|||
var ENV_STD : vm_env := ENV_EMPTY
|
||||
var STD_LIB_ID_FUNCTION: scheme_value := nil
|
||||
|
||||
var STD_LIB := let var first_insn := noop_insn(pos_unknown, pos_unknown)
|
||||
|
||||
var std_insns := single_insn(first_insn)
|
||||
var STD_LIB := let var std_insns := vm_insn_list { first = nil, last = nil }
|
||||
|
||||
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) =
|
||||
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) =
|
||||
ENV_STD := pair_val( pair_val( sym_val(name), value)
|
||||
|
|
@ -802,6 +794,8 @@ let /* Booleans */
|
|||
then stdval("nil", nil_val())
|
||||
|
||||
/* Identity function */
|
||||
; stdfun("syntax->datum")
|
||||
; stdfun("datum->syntax")
|
||||
; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
|
|
@ -949,12 +943,119 @@ let /* Booleans */
|
|||
; app(OPCODE_SETENV, 0, "")
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
; first_insn.arg1 := insn_list_length(std_insns)
|
||||
; stdfun("exit")
|
||||
; app(OPCODE_EXIT, true, "")
|
||||
|
||||
; std_insns
|
||||
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 var tail := head
|
||||
in while tail <> nil & tail.next <> nil
|
||||
|
|
@ -1164,17 +1265,8 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
function compile_define_syntax (ast: sexp_ast): vm_insn_list =
|
||||
let var symbol := ast.val_cdr.val_car.val_s
|
||||
var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false)
|
||||
|
||||
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
|
||||
( compile_error("Please do not compile define-syntax", ast)
|
||||
; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)))
|
||||
|
||||
function compile_define (ast: sexp_ast): vm_insn_list =
|
||||
|
||||
|
|
@ -1349,6 +1441,24 @@ let /* Booleans */
|
|||
; insns
|
||||
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 */
|
||||
else let var num_args := 0
|
||||
var args_insns := vm_insn_list { first = nil, last = nil }
|
||||
|
|
@ -1389,7 +1499,9 @@ let /* Booleans */
|
|||
; print("\n")
|
||||
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
|
||||
|
||||
function optimize_vm_tape (real_tape: vm_tape): vm_tape =
|
||||
|
|
@ -1417,7 +1529,7 @@ let /* Booleans */
|
|||
|
||||
function insn_to_string (insn: vm_insn): string =
|
||||
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
|
||||
| vm_insn_num_opcodes <= insn.opcode
|
||||
|
|
@ -1445,12 +1557,13 @@ let /* Booleans */
|
|||
, "")
|
||||
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"
|
||||
var index := 0
|
||||
var index := first
|
||||
var real_tape := tape.tape
|
||||
var length := tape.filled
|
||||
var ln_width := size(int_to_string(tape.length))
|
||||
var last := if last < 0 then tape.filled + last
|
||||
else last
|
||||
var ln_width := size(int_to_string(last))
|
||||
|
||||
function repeat (str: string, i: int): string =
|
||||
if i <= 0
|
||||
|
|
@ -1462,7 +1575,7 @@ let /* Booleans */
|
|||
in concat(repeat(" ", ln_width-size(num_str)), num_str)
|
||||
end
|
||||
|
||||
in while index < length
|
||||
in while index <= last
|
||||
do ( str := concat5( str
|
||||
, line_number(index)
|
||||
, " "
|
||||
|
|
@ -1473,101 +1586,8 @@ let /* Booleans */
|
|||
; str
|
||||
end
|
||||
|
||||
/**** Virtual Machine ****/
|
||||
|
||||
/* 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 */
|
||||
function tape_to_string (tape: vm_tape): string =
|
||||
tape_to_string_range(tape, 0, tape.filled)
|
||||
|
||||
/* Virtual Machine execution */
|
||||
|
||||
|
|
@ -1581,6 +1601,9 @@ let /* Booleans */
|
|||
let var tape_info := tape
|
||||
var tape := tape.tape
|
||||
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) =
|
||||
if value.typ <> typ
|
||||
|
|
@ -1709,7 +1732,8 @@ let /* Booleans */
|
|||
else if tape[ip].opcode = OPCODE_RET
|
||||
then let var return_to := stack_destroy_elem(stack, tape[ip].arg1)
|
||||
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))
|
||||
then run_error(concat("Cannot return to non-function value ", value_to_string(return_to)))
|
||||
else ( ip := return_to.val_i
|
||||
|
|
@ -1795,7 +1819,8 @@ let /* Booleans */
|
|||
in if ast = nil
|
||||
then run_error("Stack too shallow!")
|
||||
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))
|
||||
; ip := ip + 1
|
||||
end
|
||||
|
|
@ -1823,32 +1848,44 @@ let /* Booleans */
|
|||
; ip := ip + 1 )
|
||||
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 "
|
||||
, int_to_string(tape[ip].opcode)))
|
||||
|
||||
function run_error(errmsg: string) =
|
||||
let var repr_pos_l := pos_to_string(tape[ip].pos_l)
|
||||
var repr_pos_r := pos_to_string(tape[ip].pos_r)
|
||||
function run_error (errmsg: string) =
|
||||
let
|
||||
in print("Tiger-scheme runtime error\n ")
|
||||
; print(errmsg)
|
||||
; print("\n At instruction ")
|
||||
; print(int_to_string(ip))
|
||||
; print(": ")
|
||||
; print(insn_to_string(tape[ip]))
|
||||
; print("\n Scheme: ")
|
||||
; print("\n")
|
||||
; 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 Source: ")
|
||||
; 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
|
||||
|
||||
in while continue
|
||||
in while continue & ip < tape_info.filled & not(TRIGGERED_EXIT)
|
||||
do ( vm_update()
|
||||
; if DEBUG_PRINT_STACK
|
||||
then ( print("[")
|
||||
|
|
@ -1856,49 +1893,92 @@ let /* Booleans */
|
|||
; print("]: ")
|
||||
; print(stack_to_string(stack))
|
||||
; print("\n") ))
|
||||
|
||||
; if DEBUG_PRINT_STACK
|
||||
then print("Exit VM instance\n")
|
||||
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 ignore := ( tape_append(tape, STD_LIB)
|
||||
; tape_append(tape, compile_to_vm(sexp_ast))
|
||||
; "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 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_to_string(stack))
|
||||
; print("\n")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user