From d776adba344d8c29bbe8b46cc342184b7c8e14bc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 4 Apr 2017 00:52:59 +0900 Subject: [PATCH] add load&compile functions --- Makefile | 2 +- contrib/10.math/math.c | 2 +- contrib/20.r7rs/src/file.c | 2 +- contrib/20.r7rs/src/load.c | 18 +- contrib/20.r7rs/src/r7rs.c | 18 +- contrib/20.r7rs/src/system.c | 2 +- contrib/20.r7rs/src/time.c | 2 +- contrib/30.random/src/random.c | 2 +- contrib/30.readline/src/readline.c | 2 +- contrib/30.regexp/src/regexp.c | 2 +- contrib/40.srfi/src/0.c | 2 +- contrib/40.srfi/src/106.c | 2 +- contrib/60.repl/repl.c | 2 +- lib/ext/boot.c | 6 +- lib/ext/compile.c | 457 +++++++++++++++ lib/ext/load.c | 896 ++++++++++++++++++++++++++++- lib/include/picrin/extra.h | 9 +- lib/state.c | 4 +- piclib/library.scm | 2 +- tools/mkboot.scm | 4 +- tools/mkinit.pl | 4 +- tools/mkloader.pl | 23 +- 22 files changed, 1414 insertions(+), 49 deletions(-) create mode 100644 lib/ext/compile.c diff --git a/Makefile b/Makefile index e72145aa..87a40b5f 100644 --- a/Makefile +++ b/Makefile @@ -20,7 +20,7 @@ LIBPICRIN_SRCS = \ lib/vector.c\ lib/weak.c\ lib/ext/boot.c\ - lib/ext/eval.c\ + lib/ext/compile.c\ lib/ext/lib.c\ lib/ext/load.c\ lib/ext/read.c\ diff --git a/contrib/10.math/math.c b/contrib/10.math/math.c index ead97806..10330baf 100644 --- a/contrib/10.math/math.c +++ b/contrib/10.math/math.c @@ -283,7 +283,7 @@ pic_number_expt(pic_state *pic) } void -pic_init_math(pic_state *pic) +pic_nitro_init_math(pic_state *pic) { pic_deflibrary(pic, "picrin.math"); pic_in_library(pic, "picrin.math"); diff --git a/contrib/20.r7rs/src/file.c b/contrib/20.r7rs/src/file.c index 35286606..97e6ef24 100644 --- a/contrib/20.r7rs/src/file.c +++ b/contrib/20.r7rs/src/file.c @@ -75,7 +75,7 @@ pic_file_delete(pic_state *pic) } void -pic_init_file(pic_state *pic) +pic_nitro_init_file(pic_state *pic) { pic_defun(pic, "scheme.base:open-input-file", pic_file_open_input_file); /* for `include' */ pic_defun(pic, "scheme.file:open-input-file", pic_file_open_input_file); diff --git a/contrib/20.r7rs/src/load.c b/contrib/20.r7rs/src/load.c index 6c901c9a..111f87a8 100644 --- a/contrib/20.r7rs/src/load.c +++ b/contrib/20.r7rs/src/load.c @@ -10,7 +10,7 @@ static pic_value pic_load_load(pic_state *pic) { - pic_value envid, port; + pic_value envid, port, e; char *fn; FILE *fp; @@ -22,16 +22,26 @@ pic_load_load(pic_state *pic) } port = pic_fopen(pic, fp, "r"); + pic_try { + pic_value form; + size_t ai = pic_enter(pic); - pic_load(pic, port); - + while (! pic_eof_p(pic, form = pic_read(pic, port))) { + pic_funcall(pic, "eval", 1, form); + pic_leave(pic, ai); + } + } + pic_catch (e) { + pic_fclose(pic, port); + pic_raise(pic, e); + } pic_fclose(pic, port); return pic_undef_value(pic); } void -pic_init_load(pic_state *pic) +pic_nitro_init_load(pic_state *pic) { pic_defun(pic, "scheme.load:load", pic_load_load); } diff --git a/contrib/20.r7rs/src/r7rs.c b/contrib/20.r7rs/src/r7rs.c index 43f98ed4..efe78aef 100644 --- a/contrib/20.r7rs/src/r7rs.c +++ b/contrib/20.r7rs/src/r7rs.c @@ -4,18 +4,18 @@ #include "picrin.h" -void pic_init_file(pic_state *); -void pic_init_load(pic_state *); -void pic_init_system(pic_state *); -void pic_init_time(pic_state *); +void pic_nitro_init_file(pic_state *); +void pic_nitro_init_load(pic_state *); +void pic_nitro_init_system(pic_state *); +void pic_nitro_init_time(pic_state *); void -pic_init_r7rs(pic_state *pic) +pic_nitro_init_r7rs(pic_state *pic) { - pic_init_file(pic); - pic_init_load(pic); - pic_init_system(pic); - pic_init_time(pic); + pic_nitro_init_file(pic); + pic_nitro_init_load(pic); + pic_nitro_init_system(pic); + pic_nitro_init_time(pic); pic_add_feature(pic, "r7rs"); } diff --git a/contrib/20.r7rs/src/system.c b/contrib/20.r7rs/src/system.c index 75b2914d..64979667 100644 --- a/contrib/20.r7rs/src/system.c +++ b/contrib/20.r7rs/src/system.c @@ -112,7 +112,7 @@ pic_system_getenvs(pic_state *pic) } void -pic_init_system(pic_state *pic) +pic_nitro_init_system(pic_state *pic) { pic_defun(pic, "scheme.process-context:command-line", pic_system_cmdline); pic_defun(pic, "scheme.process-context:exit", pic_system_exit); diff --git a/contrib/20.r7rs/src/time.c b/contrib/20.r7rs/src/time.c index 1460c0b4..15b005e6 100644 --- a/contrib/20.r7rs/src/time.c +++ b/contrib/20.r7rs/src/time.c @@ -40,7 +40,7 @@ pic_jiffies_per_second(pic_state *pic) } void -pic_init_time(pic_state *pic) +pic_nitro_init_time(pic_state *pic) { pic_defun(pic, "scheme.time:current-second", pic_current_second); pic_defun(pic, "scheme.time:current-jiffy", pic_current_jiffy); diff --git a/contrib/30.random/src/random.c b/contrib/30.random/src/random.c index 2d50e256..ce2d3015 100644 --- a/contrib/30.random/src/random.c +++ b/contrib/30.random/src/random.c @@ -12,7 +12,7 @@ pic_random_real(pic_state *pic) } void -pic_init_random(pic_state *pic) +pic_nitro_init_random(pic_state *pic) { pic_deflibrary(pic, "srfi.27"); pic_in_library(pic, "srfi.27"); diff --git a/contrib/30.readline/src/readline.c b/contrib/30.readline/src/readline.c index a78313a9..f557d141 100644 --- a/contrib/30.readline/src/readline.c +++ b/contrib/30.readline/src/readline.c @@ -241,7 +241,7 @@ pic_rl_history_expand(pic_state *pic) } void -pic_init_readline(pic_state *pic){ +pic_nitro_init_readline(pic_state *pic){ using_history(); pic_deflibrary(pic, "picrin.readline"); diff --git a/contrib/30.regexp/src/regexp.c b/contrib/30.regexp/src/regexp.c index 163ccdd8..f9387988 100644 --- a/contrib/30.regexp/src/regexp.c +++ b/contrib/30.regexp/src/regexp.c @@ -165,7 +165,7 @@ pic_regexp_regexp_replace(pic_state *pic) } void -pic_init_regexp(pic_state *pic) +pic_nitro_init_regexp(pic_state *pic) { pic_deflibrary(pic, "picrin.regexp"); pic_in_library(pic, "picrin.regexp"); diff --git a/contrib/40.srfi/src/0.c b/contrib/40.srfi/src/0.c index 1af710d0..834d97e7 100644 --- a/contrib/40.srfi/src/0.c +++ b/contrib/40.srfi/src/0.c @@ -1,7 +1,7 @@ #include "picrin.h" void -pic_init_srfi_0(pic_state *pic) +pic_nitro_init_srfi_0(pic_state *pic) { pic_add_feature(pic, "srfi-0"); pic_add_feature(pic, "srfi-1"); diff --git a/contrib/40.srfi/src/106.c b/contrib/40.srfi/src/106.c index 8215fc79..4f295301 100644 --- a/contrib/40.srfi/src/106.c +++ b/contrib/40.srfi/src/106.c @@ -353,7 +353,7 @@ pic_socket_call_with_socket(pic_state *pic) } void -pic_init_srfi_106(pic_state *pic) +pic_nitro_init_srfi_106(pic_state *pic) { pic_defun(pic, "srfi.106:socket?", pic_socket_socket_p); pic_defun(pic, "srfi.106:make-socket", pic_socket_make_socket); diff --git a/contrib/60.repl/repl.c b/contrib/60.repl/repl.c index 89f14de7..c88fd75a 100644 --- a/contrib/60.repl/repl.c +++ b/contrib/60.repl/repl.c @@ -12,7 +12,7 @@ pic_repl_tty_p(pic_state *pic) } void -pic_init_repl(pic_state *pic) +pic_nitro_init_repl(pic_state *pic) { pic_defun(pic, "picrin.repl:tty?", pic_repl_tty_p); } diff --git a/lib/ext/boot.c b/lib/ext/boot.c index 1b564b6d..804d5fde 100644 --- a/lib/ext/boot.c +++ b/lib/ext/boot.c @@ -337,7 +337,7 @@ static const char boot_library_rom[][80] = { "ring-append .res.2459 .delim.2457 (car .strs.2460)) (cdr .strs.2460))))) (.loop.", "2458 (car .strs.2456) (cdr .strs.2456))))))) (core#if (symbol? .name.2448) .name", ".2448 (string->symbol (.join.2450 (map .->string.2449 .name.2448) \".\")))))))) (c", -"ore#begin (core#define current-library (make-parameter (core#quote (picrin base)", +"ore#begin (core#define current-library (make-parameter (core#quote (picrin user)", ") mangle)) (core#begin (core#define *libraries* (make-dictionary)) (core#begin (", "core#define find-library (core#lambda (.name.2461) (dictionary-has? *libraries* ", "(mangle .name.2461)))) (core#begin (core#define make-library (core#lambda (.name", @@ -492,8 +492,8 @@ static const char boot_library_rom[][80] = { void pic_boot(pic_state *pic) { - pic_call(pic, pic_compile(pic, pic_read_cstr(pic, &boot_rom[0][0])), 0); + pic_load_native(pic, &boot_rom[0][0]); #if PIC_USE_LIBRARY - pic_call(pic, pic_compile(pic, pic_read_cstr(pic, &boot_library_rom[0][0])), 0); + pic_load_native(pic, &boot_library_rom[0][0]); #endif } diff --git a/lib/ext/compile.c b/lib/ext/compile.c new file mode 100644 index 00000000..afabc6bb --- /dev/null +++ b/lib/ext/compile.c @@ -0,0 +1,457 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/extra.h" +#include "../object.h" +#include "../state.h" + +KHASH_DEFINE(env, struct identifier *, symbol *, kh_ptr_hash_func, kh_ptr_hash_equal) + +pic_value +pic_make_env(pic_state *pic, pic_value prefix) +{ + struct env *env; + + env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV); + env->up = NULL; + env->prefix = pic_str_ptr(pic, prefix); + kh_init(env, &env->map); + + return obj_value(pic, env); +} + +static pic_value +default_env(pic_state *pic) +{ + return pic_ref(pic, "default-environment"); +} + +static pic_value +extend_env(pic_state *pic, pic_value up) +{ + struct env *env; + + env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV); + env->up = pic_env_ptr(pic, up); + env->prefix = NULL; + kh_init(env, &env->map); + + return obj_value(pic, env); +} + +static bool +search_scope(pic_state *pic, pic_value id, pic_value env, pic_value *uid) +{ + int it; + + it = kh_get(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id)); + if (it == kh_end(&pic_env_ptr(pic, env)->map)) { + return false; + } + *uid = obj_value(pic, kh_val(&pic_env_ptr(pic, env)->map, it)); + return true; +} + +static bool +search(pic_state *pic, pic_value id, pic_value env, pic_value *uid) +{ + struct env *e; + + while (1) { + if (search_scope(pic, id, env, uid)) + return true; + e = pic_env_ptr(pic, env)->up; + if (e == NULL) + break; + env = obj_value(pic, e); + } + return false; +} + +pic_value +pic_find_identifier(pic_state *pic, pic_value id, pic_value env) +{ + struct env *e; + pic_value uid; + + while (! search(pic, id, env, &uid)) { + if (pic_sym_p(pic, id)) { + while (1) { + e = pic_env_ptr(pic, env); + if (e->up == NULL) + break; + env = obj_value(pic, e->up); + } + return pic_add_identifier(pic, id, env); + } + env = obj_value(pic, pic_id_ptr(pic, id)->env); /* do not overwrite id first */ + id = obj_value(pic, pic_id_ptr(pic, id)->u.id); + } + return uid; +} + +pic_value +pic_add_identifier(pic_state *pic, pic_value id, pic_value env) +{ + const char *name, *prefix; + pic_value uid, str; + + if (search_scope(pic, id, env, &uid)) { + return uid; + } + + name = pic_str(pic, pic_id_name(pic, id), NULL); + + if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) { + prefix = pic_str(pic, obj_value(pic, pic_env_ptr(pic, env)->prefix), NULL); + str = pic_strf_value(pic, "%s%s", prefix, name); + } else { + str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++); + } + uid = pic_intern(pic, str); + + pic_set_identifier(pic, id, uid, env); + + return uid; +} + +void +pic_set_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env) +{ + int it, ret; + it = kh_put(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id), &ret); + kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid); +} + +#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0) +#define S(lit) (pic_intern_lit(pic, lit)) + +#define pic_sym(pic,sym) pic_str(pic, pic_sym_name(pic, (sym)), NULL) + +static void +define_macro(pic_state *pic, pic_value uid, pic_value mac) +{ + if (pic_weak_has(pic, pic->macros, uid)) { + pic_warnf(pic, "redefining syntax variable: %s", pic_sym(pic, uid)); + } + pic_weak_set(pic, pic->macros, uid, mac); +} + +static bool +find_macro(pic_state *pic, pic_value uid, pic_value *mac) +{ + if (! pic_weak_has(pic, pic->macros, uid)) { + return false; + } + *mac = pic_weak_ref(pic, pic->macros, uid); + return true; +} + +static void +shadow_macro(pic_state *pic, pic_value uid) +{ + if (pic_weak_has(pic, pic->macros, uid)) { + pic_weak_del(pic, pic->macros, uid); + } +} + +static pic_value expand(pic_state *, pic_value expr, pic_value env, pic_value deferred); +static pic_value expand_lambda(pic_state *, pic_value expr, pic_value env); + +static pic_value +expand_var(pic_state *pic, pic_value id, pic_value env, pic_value deferred) +{ + pic_value mac, functor; + + functor = pic_find_identifier(pic, id, env); + + if (find_macro(pic, functor, &mac)) { + return expand(pic, pic_call(pic, mac, 2, id, env), env, deferred); + } + return functor; +} + +static pic_value +expand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, S("core#quote"), pic_cdr(pic, expr)); +} + +static pic_value +expand_list(pic_state *pic, pic_value obj, pic_value env, pic_value deferred) +{ + size_t ai = pic_enter(pic); + pic_value x, head, tail; + + if (pic_pair_p(pic, obj)) { + head = expand(pic, pic_car(pic, obj), env, deferred); + tail = expand_list(pic, pic_cdr(pic, obj), env, deferred); + x = pic_cons(pic, head, tail); + } else { + x = expand(pic, obj, env, deferred); + } + + pic_leave(pic, ai); + pic_protect(pic, x); + return x; +} + +static pic_value +expand_defer(pic_state *pic, pic_value expr, pic_value deferred) +{ + pic_value skel = pic_cons(pic, pic_invalid_value(pic), pic_invalid_value(pic)); + + pic_set_car(pic, deferred, pic_cons(pic, pic_cons(pic, expr, skel), pic_car(pic, deferred))); + + return skel; +} + +static void +expand_deferred(pic_state *pic, pic_value deferred, pic_value env) +{ + pic_value defer, val, src, dst, it; + + deferred = pic_car(pic, deferred); + + pic_for_each (defer, pic_reverse(pic, deferred), it) { + src = pic_car(pic, defer); + dst = pic_cdr(pic, defer); + + val = expand_lambda(pic, src, env); + + /* copy */ + pic_set_car(pic, dst, pic_car(pic, val)); + pic_set_cdr(pic, dst, pic_cdr(pic, val)); + } +} + +static pic_value +expand_lambda(pic_state *pic, pic_value expr, pic_value env) +{ + pic_value formal, body; + pic_value in; + pic_value a, deferred; + + in = extend_env(pic, env); + + for (a = pic_cadr(pic, expr); pic_pair_p(pic, a); a = pic_cdr(pic, a)) { + pic_add_identifier(pic, pic_car(pic, a), in); + } + if (pic_id_p(pic, a)) { + pic_add_identifier(pic, a, in); + } + + deferred = pic_list(pic, 1, pic_nil_value(pic)); + + formal = expand_list(pic, pic_list_ref(pic, expr, 1), in, deferred); + body = expand(pic, pic_list_ref(pic, expr, 2), in, deferred); + + expand_deferred(pic, deferred, in); + + return pic_list(pic, 3, S("core#lambda"), formal, body); +} + +static pic_value +expand_define(pic_state *pic, pic_value expr, pic_value env, pic_value deferred) +{ + pic_value uid, val; + + uid = pic_add_identifier(pic, pic_list_ref(pic, expr, 1), env); + + shadow_macro(pic, uid); + + val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred); + + return pic_list(pic, 3, S("core#define"), uid, val); +} + +static pic_value +expand_defmacro(pic_state *pic, pic_value expr, pic_value env) +{ + pic_value uid, val; + + uid = pic_add_identifier(pic, pic_list_ref(pic, expr, 1), env); + + val = pic_load(pic, pic_compile(pic, pic_list_ref(pic, expr, 2), env)); + if (! pic_proc_p(pic, val)) { + pic_error(pic, "macro definition evaluates to non-procedure object", 1, pic_list_ref(pic, expr, 1)); + } + + define_macro(pic, uid, val); + + return pic_undef_value(pic); +} + +static pic_value +expand_node(pic_state *pic, pic_value expr, pic_value env, pic_value deferred) +{ + switch (pic_type(pic, expr)) { + case PIC_TYPE_ID: + case PIC_TYPE_SYMBOL: { + return expand_var(pic, expr, env, deferred); + } + case PIC_TYPE_PAIR: { + pic_value mac; + + if (! pic_list_p(pic, expr)) { + pic_error(pic, "cannot expand improper list", 1, expr); + } + + if (pic_id_p(pic, pic_car(pic, expr))) { + pic_value functor; + + functor = pic_find_identifier(pic, pic_car(pic, expr), env); + + if (EQ(functor, "core#define-macro")) { + return expand_defmacro(pic, expr, env); + } + else if (EQ(functor, "core#lambda")) { + return expand_defer(pic, expr, deferred); + } + else if (EQ(functor, "core#define")) { + return expand_define(pic, expr, env, deferred); + } + else if (EQ(functor, "core#quote")) { + return expand_quote(pic, expr); + } + + if (find_macro(pic, functor, &mac)) { + return expand(pic, pic_call(pic, mac, 2, expr, env), env, deferred); + } + } + return expand_list(pic, expr, env, deferred); + } + default: + return expr; + } +} + +static pic_value +expand(pic_state *pic, pic_value expr, pic_value env, pic_value deferred) +{ + size_t ai = pic_enter(pic); + pic_value v; + + v = expand_node(pic, expr, env, deferred); + + pic_leave(pic, ai); + pic_protect(pic, v); + return v; +} + +pic_value +pic_compile(pic_state *pic, pic_value expr, pic_value env) +{ + pic_value v, deferred; + + deferred = pic_list(pic, 1, pic_nil_value(pic)); + + v = expand(pic, expr, env, deferred); + + expand_deferred(pic, deferred, env); + + return v; +} + +static pic_value +pic_compile_make_environment(pic_state *pic) +{ + pic_value name; + + pic_get_args(pic, "m", &name); + + return pic_make_env(pic, pic_sym_name(pic, name)); +} + +static pic_value +pic_compile_set_identifier(pic_state *pic) +{ + pic_value id, uid, env; + + pic_get_args(pic, "omo", &id, &uid, &env); + + TYPE_CHECK(pic, id, id); + TYPE_CHECK(pic, env, env); + + pic_set_identifier(pic, id, uid, env); + return pic_undef_value(pic); +} + +static pic_value +pic_compile_find_identifier(pic_state *pic) +{ + pic_value id, env; + + pic_get_args(pic, "oo", &id, &env); + + TYPE_CHECK(pic, id, id); + TYPE_CHECK(pic, env, env); + + return pic_find_identifier(pic, id, env); +} + +static pic_value +pic_compile_add_macro(pic_state *pic) +{ + pic_value id, mac, uid; + + pic_get_args(pic, "ol", &id, &mac); + + TYPE_CHECK(pic, id, id); + + uid = pic_find_identifier(pic, id, default_env(pic)); + define_macro(pic, uid, mac); + return pic_undef_value(pic); +} + +static pic_value +pic_compile_compile(pic_state *pic) +{ + pic_value program, env = default_env(pic); + + pic_get_args(pic, "o|o", &program, &env); + + TYPE_CHECK(pic, env, env); + + return pic_compile(pic, program, env); +} + +static pic_value +pic_compile_eval(pic_state *pic) +{ + pic_value program, env = default_env(pic); + + pic_get_args(pic, "o|o", &program, &env); + + TYPE_CHECK(pic, env, env); + + return pic_load(pic, pic_compile(pic, program, env)); +} + +#define add_keyword(name) do { \ + pic_value var; \ + var = pic_intern_lit(pic, name); \ + pic_set_identifier(pic, var, var, env); \ + } while (0) + +void +pic_init_compile(pic_state *pic) +{ + pic_value env = pic_make_env(pic, pic_lit_value(pic, "")); + add_keyword("core#define"); + add_keyword("core#set!"); + add_keyword("core#quote"); + add_keyword("core#lambda"); + add_keyword("core#if"); + add_keyword("core#begin"); + add_keyword("core#define-macro"); + pic_define(pic, "default-environment", env); + pic_defun(pic, "make-environment", pic_compile_make_environment); + pic_defun(pic, "find-identifier", pic_compile_find_identifier); + pic_defun(pic, "set-identifier!", pic_compile_set_identifier); + pic_defun(pic, "add-macro!", pic_compile_add_macro); + pic_defun(pic, "compile", pic_compile_compile); + pic_defun(pic, "eval", pic_compile_eval); +} diff --git a/lib/ext/load.c b/lib/ext/load.c index a3b00d2a..104b1210 100644 --- a/lib/ext/load.c +++ b/lib/ext/load.c @@ -4,26 +4,890 @@ #include "picrin.h" #include "picrin/extra.h" +#include "../object.h" +#include "../state.h" +#include "../vm.h" -void -pic_load(pic_state *pic, pic_value port) +#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0) +#define S(lit) (pic_intern_lit(pic, lit)) + +#define pic_sym(pic,sym) pic_str(pic, pic_sym_name(pic, (sym)), NULL) + +static pic_value +optimize_beta(pic_state *pic, pic_value expr) { - pic_value form; size_t ai = pic_enter(pic); + pic_value functor, formals, args, tmp, val, it, defs; - while (! pic_eof_p(pic, form = pic_read(pic, port))) { - pic_funcall(pic, "eval", 1, form); - pic_leave(pic, ai); + if (! pic_list_p(pic, expr)) + return expr; + + if (pic_nil_p(pic, expr)) + return expr; + + if (pic_sym_p(pic, pic_list_ref(pic, expr, 0))) { + pic_value sym = pic_list_ref(pic, expr, 0); + + if (EQ(sym, "core#quote")) { + return expr; + } else if (EQ(sym, "core#lambda")) { + return pic_list(pic, 3, S("core#lambda"), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2))); + } + } + + tmp = pic_nil_value(pic); + pic_for_each (val, expr, it) { + pic_push(pic, optimize_beta(pic, val), tmp); + } + expr = pic_reverse(pic, tmp); + + pic_leave(pic, ai); + pic_protect(pic, expr); + + functor = pic_list_ref(pic, expr, 0); + if (pic_pair_p(pic, functor) && pic_sym_p(pic, pic_car(pic, functor)) && EQ(pic_car(pic, functor), "core#lambda")) { + formals = pic_list_ref(pic, functor, 1); + if (! pic_list_p(pic, formals)) + goto exit; /* TODO: support ((lambda args x) 1 2) */ + args = pic_cdr(pic, expr); + if (pic_length(pic, formals) != pic_length(pic, args)) + goto exit; + defs = pic_nil_value(pic); + pic_for_each (val, args, it) { + pic_push(pic, pic_list(pic, 3, S("core#define"), pic_car(pic, formals), val), defs); + formals = pic_cdr(pic, formals); + } + expr = pic_list_ref(pic, functor, 2); + pic_for_each (val, defs, it) { + expr = pic_list(pic, 3, S("core#begin"), val, expr); + } + } + exit: + + pic_leave(pic, ai); + pic_protect(pic, expr); + return expr; +} + +static pic_value +pic_optimize(pic_state *pic, pic_value expr) +{ + return optimize_beta(pic, expr); +} + +static pic_value normalize(pic_state *pic, pic_value expr, pic_value locals, bool in); + +static pic_value +normalize_body(pic_state *pic, pic_value expr, bool in) +{ + pic_value v, locals; + + locals = pic_list(pic, 1, pic_nil_value(pic)); + + v = normalize(pic, expr, locals, in); + + if (! in) { + return v; + } + return pic_list(pic, 3, S("core#let"), pic_car(pic, locals), v); +} + +static pic_value +normalize(pic_state *pic, pic_value expr, pic_value locals, bool in) +{ + pic_value proc, e, it, r; + + if (! pic_list_p(pic, expr)) + return expr; + + if (! pic_pair_p(pic, expr)) + return expr; + + proc = pic_list_ref(pic, expr, 0); + if (pic_sym_p(pic, proc)) { + pic_value sym = proc; + + if (EQ(sym, "core#define")) { + pic_value var, val; + + var = pic_list_ref(pic, expr, 1); + + if (! in) { /* global */ + if (pic_dict_has(pic, pic->globals, var)) { + pic_warnf(pic, "redefining variable: %s", pic_sym(pic, var)); + } + pic_dict_set(pic, pic->globals, var, pic_invalid_value(pic)); + } else { /* local */ + bool found = false; + + pic_for_each (e, pic_car(pic, locals), it) { + if (pic_eq_p(pic, e, var)) { + pic_warnf(pic, "redefining variable: %s", pic_sym(pic, var)); + found = true; + break; + } + } + if (! found) { + pic_set_car(pic, locals, pic_cons(pic, var, pic_car(pic, locals))); + } + } + val = normalize(pic, pic_list_ref(pic, expr, 2), locals, in); + return pic_list(pic, 3, S("core#set!"), var, val); + } + else if (EQ(sym, "core#lambda")) { + return pic_list(pic, 3, S("core#lambda"), pic_list_ref(pic, expr, 1), normalize_body(pic, pic_list_ref(pic, expr, 2), true)); + } + else if (EQ(sym, "core#quote")) { + return expr; + } + } + + r = pic_nil_value(pic); + pic_for_each (e, expr, it) { + pic_push(pic, normalize(pic, e, locals, in), r); + } + return pic_reverse(pic, r); +} + +static pic_value +pic_normalize(pic_state *pic, pic_value expr) +{ + return normalize_body(pic, expr, false); +} + +typedef struct analyze_scope { + int depth; + pic_value args, locals, captures; + struct analyze_scope *up; +} analyze_scope; + +static void +analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value args, pic_value locals, analyze_scope *up) +{ + scope->args = args; + scope->locals = locals; + scope->captures = pic_make_dict(pic); + scope->up = up; + scope->depth = up ? up->depth + 1 : 0; +} + +static bool +find_local_var(pic_state *pic, analyze_scope *scope, pic_value sym) +{ + pic_value args, locals; + + /* args */ + for (args = scope->args; pic_pair_p(pic, args); args = pic_cdr(pic, args)) { + if (pic_eq_p(pic, pic_car(pic, args), sym)) + return true; + } + if (! pic_nil_p(pic, args)) { + if (pic_eq_p(pic, args, sym)) + return true; + } + + /* locals */ + for (locals = scope->locals; pic_pair_p(pic, locals); locals = pic_cdr(pic, locals)) { + if (pic_eq_p(pic, pic_car(pic, locals), sym)) + return true; + } + return false; +} + +static int +find_var(pic_state *pic, analyze_scope *scope, pic_value sym) +{ + int depth = 0; + + while (scope) { + if (find_local_var(pic, scope, sym)) { + if (depth > 0) { + pic_dict_set(pic, scope->captures, sym, pic_true_value(pic)); /* capture! */ + } + return depth; + } + depth++; + scope = scope->up; + } + return depth - 1; /* global variable */ +} + +static pic_value analyze(pic_state *, analyze_scope *, pic_value); +static pic_value analyze_lambda(pic_state *, analyze_scope *, pic_value); + +static pic_value +analyze_var(pic_state *pic, analyze_scope *scope, pic_value sym) +{ + int depth; + + depth = find_var(pic, scope, sym); + + if (depth == scope->depth) { + return pic_list(pic, 2, S("core#gref"), sym); + } else if (depth == 0) { + return pic_list(pic, 2, S("core#lref"), sym); + } else { + return pic_list(pic, 3, S("core#cref"), pic_int_value(pic, depth), sym); } } +static pic_value +analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form) +{ + analyze_scope s, *scope = &s; + pic_value body, args, locals; + + args = pic_list_ref(pic, form, 1); + locals = pic_list_ref(pic, pic_list_ref(pic, form, 2), 1); + body = pic_list_ref(pic, pic_list_ref(pic, form, 2), 2); + + analyzer_scope_init(pic, scope, args, locals, up); + + /* analyze body */ + body = analyze(pic, scope, body); + + return pic_list(pic, 5, S("core#lambda"), args, locals, scope->captures, body); +} + +static pic_value +analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj) +{ + pic_value seq = pic_nil_value(pic), val, it; + + pic_for_each (val, obj, it) { + pic_push(pic, analyze(pic, scope, val), seq); + } + + return pic_reverse(pic, seq); +} + +static pic_value +analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj) +{ + return pic_cons(pic, S("core#call"), analyze_list(pic, scope, obj)); +} + +static pic_value +analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj) +{ + switch (pic_type(pic, obj)) { + case PIC_TYPE_SYMBOL: { + return analyze_var(pic, scope, obj); + } + case PIC_TYPE_PAIR: { + pic_value proc; + + if (! pic_list_p(pic, obj)) { + pic_error(pic, "invalid expression given", 1, obj); + } + + proc = pic_list_ref(pic, obj, 0); + if (pic_sym_p(pic, proc)) { + pic_value sym = proc; + + if (EQ(sym, "core#lambda")) { + return analyze_lambda(pic, scope, obj); + } + else if (EQ(sym, "core#quote")) { + return obj; + } + else if (EQ(sym, "core#begin") || EQ(sym, "core#set!") || EQ(sym, "core#if")) { + return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj))); + } + } + + return analyze_call(pic, scope, obj); + } + default: + return pic_list(pic, 2, S("core#quote"), obj); + } +} + +static pic_value +analyze(pic_state *pic, analyze_scope *scope, pic_value obj) +{ + size_t ai = pic_enter(pic); + pic_value res; + + res = analyze_node(pic, scope, obj); + + pic_leave(pic, ai); + pic_protect(pic, res); + return res; +} + +static pic_value +pic_analyze(pic_state *pic, pic_value obj) +{ + analyze_scope s, *scope = &s; + + analyzer_scope_init(pic, scope, pic_nil_value(pic), pic_nil_value(pic), NULL); + + obj = analyze(pic, scope, obj); + + return obj; +} + +typedef struct codegen_context { + /* rest args variable is counted as a local */ + pic_value rest; + pic_value args, locals, captures; + /* actual bit code sequence */ + struct code *code; + size_t clen, ccapa; + /* child ireps */ + struct irep **irep; + size_t ilen, icapa; + /* constant object pool */ + int *ints; + size_t klen, kcapa; + double *nums; + size_t flen, fcapa; + struct object **pool; + size_t plen, pcapa; + + struct codegen_context *up; +} codegen_context; + +static void create_activation(pic_state *, codegen_context *); + +static void +codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_value args, pic_value locals, pic_value captures) +{ + pic_value tmp; + int i, it; + + for (i = 0, tmp = args; pic_pair_p(pic, tmp); tmp = pic_cdr(pic, tmp)) + i++; + cxt->args = pic_make_vec(pic, i, NULL); + for (i = 0, tmp = args; pic_pair_p(pic, tmp); tmp = pic_cdr(pic, tmp)) { + pic_vec_set(pic, cxt->args, i++, pic_car(pic, tmp)); + } + + cxt->rest = tmp; + + i = pic_length(pic, locals); + if (pic_sym_p(pic, cxt->rest)) { + i++; + } + cxt->locals = pic_make_vec(pic, i, NULL); + i = 0; + if (pic_sym_p(pic, cxt->rest)) { + pic_vec_set(pic, cxt->locals, i++, cxt->rest); + } + for (tmp = locals; pic_pair_p(pic, tmp); tmp = pic_cdr(pic, tmp)) { + pic_vec_set(pic, cxt->locals, i++, pic_car(pic, tmp)); + } + + cxt->captures = pic_make_vec(pic, pic_dict_size(pic, captures), NULL); + it = i = 0; + while (pic_dict_next(pic, captures, &it, &tmp, NULL)) { + pic_vec_set(pic, cxt->captures, i++, tmp); + } + + cxt->up = up; + + cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(struct code)); + cxt->clen = 0; + cxt->ccapa = PIC_ISEQ_SIZE; + + cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct irep *)); + cxt->ilen = 0; + cxt->icapa = PIC_IREP_SIZE; + + cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(struct object *)); + cxt->plen = 0; + cxt->pcapa = PIC_POOL_SIZE; + + cxt->ints = pic_calloc(pic, PIC_POOL_SIZE, sizeof(int)); + cxt->klen = 0; + cxt->kcapa = PIC_POOL_SIZE; + + cxt->nums = pic_calloc(pic, PIC_POOL_SIZE, sizeof(double)); + cxt->flen = 0; + cxt->fcapa = PIC_POOL_SIZE; + + create_activation(pic, cxt); +} + +static struct irep * +codegen_context_destroy(pic_state *pic, codegen_context *cxt) +{ + struct irep *irep; + + /* create irep */ + irep = (struct irep *)pic_obj_alloc(pic, sizeof(struct irep), PIC_TYPE_IREP); + irep->varg = pic_sym_p(pic, cxt->rest); + irep->argc = pic_vec_len(pic, cxt->args) + 1; + irep->localc = pic_vec_len(pic, cxt->locals); + irep->capturec = pic_vec_len(pic, cxt->captures); + irep->code = pic_realloc(pic, cxt->code, sizeof(struct code) * cxt->clen); + irep->irep = pic_realloc(pic, cxt->irep, sizeof(struct irep *) * cxt->ilen); + irep->ints = pic_realloc(pic, cxt->ints, sizeof(int) * cxt->klen); + irep->nums = pic_realloc(pic, cxt->nums, sizeof(double) * cxt->flen); + irep->pool = pic_realloc(pic, cxt->pool, sizeof(struct object *) * cxt->plen); + irep->ncode = cxt->clen; + irep->nirep = cxt->ilen; + irep->nints = cxt->klen; + irep->nnums = cxt->flen; + irep->npool = cxt->plen; + + return irep; +} + +#define check_size(pic, cxt, x, name, type) do { \ + if (cxt->x##len >= cxt->x##capa) { \ + cxt->x##capa *= 2; \ + cxt->name = pic_realloc(pic, cxt->name, sizeof(type) * cxt->x##capa); \ + } \ + } while (0) + +#define check_code_size(pic, cxt) check_size(pic, cxt, c, code, struct code) +#define check_irep_size(pic, cxt) check_size(pic, cxt, i, irep, struct irep *) +#define check_pool_size(pic, cxt) check_size(pic, cxt, p, pool, struct object *) +#define check_ints_size(pic, cxt) check_size(pic, cxt, k, ints, int) +#define check_nums_size(pic, cxt) check_size(pic, cxt, f, nums, double) + +#define emit_n(pic, cxt, ins) do { \ + check_code_size(pic, cxt); \ + cxt->code[cxt->clen].insn = ins; \ + cxt->clen++; \ + } while (0) \ + +#define emit_i(pic, cxt, ins, I) do { \ + check_code_size(pic, cxt); \ + cxt->code[cxt->clen].insn = ins; \ + cxt->code[cxt->clen].a = I; \ + cxt->clen++; \ + } while (0) \ + +#define emit_r(pic, cxt, ins, D, I) do { \ + check_code_size(pic, cxt); \ + cxt->code[cxt->clen].insn = ins; \ + cxt->code[cxt->clen].a = D; \ + cxt->code[cxt->clen].b = I; \ + cxt->clen++; \ + } while (0) \ + +#define emit_ret(pic, cxt, tailpos) if (tailpos) emit_n(pic, cxt, OP_RET) + +struct { + const char *name; + int insn; + int argc; +} pic_vm_proc[] = { + { "cons", OP_CONS, 2 }, + { "car", OP_CAR, 1 }, + { "cdr", OP_CDR, 1 }, + { "null?", OP_NILP, 1 }, + { "symbol?", OP_SYMBOLP, 1 }, + { "pair?", OP_PAIRP, 1 }, + { "not", OP_NOT, 1 }, + { "=", OP_EQ, 2 }, + { "<", OP_LT, 2 }, + { "<=", OP_LE, 2 }, + { ">", OP_GT, 2 }, + { ">=", OP_GE, 2 }, + { "+", OP_ADD, 2 }, + { "-", OP_SUB, 2 }, + { "*", OP_MUL, 2 }, + { "/", OP_DIV, 2 } +}; + +static int +index_capture(pic_state *pic, codegen_context *cxt, pic_value sym, int depth) +{ + int i; + + while (depth-- > 0) { + cxt = cxt->up; + } + + for (i = 0; i < pic_vec_len(pic, cxt->captures); ++i) { + if (pic_eq_p(pic, sym, pic_vec_ref(pic, cxt->captures, i))) + return i; + } + return -1; +} + +static int +index_local(pic_state *pic, codegen_context *cxt, pic_value sym) +{ + int i, offset; + + offset = 1; + for (i = 0; i < pic_vec_len(pic, cxt->args); ++i) { + if (pic_eq_p(pic, sym, pic_vec_ref(pic, cxt->args, i))) + return i + offset; + } + offset += i; + for (i = 0; i < pic_vec_len(pic, cxt->locals); ++i) { + if (pic_eq_p(pic, sym, pic_vec_ref(pic, cxt->locals, i))) + return i + offset; + } + return -1; +} + +static int +index_global(pic_state *pic, codegen_context *cxt, pic_value name) +{ + int pidx; + + check_pool_size(pic, cxt); + pidx = (int)cxt->plen++; + cxt->pool[pidx] = (struct object *)pic_sym_ptr(pic, name); + + return pidx; +} + +static void +create_activation(pic_state *pic, codegen_context *cxt) +{ + int i, n; + + for (i = 0; i < pic_vec_len(pic, cxt->captures); ++i) { + pic_value sym = pic_vec_ref(pic, cxt->captures, i); + n = index_local(pic, cxt, sym); + assert(n != -1); + if (n <= pic_vec_len(pic, cxt->args) || pic_eq_p(pic, sym, cxt->rest)) { + /* copy arguments to capture variable area */ + emit_i(pic, cxt, OP_LREF, n); + } else { + /* otherwise, just extend the stack */ + emit_n(pic, cxt, OP_PUSHUNDEF); + } + } +} + +static void codegen(pic_state *, codegen_context *, pic_value, bool); + +static void +codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + pic_value sym; + + sym = pic_car(pic, obj); + if (EQ(sym, "core#gref")) { + pic_value name; + + name = pic_list_ref(pic, obj, 1); + emit_i(pic, cxt, OP_GREF, index_global(pic, cxt, name)); + emit_ret(pic, cxt, tailpos); + } + else if (EQ(sym, "core#cref")) { + pic_value name; + int depth; + + depth = pic_int(pic, pic_list_ref(pic, obj, 1)); + name = pic_list_ref(pic, obj, 2); + emit_r(pic, cxt, OP_CREF, depth, index_capture(pic, cxt, name, depth)); + emit_ret(pic, cxt, tailpos); + } + else if (EQ(sym, "core#lref")) { + pic_value name; + int i; + + name = pic_list_ref(pic, obj, 1); + if ((i = index_capture(pic, cxt, name, 0)) != -1) { + emit_i(pic, cxt, OP_LREF, i + pic_vec_len(pic, cxt->args) + pic_vec_len(pic, cxt->locals) + 1); + emit_ret(pic, cxt, tailpos); + } else { + emit_i(pic, cxt, OP_LREF, index_local(pic, cxt, name)); + emit_ret(pic, cxt, tailpos); + } + } +} + +static void +codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + pic_value var, val; + pic_value type; + + val = pic_list_ref(pic, obj, 2); + codegen(pic, cxt, val, false); + + var = pic_list_ref(pic, obj, 1); + type = pic_list_ref(pic, var, 0); + if (EQ(type, "core#gref")) { + pic_value name; + size_t i; + + name = pic_list_ref(pic, var, 1); + + for (i = 0; i < sizeof pic_vm_proc / sizeof pic_vm_proc[0]; ++i) { + if (EQ(name, pic_vm_proc[i].name)) + pic_error(pic, "tried to override built-in procedure", 1, name); + } + + emit_i(pic, cxt, OP_GSET, index_global(pic, cxt, name)); + emit_ret(pic, cxt, tailpos); + } + else if (EQ(type, "core#cref")) { + pic_value name; + int depth; + + depth = pic_int(pic, pic_list_ref(pic, var, 1)); + name = pic_list_ref(pic, var, 2); + emit_r(pic, cxt, OP_CSET, depth, index_capture(pic, cxt, name, depth)); + emit_ret(pic, cxt, tailpos); + } + else if (EQ(type, "core#lref")) { + pic_value name; + int i; + + name = pic_list_ref(pic, var, 1); + if ((i = index_capture(pic, cxt, name, 0)) != -1) { + emit_i(pic, cxt, OP_LSET, i + pic_vec_len(pic, cxt->args) + pic_vec_len(pic, cxt->locals) + 1); + emit_ret(pic, cxt, tailpos); + } else { + emit_i(pic, cxt, OP_LSET, index_local(pic, cxt, name)); + emit_ret(pic, cxt, tailpos); + } + } +} + +static void +codegen_lambda(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + codegen_context c, *inner_cxt = &c; + pic_value args, locals, captures, body; + + check_irep_size(pic, cxt); + + /* extract arguments */ + args = pic_list_ref(pic, obj, 1); + locals = pic_list_ref(pic, obj, 2); + captures = pic_list_ref(pic, obj, 3); + body = pic_list_ref(pic, obj, 4); + + /* emit irep */ + codegen_context_init(pic, inner_cxt, cxt, args, locals, captures); + codegen(pic, inner_cxt, body, true); + cxt->irep[cxt->ilen] = codegen_context_destroy(pic, inner_cxt); + + /* emit OP_LAMBDA */ + emit_i(pic, cxt, OP_LAMBDA, cxt->ilen++); + emit_ret(pic, cxt, tailpos); +} + +static void +codegen_if(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + int s, t; + + codegen(pic, cxt, pic_list_ref(pic, obj, 1), false); + + s = (int)cxt->clen; + + emit_n(pic, cxt, OP_JMPIF); + + /* if false branch */ + codegen(pic, cxt, pic_list_ref(pic, obj, 3), tailpos); + + t = (int)cxt->clen; + + emit_n(pic, cxt, OP_JMP); + + cxt->code[s].a = (int)cxt->clen - s; + + /* if true branch */ + codegen(pic, cxt, pic_list_ref(pic, obj, 2), tailpos); + cxt->code[t].a = (int)cxt->clen - t; +} + +static void +codegen_begin(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + codegen(pic, cxt, pic_list_ref(pic, obj, 1), false); + emit_n(pic, cxt, OP_POP); + codegen(pic, cxt, pic_list_ref(pic, obj, 2), tailpos); +} + +static void +codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + int pidx; + + obj = pic_list_ref(pic, obj, 1); + switch (pic_type(pic, obj)) { + case PIC_TYPE_UNDEF: + emit_n(pic, cxt, OP_PUSHUNDEF); + break; + case PIC_TYPE_TRUE: + emit_n(pic, cxt, OP_PUSHTRUE); + break; + case PIC_TYPE_FALSE: + emit_n(pic, cxt, OP_PUSHFALSE); + break; + case PIC_TYPE_INT: + check_ints_size(pic, cxt); + pidx = (int)cxt->klen++; + cxt->ints[pidx] = pic_int(pic, obj); + emit_i(pic, cxt, OP_PUSHINT, pidx); + break; + case PIC_TYPE_FLOAT: + check_nums_size(pic, cxt); + pidx = (int)cxt->flen++; + cxt->nums[pidx] = pic_float(pic, obj); + emit_i(pic, cxt, OP_PUSHFLOAT, pidx); + break; + case PIC_TYPE_NIL: + emit_n(pic, cxt, OP_PUSHNIL); + break; + case PIC_TYPE_EOF: + emit_n(pic, cxt, OP_PUSHEOF); + break; + case PIC_TYPE_CHAR: + check_ints_size(pic, cxt); + pidx = (int)cxt->klen++; + cxt->ints[pidx] = pic_char(pic, obj); + emit_i(pic, cxt, OP_PUSHCHAR, pidx); + break; + default: + assert(obj_p(pic,obj)); + check_pool_size(pic, cxt); + pidx = (int)cxt->plen++; + cxt->pool[pidx] = obj_ptr(pic, obj); + emit_i(pic, cxt, OP_PUSHCONST, pidx); + break; + } + emit_ret(pic, cxt, tailpos); +} + +static void +codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + int len = pic_length(pic, obj); + pic_value elt, it, functor; + + functor = pic_list_ref(pic, obj, 1); + if (EQ(pic_list_ref(pic, functor, 0), "core#gref")) { + pic_value sym; + size_t i; + + sym = pic_list_ref(pic, functor, 1); + + for (i = 0; i < sizeof pic_vm_proc / sizeof pic_vm_proc[0]; ++i) { + if (EQ(sym, pic_vm_proc[i].name) && len == pic_vm_proc[i].argc + 2) { + pic_for_each (elt, pic_cddr(pic, obj), it) { + codegen(pic, cxt, elt, false); + } + emit_n(pic, cxt, pic_vm_proc[i].insn); + emit_ret(pic, cxt, tailpos); + return; + } + } + } + + pic_for_each (elt, pic_cdr(pic, obj), it) { + codegen(pic, cxt, elt, false); + } + emit_i(pic, cxt, (tailpos ? OP_TAILCALL : OP_CALL), len - 1); +} + +static void +codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos) +{ + pic_value sym; + + sym = pic_car(pic, obj); + if (EQ(sym, "core#gref") || EQ(sym, "core#cref") || EQ(sym, "core#lref")) { + codegen_ref(pic, cxt, obj, tailpos); + } + else if (EQ(sym, "core#set!") || EQ(sym, "core#define")) { + codegen_set(pic, cxt, obj, tailpos); + } + else if (EQ(sym, "core#lambda")) { + codegen_lambda(pic, cxt, obj, tailpos); + } + else if (EQ(sym, "core#if")) { + codegen_if(pic, cxt, obj, tailpos); + } + else if (EQ(sym, "core#begin")) { + codegen_begin(pic, cxt, obj, tailpos); + } + else if (EQ(sym, "core#quote")) { + codegen_quote(pic, cxt, obj, tailpos); + } + else if (EQ(sym, "core#call")) { + codegen_call(pic, cxt, obj, tailpos); + } + else { + pic_error(pic, "codegen: unknown AST type", 1, obj); + } +} + +static struct irep * +pic_codegen(pic_state *pic, pic_value obj) +{ + codegen_context c, *cxt = &c; + + codegen_context_init(pic, cxt, NULL, pic_nil_value(pic), pic_nil_value(pic), pic_make_dict(pic)); + + codegen(pic, cxt, obj, true); + + return codegen_context_destroy(pic, cxt); +} + +#define SAVE(pic, ai, obj) pic_leave(pic, ai); pic_protect(pic, obj) + +pic_value +pic_load(pic_state *pic, pic_value obj) +{ + struct irep *irep; + size_t ai = pic_enter(pic); + +#if 0 + pic_printf(pic, "# input expression\n~s\n", obj); +#endif + + /* optimize */ + obj = pic_optimize(pic, obj); +#if 0 + pic_printf(pic, "## optimize completed\n~s\n", obj); +#endif + + SAVE(pic, ai, obj); + + /* normalize */ + obj = pic_normalize(pic, obj); +#if 0 + pic_printf(pic, "## normalize completed\n~s\n", obj); +#endif + + SAVE(pic, ai, obj); + + /* analyze */ + obj = pic_analyze(pic, obj); +#if 0 + pic_printf(pic, "## analyzer completed\n~s\n", obj); +#endif + + SAVE(pic, ai, obj); + + /* codegen */ + irep = pic_codegen(pic, obj); + + return pic_call(pic, pic_make_proc_irep(pic, irep, NULL), 0); +} + void -pic_load_cstr(pic_state *pic, const char *str) +pic_load_native(pic_state *pic, const char *str) { pic_value e, port = pic_fmemopen(pic, str, strlen(str), "r"); pic_try { - pic_load(pic, port); + size_t ai = pic_enter(pic); + + while (1) { + pic_value form = pic_read(pic, port); + if (pic_eof_p(pic, form)) { + break; + } + pic_load(pic, form); + pic_leave(pic, ai); + } } pic_catch(e) { pic_fclose(pic, port); @@ -31,3 +895,19 @@ pic_load_cstr(pic_state *pic, const char *str) } pic_fclose(pic, port); } + +static pic_value +pic_load_load(pic_state *pic) +{ + pic_value program; + + pic_get_args(pic, "o", &program); + + return pic_load(pic, program); +} + +void +pic_init_load(pic_state *pic) +{ + pic_defun(pic, "load", pic_load_load); +} diff --git a/lib/include/picrin/extra.h b/lib/include/picrin/extra.h index deefebb6..ff10c2aa 100644 --- a/lib/include/picrin/extra.h +++ b/lib/include/picrin/extra.h @@ -17,25 +17,22 @@ void *pic_default_allocf(void *, void *, size_t); pic_value pic_read(pic_state *, pic_value port); pic_value pic_read_cstr(pic_state *, const char *); -void pic_load(pic_state *, pic_value port); -void pic_load_cstr(pic_state *, const char *); - #if PIC_USE_STDIO pic_value pic_fopen(pic_state *, FILE *, const char *mode); #endif -pic_value pic_compile(pic_state *, pic_value); +pic_value pic_compile(pic_state *, pic_value form, pic_value env); +pic_value pic_load(pic_state *, pic_value irep); +void pic_load_native(pic_state *pic, const char *); /* * library */ -#if PIC_USE_LIBRARY void pic_deflibrary(pic_state *, const char *lib); void pic_in_library(pic_state *, const char *lib); void pic_export(pic_state *, int n, ...); -#endif /* for debug */ diff --git a/lib/state.c b/lib/state.c index bed2e830..55e45a71 100644 --- a/lib/state.c +++ b/lib/state.c @@ -98,7 +98,7 @@ void pic_init_write(pic_state *); void pic_init_read(pic_state *); void pic_init_dict(pic_state *); void pic_init_record(pic_state *); -void pic_init_eval(pic_state *); +void pic_init_compile(pic_state *); void pic_init_weak(pic_state *); void pic_boot(pic_state *); @@ -127,7 +127,7 @@ pic_init_core(pic_state *pic) pic_init_read(pic); DONE; pic_init_dict(pic); DONE; pic_init_record(pic); DONE; - pic_init_eval(pic); DONE; + pic_init_compile(pic); DONE; pic_init_weak(pic); DONE; #if PIC_USE_WRITE diff --git a/piclib/library.scm b/piclib/library.scm index c84202f0..617edf80 100644 --- a/piclib/library.scm +++ b/piclib/library.scm @@ -32,7 +32,7 @@ (string->symbol (join (map ->string name) ".")))) (define current-library - (make-parameter '(picrin base) mangle)) + (make-parameter '(picrin user) mangle)) (define *libraries* (make-dictionary)) diff --git a/tools/mkboot.scm b/tools/mkboot.scm index fbca5cec..fa1a0611 100644 --- a/tools/mkboot.scm +++ b/tools/mkboot.scm @@ -64,9 +64,9 @@ "void" "pic_boot(pic_state *pic)" "{" - " pic_call(pic, pic_compile(pic, pic_read_cstr(pic, &boot_rom[0][0])), 0);" + " pic_load_native(pic, &boot_rom[0][0]);" "#if PIC_USE_LIBRARY" - " pic_call(pic, pic_compile(pic, pic_read_cstr(pic, &boot_library_rom[0][0])), 0);" + " pic_load_native(pic, &boot_library_rom[0][0]);" "#endif" "}")) diff --git a/tools/mkinit.pl b/tools/mkinit.pl index d559db27..8b155682 100755 --- a/tools/mkinit.pl +++ b/tools/mkinit.pl @@ -18,13 +18,13 @@ pic_init_contrib(pic_state *pic) EOL foreach my $lib (@ARGV) { - print " void pic_init_$lib(pic_state *);\n"; + print " void pic_nitro_init_$lib(pic_state *);\n"; } print; foreach my $lib (@ARGV) { - print " pic_init_$lib(pic);\n"; + print " pic_nitro_init_$lib(pic);\n"; } print <