Improved bytecode output when calling a locally defined lambda.
This commit is contained in:
parent
e1f72a08ba
commit
5b508bf75c
229
tigerscheme.tig
229
tigerscheme.tig
|
|
@ -13,6 +13,8 @@ let /* Booleans */
|
|||
var DEBUG_PRINT_TAPE : bool := false
|
||||
var DEBUG_PRINT_PARSED : bool := false
|
||||
var DEBUG_PRINT_JUMPS : bool := false
|
||||
var DEBUG_PRINT_MACRO : bool := true
|
||||
var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false
|
||||
|
||||
var ALLOW_TAPE_RESIZE : bool := true
|
||||
|
||||
|
|
@ -116,11 +118,14 @@ let /* Booleans */
|
|||
type pos = { at_char: int, line_num: int }
|
||||
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 line_num (pos: pos): int =
|
||||
if pos <> nil
|
||||
then pos.line_num
|
||||
else -3
|
||||
function at_char (pos: pos): int =
|
||||
if pos <> nil
|
||||
then pos.at_char
|
||||
else -1
|
||||
else -3
|
||||
|
||||
function pos_delta_char (pos: pos, delta: int): pos =
|
||||
new_pos( line_num(pos)
|
||||
|
|
@ -128,9 +133,12 @@ let /* Booleans */
|
|||
|
||||
var pos_unknown : pos := new_pos(-1, -1)
|
||||
var pos_preamble: pos := new_pos(-2, -2)
|
||||
var pos_bad : pos := new_pos(-3, -3)
|
||||
|
||||
function pos_to_string (pos: pos): string =
|
||||
if pos = pos_unknown
|
||||
if pos <> nil
|
||||
then "no position"
|
||||
else if pos = pos_unknown
|
||||
then "unknown position"
|
||||
else if pos = pos_preamble
|
||||
then "preamble"
|
||||
|
|
@ -403,6 +411,13 @@ let /* Booleans */
|
|||
& b.typ = type_integer
|
||||
& a.val_i = b.val_i
|
||||
|
||||
function scheme_value_is_proper_list (ls: scheme_value): bool =
|
||||
if ls = nil
|
||||
then false
|
||||
else ls.typ = type_nil
|
||||
| ls.typ = type_pair
|
||||
& scheme_value_is_proper_list(ls.val_cdr)
|
||||
|
||||
/* evq? See for definition:
|
||||
* https://people.csail.mit.edu/jaffer/r5rs/Equivalence-predicates.html
|
||||
* */
|
||||
|
|
@ -594,7 +609,9 @@ let /* Booleans */
|
|||
|
||||
function parse_rec (): sexp_ast =
|
||||
( ignore_ws()
|
||||
; if is_symbol(index)
|
||||
; if index >= size(str)
|
||||
then (parse_error("Reached end of string"); nil)
|
||||
else if is_symbol(index)
|
||||
then let var start_pos := new_pos(line_number, index)
|
||||
in while index < size(str) & is_symbol(index)
|
||||
do index := index + 1
|
||||
|
|
@ -726,7 +743,9 @@ let /* Booleans */
|
|||
; print("\n")
|
||||
end
|
||||
|
||||
in parse_rec()
|
||||
in if size(str) > 0
|
||||
then parse_rec()
|
||||
else (parse_error("Nothing to parse. Given string empty!"); nil)
|
||||
end
|
||||
|
||||
/**** Instructions ****/
|
||||
|
|
@ -781,6 +800,7 @@ let /* Booleans */
|
|||
var OPCODE_EXIT := 27
|
||||
var OPCODE_EQV := 28
|
||||
var OPCODE_CONCAT := 29
|
||||
var OPCODE_FORGET := 32
|
||||
|
||||
var OPCODE_DEBUG := 31
|
||||
|
||||
|
|
@ -821,6 +841,7 @@ let /* Booleans */
|
|||
; code(OPCODE_RET, "RET", 1, 0, 0)
|
||||
|
||||
; code(OPCODE_DEF, "DEF", 0, 1, 0)
|
||||
; code(OPCODE_FORGET, "FORGET", 1, 0, 0)
|
||||
; code(OPCODE_SETG, "SETG", 0, 1, 0)
|
||||
; code(OPCODE_DEFFUN, "DEFFUN", 1, 0, 0)
|
||||
; code(OPCODE_POP, "POP", 0, 0, 0)
|
||||
|
|
@ -988,6 +1009,7 @@ let /* Booleans */
|
|||
, pos_r = pos_r }))
|
||||
; ())
|
||||
|
||||
|
||||
function app_insn2 (insns: vm_insn_list, opcode:int, arg3: scheme_value, pos_l: pos, pos_r: pos) =
|
||||
( concat_lists(insns, single_insn(vm_insn { opcode = opcode
|
||||
, arg1 = 0
|
||||
|
|
@ -1253,6 +1275,15 @@ let /* Booleans */
|
|||
; stdfun("exit")
|
||||
; app(OPCODE_EXIT, true, "")
|
||||
|
||||
/* Misc??? */
|
||||
; stdfun("symbol?")
|
||||
; app(OPCODE_TYPEOF, 0, "")
|
||||
; app2(OPCODE_PUSH, int_val(type_symbol))
|
||||
; app(OPCODE_NUMEQ, 0, "")
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
|
||||
|
||||
; std_insns
|
||||
end
|
||||
|
||||
|
|
@ -1348,6 +1379,9 @@ let /* Booleans */
|
|||
, value)
|
||||
, env )
|
||||
|
||||
function env_pop(env: vm_env): vm_env =
|
||||
env.val_cdr
|
||||
|
||||
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
|
||||
|
|
@ -1728,6 +1762,17 @@ let /* Booleans */
|
|||
; insns_car )
|
||||
end
|
||||
|
||||
function compile_load_of_arguments ( insns: vm_insn_list
|
||||
, sexp_args: sexp_ast
|
||||
, pos_l: pos
|
||||
, pos_r: pos) =
|
||||
if sexp_args = nil
|
||||
| sexp_args.typ = type_nil
|
||||
| sexp_args.val_car = nil
|
||||
then ()
|
||||
else ( compile_load_of_arguments(insns, sexp_args.val_cdr, pos_l, pos_r)
|
||||
; app_insn(insns, OPCODE_DEF, 0, sexp_args.val_car.val_s, pos_l, pos_r) )
|
||||
|
||||
function compile_rec ( ast: sexp_ast
|
||||
, can_tail_call: bool
|
||||
, expected_type: type_type ): vm_insn_list =
|
||||
|
|
@ -1744,8 +1789,13 @@ let /* Booleans */
|
|||
tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r, expected_type)
|
||||
, can_tail_call)
|
||||
|
||||
else if ast.val_car = nil
|
||||
| ast.val_cdr = nil
|
||||
then ( compile_error("Attemping to compile malformed ast", ast)
|
||||
; nil )
|
||||
|
||||
/* If statements */
|
||||
else if ast.val_car <> nil
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "if"
|
||||
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, type_any)
|
||||
|
|
@ -1754,36 +1804,43 @@ let /* Booleans */
|
|||
else tail_position_one( atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)
|
||||
, can_tail_call)
|
||||
|
||||
var jump_then := sexp_ast_length(insns_then) + 1
|
||||
var jump_else := sexp_ast_length(insns_else) + 1 + 1
|
||||
var jump_then := sexp_ast_length(insns_then) + 1 + (if can_tail_call then 0 else 1)
|
||||
var jump_else := sexp_ast_length(insns_else) + 1
|
||||
|
||||
var pos_l := ast.pos_l
|
||||
var pos_r := ast.pos_r
|
||||
|
||||
in app_insn(insns_test, OPCODE_CSKIP, 2, "" , pos_l, pos_r)
|
||||
; app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
|
||||
; concat_lists(insns_test, insns_else)
|
||||
; app_insn(insns_test, OPCODE_DGOTO, jump_then, "" , pos_l, pos_r)
|
||||
in app_insn(insns_test, OPCODE_CSKIP, jump_then, "" , pos_l, pos_r)
|
||||
; concat_lists(insns_test, insns_then)
|
||||
; if not(can_tail_call)
|
||||
then app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
|
||||
; concat_lists(insns_test, insns_else)
|
||||
; insns_test
|
||||
end
|
||||
|
||||
/* Define statements */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "define"
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "define"
|
||||
then compile_define(ast)
|
||||
|
||||
/* Syntax define statements */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "define-syntax"
|
||||
then ( compile_error("Please do not compile define-syntax", ast)
|
||||
; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)))
|
||||
|
||||
|
||||
/* Syntax rules expression */
|
||||
/*
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "syntax-rules"
|
||||
then compile_syntax_rules(ast)
|
||||
*/
|
||||
|
||||
/* Begin expressions */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "begin"
|
||||
/* TODO: Implement using macroes, when those are
|
||||
* available. */
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "begin"
|
||||
then let var insns := vm_insn_list { first = nil, last = nil }
|
||||
var head := ast.val_cdr
|
||||
|
||||
|
|
@ -1798,7 +1855,8 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
/* Quote expressions */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "quote"
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "quote"
|
||||
then let var datum := ast.val_cdr.val_car
|
||||
|
||||
in tail_position_one( vm_insn { opcode = OPCODE_PUSH
|
||||
|
|
@ -1811,7 +1869,8 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
/* Quasi-Quote expressions */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "quasiquote"
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "quasiquote"
|
||||
then let var datum := ast.val_cdr.val_car
|
||||
var insns := compile_quasiquote(datum)
|
||||
|
||||
|
|
@ -1827,7 +1886,8 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
/* Set statements */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "set!"
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "set!"
|
||||
then let var sym := ast.val_cdr.val_car.val_s
|
||||
var exp_insns := compile_rec(ast.val_cdr.val_cdr.val_car, false, type_any)
|
||||
|
||||
|
|
@ -1837,46 +1897,30 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
/* Lambda expressions */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "lambda"
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s = "lambda"
|
||||
|
||||
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_r := ast.pos_r
|
||||
|
||||
function build_insns_arguments (args: sexp_ast, derp: vm_insn_list_link): vm_insn_list_link =
|
||||
if args = nil
|
||||
| args.typ = type_nil
|
||||
| args.val_car = nil
|
||||
then derp
|
||||
else
|
||||
build_insns_arguments( args.val_cdr
|
||||
, vm_insn_list_link { insn = vm_insn { opcode = OPCODE_DEF
|
||||
, arg1 = 0
|
||||
, arg2 = args.val_car.val_s
|
||||
, arg3 = nil
|
||||
, pos_l = pos_l
|
||||
, pos_r = pos_r }
|
||||
, next = derp })
|
||||
|
||||
var insns_ass_args := list(build_insns_arguments(ast.val_cdr.val_car, nil))
|
||||
|
||||
var jump_lambda := sexp_ast_length(insns_body)
|
||||
+ sexp_ast_length(insns_ass_args)
|
||||
+ sexp_list_length(ast.val_cdr.val_car)
|
||||
+ 1
|
||||
|
||||
var insns := vm_insn_list { first = nil, last = nil }
|
||||
|
||||
in app_insn(insns, OPCODE_DEFFUN, 2, "", pos_l, pos_r)
|
||||
; app_insn(insns, OPCODE_DGOTO, jump_lambda, "" , pos_l, pos_r)
|
||||
; concat_lists(insns, insns_ass_args)
|
||||
; compile_load_of_arguments(insns, ast.val_cdr.val_car, pos_l, pos_r)
|
||||
; concat_lists(insns, insns_body)
|
||||
; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r)
|
||||
; insns
|
||||
end
|
||||
|
||||
/* Macro applications */
|
||||
else if ast.val_car <> nil
|
||||
& ast.val_car.typ = type_symbol
|
||||
else if ast.val_car.typ = type_symbol
|
||||
& ast.val_car.val_s <> ""
|
||||
& env_seek_elem(env_macro, ast.val_car.val_s) <> nil
|
||||
then let var stack := stack_new()
|
||||
|
|
@ -1895,11 +1939,61 @@ let /* Booleans */
|
|||
, ast)
|
||||
; TRIGGERED_EXIT := true
|
||||
; nil )
|
||||
else ( 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, type_any) )
|
||||
else let var derp: scheme_value := nil
|
||||
in vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global)
|
||||
; /* TODO: Assert that there is something on the stack */
|
||||
derp := stack_pop(stack)
|
||||
; if DEBUG_PRINT_MACRO
|
||||
then ( print("Macro expanded to: ")
|
||||
; print(value_to_string(derp))
|
||||
; print("\n") )
|
||||
; compile_rec(derp, can_tail_call, type_any)
|
||||
end
|
||||
end
|
||||
|
||||
/* Call-lambda expressions: A system for binding local
|
||||
* variables */
|
||||
/* Lambda expressions */
|
||||
else if ast.val_car.typ = type_pair
|
||||
& ast.val_car.val_car.typ = type_symbol
|
||||
& ast.val_car.val_car.val_s = "lambda"
|
||||
|
||||
/* Does not support non-proper lists, currently: */
|
||||
& scheme_value_is_proper_list (ast.val_car.val_cdr.val_car)
|
||||
then
|
||||
let var pos_l := ast.pos_l
|
||||
var pos_r := ast.pos_r
|
||||
|
||||
var insns := vm_insn_list { first = nil, last = nil }
|
||||
|
||||
var num_required_args := sexp_list_length (ast.val_car.val_cdr.val_car)
|
||||
var num_given_args := sexp_list_length (ast.val_cdr)
|
||||
/* TODO: Give error when numbers of arguments does
|
||||
* not match */
|
||||
|
||||
var ast_iter := ast.val_cdr
|
||||
|
||||
in ()
|
||||
|
||||
/* First compile arguments onto stack */
|
||||
; while ast_iter <> nil & ast_iter.typ = type_pair
|
||||
do ( concat_lists(insns, compile_rec(ast_iter.val_car, false, type_any))
|
||||
; ast_iter := ast_iter.val_cdr )
|
||||
|
||||
/* Then assign them to variables */
|
||||
; print(concat(value_to_string(ast.val_car.val_cdr.val_car), "\n"))
|
||||
; compile_load_of_arguments(insns, ast.val_car.val_cdr.val_car, pos_l, pos_r)
|
||||
|
||||
/* Perform body */
|
||||
; concat_lists(insns, compile_rec(ast.val_car.val_cdr.val_cdr.val_car, can_tail_call, type_any))
|
||||
|
||||
/* Forget variables again */
|
||||
; app_insn(insns, OPCODE_FORGET, num_required_args, "", pos_l, pos_r)
|
||||
|
||||
/* Return instructions */
|
||||
; insns
|
||||
end
|
||||
|
||||
/* Call expressions */
|
||||
else let var num_args := 0
|
||||
var args_insns := vm_insn_list { first = nil, last = nil }
|
||||
|
|
@ -1926,8 +2020,8 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
function compile_error(errmsg: string, errast: sexp_ast) =
|
||||
let var repr_pos_l := pos_to_string(errast.pos_l)
|
||||
var repr_pos_r := pos_to_string(errast.pos_r)
|
||||
let var repr_pos_l := pos_to_string(if errast = nil then nil else errast.pos_l)
|
||||
var repr_pos_r := pos_to_string(if errast = nil then nil else errast.pos_r)
|
||||
in print("Tiger-scheme compile error\n ")
|
||||
; print(errmsg)
|
||||
; print("\n For scheme: ")
|
||||
|
|
@ -1940,8 +2034,12 @@ let /* Booleans */
|
|||
; print("\n")
|
||||
end
|
||||
|
||||
var base_insns := compile_rec(ast, false, type_any)
|
||||
in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
|
||||
var base_insns :=
|
||||
if ast = nil
|
||||
then (compile_error("Given ast was nil!", ast); nil)
|
||||
else compile_rec(ast, false, type_any)
|
||||
in if ast <> nil
|
||||
then app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
|
||||
; base_insns
|
||||
end
|
||||
|
||||
|
|
@ -2163,9 +2261,12 @@ let /* Booleans */
|
|||
if value = nil
|
||||
then run_error(concat5( "Attempting to access unknown variable \""
|
||||
, tape[ip].arg2
|
||||
, "\"\n Environment looks like "
|
||||
, env_to_string(env)
|
||||
, ""))
|
||||
, "\"\n"
|
||||
, ""
|
||||
, if DEBUG_SHOW_FULL_ENVIRONMENT
|
||||
then concat( "\tEnvironment looks like "
|
||||
, env_to_string(env))
|
||||
else ""))
|
||||
else if tape[ip].arg1 <> 0
|
||||
& tape[ip].arg1 <> value.typ
|
||||
then run_error(concat6( "Attempting to access variable \""
|
||||
|
|
@ -2185,6 +2286,11 @@ let /* Booleans */
|
|||
; ip := ip + 1
|
||||
end
|
||||
|
||||
else if tape[ip].opcode = OPCODE_FORGET
|
||||
then ( for i := 1 to tape[ip].arg1
|
||||
do env := env_pop(env)
|
||||
; ip := ip + 1 )
|
||||
|
||||
else if tape[ip].opcode = OPCODE_SETG
|
||||
then let var value := stack_pop(stack)
|
||||
var new_env := global_env_push(global_env, tape[ip].arg2, value)
|
||||
|
|
@ -2450,14 +2556,26 @@ let /* Booleans */
|
|||
let var depth := 0
|
||||
var char := "BAD SHIT HAPPENED"
|
||||
var text := ""
|
||||
var comment_mode := false
|
||||
in while char <> ""
|
||||
do ( char := getchar()
|
||||
; text := concat(text, char)
|
||||
; if char = "("
|
||||
; if comment_mode
|
||||
& char = "\n"
|
||||
then comment_mode := false
|
||||
else if comment_mode
|
||||
then () /* Do nothing */
|
||||
|
||||
/* We can assume that comment mode is not enabled for
|
||||
* these: */
|
||||
else if char = "("
|
||||
then depth := depth + 1
|
||||
else if char = ")"
|
||||
then ( depth := depth - 1
|
||||
; if depth = 0 then break ))
|
||||
; if depth = 0 then break )
|
||||
else if char = ";"
|
||||
then comment_mode := true
|
||||
)
|
||||
; text
|
||||
end
|
||||
|
||||
|
|
@ -2473,9 +2591,12 @@ in print("Ready for the scheming Tiger?\n")
|
|||
|
||||
var macro_name := "" /* Not macro is "" */
|
||||
|
||||
var sexp := parse_string(text)
|
||||
var sexp := if size(text) > 0
|
||||
then parse_string(text)
|
||||
else nil
|
||||
var sexp_compile :=
|
||||
if sexp.typ = type_pair
|
||||
if sexp <> nil
|
||||
& 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user