add load&compile functions
This commit is contained in:
Yuichi Nishiwaki
parent
b9cfbe8276
commit
d776adba34
2
Makefile
2
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\
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
896
lib/ext/load.c
896
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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
"}"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <<EOL;
|
||||
|
|
|
|||
|
|
@ -14,6 +14,27 @@ print <<EOL;
|
|||
#include "picrin.h"
|
||||
#include "picrin/extra.h"
|
||||
|
||||
void
|
||||
pic_eval_native(pic_state *pic, const char *str)
|
||||
{
|
||||
pic_value port = pic_fmemopen(pic, str, strlen(str), "r"), e;
|
||||
|
||||
pic_try {
|
||||
size_t ai = pic_enter(pic);
|
||||
pic_value form;
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
EOL
|
||||
|
||||
foreach my $file (@ARGV) {
|
||||
|
|
@ -50,7 +71,7 @@ EOL
|
|||
my $var = &escape_v($file);
|
||||
my $basename = basename($file);
|
||||
my $dirname = basename(dirname($file));
|
||||
print " pic_load_cstr(pic, &${var}[0][0]);\n";
|
||||
print " pic_eval_native(pic, &${var}[0][0]);\n";
|
||||
print<<EOL
|
||||
}
|
||||
pic_catch(e) {
|
||||
|
|
|
|||
Loading…
Reference in New Issue