From b278001eeb56e2cdad05a968579dbe1c629ac787 Mon Sep 17 00:00:00 2001 From: Jon Michael Aanes Date: Tue, 18 Dec 2018 14:51:08 +0100 Subject: [PATCH] Implemented basic macros --- example.scm | 18 ++ tigerscheme.tig | 478 ++++++++++++++++++++++++++++-------------------- 2 files changed, 297 insertions(+), 199 deletions(-) diff --git a/example.scm b/example.scm index a1c0804..080eace 100644 --- a/example.scm +++ b/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) diff --git a/tigerscheme.tig b/tigerscheme.tig index 0a7dff1..288089d 100644 --- a/tigerscheme.tig +++ b/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,19 +769,17 @@ 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) - , ENV_STD ) + , ENV_STD ) function tape_pos (): int = insn_list_length(std_insns) @@ -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(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") - ; 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 - 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")