Jmaa/tiger-scheme
1
0
Fork 0
Code

Implemented basic macros

Browse Source
This commit is contained in:
Jon Michael Aanes 2018-12-18 14:51:08 +01:00
parent 344746cc64
commit b278001eeb
2 changed files with 297 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
example.scm
View File

@ -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)

478
tigerscheme.tig
View File

@ -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")