conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'improved-hygiene2'

This commit is contained in:
Yuichi Nishiwaki 2015-06-16 21:24:39 +09:00
parent 015971ffc4 7dd0e01b70
commit 6c821105fd
26 changed files with 1786 additions and 1567 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
contrib/05.r7rs/scheme/case-lambda.scm
View File

@ -1,28 +1,25 @@
(define-library (scheme case-lambda) (define-library (scheme case-lambda)
(import (scheme base)) (import (scheme base))
(define (length+ list)
(if (pair? list)
(+ 1 (length+ (cdr list)))
0))
(define-syntax case-lambda (define-syntax case-lambda
(syntax-rules () (syntax-rules ()
((case-lambda (params body0 ...) ...) ((case-lambda (params body0 ...) ...)
(lambda args (lambda args
(let ((len (length args))) (let ((len (length args)))
(letrec-syntax (letrec-syntax
((cl (syntax-rules ::: () ((cl (syntax-rules ()
((cl) ((cl)
(error "no matching clause")) (error "no matching clause"))
((cl ((p :::) . body) . rest) ((cl (formal . body) . rest)
(if (= len (length '(p :::))) (if (if (list? 'formal)
(apply (lambda (p :::) (= len (length 'formal))
. body) (>= len (length+ 'formal)))
args) (apply (lambda formal . body) args)
(cl . rest)))
((cl ((p ::: . tail) . body)
. rest)
(if (>= len (length '(p :::)))
(apply
(lambda (p ::: . tail)
. body)
args)
(cl . rest)))))) (cl . rest))))))
(cl (params body0 ...) ...))))))) (cl (params body0 ...) ...)))))))

10
extlib/benz/bool.c
View File

@ -104,6 +104,14 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
} }
return true; return true;
} }
case PIC_TT_ID: {
struct pic_id *id1, *id2;
id1 = pic_id_ptr(x);
id2 = pic_id_ptr(y);
return pic_eq_p(pic_expand(pic, id1->var, id1->env), pic_expand(pic, id2->var, id2->env));
}
default: default:
return false; return false;
} }
@ -195,7 +203,7 @@ pic_init_bool(pic_state *pic)
pic_defun(pic, "eqv?", pic_bool_eqv_p); pic_defun(pic, "eqv?", pic_bool_eqv_p);
pic_defun(pic, "equal?", pic_bool_equal_p); pic_defun(pic, "equal?", pic_bool_equal_p);
pic_defun_vm(pic, "not", pic->rNOT, pic_bool_not); pic_defun_vm(pic, "not", pic->uNOT, pic_bool_not);
pic_defun(pic, "boolean?", pic_bool_boolean_p); pic_defun(pic, "boolean?", pic_bool_boolean_p);
pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);

1050
extlib/benz/boot.c
View File

File diff suppressed because it is too large Load Diff

401
extlib/benz/codegen.c
View File

@ -4,6 +4,347 @@
#include "picrin.h" #include "picrin.h"
/**
* macro expander
*/
static pic_sym *
lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env)
{
xh_entry *e;
assert(pic_var_p(var));
while (env != NULL) {
if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) {
return xh_val(e, pic_sym *);
}
env = env->up;
}
return NULL;
}
static pic_sym *
resolve(pic_state *pic, pic_value var, struct pic_env *env)
{
pic_sym *uid;
assert(pic_var_p(var));
assert(env != NULL);
while ((uid = lookup(pic, var, env)) == NULL) {
if (pic_sym_p(var)) {
break;
}
env = pic_id_ptr(var)->env;
var = pic_id_ptr(var)->var;
}
if (uid == NULL) {
while (env->up != NULL) {
env = env->up;
}
uid = pic_add_variable(pic, env, var);
}
return uid;
}
static void
define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
{
pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac));
}
static struct pic_proc *
find_macro(pic_state *pic, pic_sym *uid)
{
if (! pic_dict_has(pic, pic->macros, uid)) {
return NULL;
}
return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid));
}
static pic_value expand(pic_state *, pic_value, struct pic_env *, pic_value);
static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *);
static pic_value
expand_var(pic_state *pic, pic_value var, struct pic_env *env)
{
return pic_obj_value(resolve(pic, var, env));
}
static pic_value
expand_quote(pic_state *pic, pic_value expr)
{
return pic_cons(pic, pic_obj_value(pic->uQUOTE), pic_cdr(pic, expr));
}
static pic_value
expand_list(pic_state *pic, pic_value obj, struct pic_env *env, pic_value deferred)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value x, head, tail;
if (pic_pair_p(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_gc_arena_restore(pic, ai);
pic_gc_protect(pic, x);
return x;
}
static pic_value
expand_defer(pic_state *pic, pic_value expr, pic_value deferred)
{
pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#<invalid>) */
pic_set_car(pic, deferred, pic_acons(pic, expr, skel, pic_car(pic, deferred)));
return skel;
}
static void
expand_deferred(pic_state *pic, pic_value deferred, struct pic_env *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, struct pic_env *env)
{
pic_value formal, body;
struct pic_env *in;
pic_value a, deferred;
if (pic_length(pic, expr) < 2) {
pic_errorf(pic, "syntax error");
}
in = pic_make_env(pic, env);
for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
pic_value var = pic_car(pic, a);
if (! pic_var_p(var)) {
pic_errorf(pic, "syntax error");
}
pic_add_variable(pic, in, var);
}
if (pic_var_p(a)) {
pic_add_variable(pic, in, a);
}
else if (! pic_nil_p(a)) {
pic_errorf(pic, "syntax error");
}
deferred = pic_list1(pic, pic_nil_value());
formal = expand_list(pic, pic_cadr(pic, expr), in, deferred);
body = expand_list(pic, pic_cddr(pic, expr), in, deferred);
expand_deferred(pic, deferred, in);
return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body));
}
static pic_value
expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{
pic_sym *uid;
pic_value var, val;
while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) {
var = pic_car(pic, pic_cadr(pic, expr));
val = pic_cdr(pic, pic_cadr(pic, expr));
expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
}
if (pic_length(pic, expr) != 3) {
pic_errorf(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_var_p(var)) {
pic_errorf(pic, "binding to non-variable object");
}
if ((uid = pic_find_variable(pic, env, var)) == NULL) {
uid = pic_add_variable(pic, env, var);
}
val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred);
return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val);
}
static pic_value
expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_value var, val;
pic_sym *uid;
if (pic_length(pic, expr) != 3) {
pic_errorf(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_var_p(var)) {
pic_errorf(pic, "binding to non-variable object");
}
if ((uid = pic_find_variable(pic, env, var)) == NULL) {
uid = pic_add_variable(pic, env, var);
} else {
pic_warnf(pic, "redefining syntax variable: ~s", var);
}
val = pic_cadr(pic, pic_cdr(pic, expr));
pic_try {
val = pic_eval(pic, val, env);
} pic_catch {
pic_errorf(pic, "expand error while definition: %s", pic_errmsg(pic));
}
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
define_macro(pic, uid, pic_proc_ptr(val));
return pic_undef_value();
}
static pic_value
expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env)
{
pic_value v;
#if DEBUG
puts("before expand-1:");
pic_debug(pic, expr);
puts("");
#endif
pic_try {
v = pic_apply2(pic, mac, expr, pic_obj_value(env));
} pic_catch {
pic_errorf(pic, "expand error while application: %s", pic_errmsg(pic));
}
#if DEBUG
puts("after expand-1:");
pic_debug(pic, v);
puts("");
#endif
return v;
}
static pic_value
expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{
switch (pic_type(expr)) {
case PIC_TT_ID:
case PIC_TT_SYMBOL: {
return expand_var(pic, expr, env);
}
case PIC_TT_PAIR: {
struct pic_proc *mac;
if (! pic_list_p(expr)) {
pic_errorf(pic, "cannot expand improper list: ~s", expr);
}
if (pic_var_p(pic_car(pic, expr))) {
pic_sym *functor;
functor = resolve(pic, pic_car(pic, expr), env);
if (functor == pic->uDEFINE_MACRO) {
return expand_defmacro(pic, expr, env);
}
else if (functor == pic->uLAMBDA) {
return expand_defer(pic, expr, deferred);
}
else if (functor == pic->uDEFINE) {
return expand_define(pic, expr, env, deferred);
}
else if (functor == pic->uQUOTE) {
return expand_quote(pic, expr);
}
if ((mac = find_macro(pic, functor)) != NULL) {
return expand_node(pic, expand_macro(pic, mac, expr, env), env, deferred);
}
}
return expand_list(pic, expr, env, deferred);
}
default:
return expr;
}
}
static pic_value
expand(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v;
#if DEBUG
printf("[expand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
v = expand_node(pic, expr, env, deferred);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
return v;
}
pic_value
pic_expand(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_value v, deferred;
#if DEBUG
puts("before expand:");
pic_debug(pic, expr);
puts("");
#endif
deferred = pic_list1(pic, pic_nil_value());
v = expand(pic, expr, env, deferred);
expand_deferred(pic, deferred, env);
#if DEBUG
puts("after expand:");
pic_debug(pic, v);
puts("");
#endif
return v;
}
typedef xvect_t(pic_sym *) xvect; typedef xvect_t(pic_sym *) xvect;
#define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x)) #define xv_push_sym(v, x) xv_push(pic_sym *, (v), (x))
@ -331,7 +672,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v
: pic_false_value(); : pic_false_value();
/* To know what kind of local variables are defined, analyze body at first. */ /* To know what kind of local variables are defined, analyze body at first. */
body = analyze(state, pic_cons(pic, pic_obj_value(pic->rBEGIN), body_exprs), true); body = analyze(state, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true);
analyze_deferred(state); analyze_deferred(state);
@ -399,7 +740,7 @@ analyze_define(analyze_state *state, pic_value obj)
if (pic_pair_p(pic_list_ref(pic, obj, 2)) if (pic_pair_p(pic_list_ref(pic, obj, 2))
&& pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0))
&& pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->uLAMBDA) {
pic_value formals, body_exprs; pic_value formals, body_exprs;
formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1);
@ -698,88 +1039,88 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
if (pic_sym_p(proc)) { if (pic_sym_p(proc)) {
pic_sym *sym = pic_sym_ptr(proc); pic_sym *sym = pic_sym_ptr(proc);
if (sym == pic->rDEFINE) { if (sym == pic->uDEFINE) {
return analyze_define(state, obj); return analyze_define(state, obj);
} }
else if (sym == pic->rLAMBDA) { else if (sym == pic->uLAMBDA) {
return analyze_lambda(state, obj); return analyze_lambda(state, obj);
} }
else if (sym == pic->rIF) { else if (sym == pic->uIF) {
return analyze_if(state, obj, tailpos); return analyze_if(state, obj, tailpos);
} }
else if (sym == pic->rBEGIN) { else if (sym == pic->uBEGIN) {
return analyze_begin(state, obj, tailpos); return analyze_begin(state, obj, tailpos);
} }
else if (sym == pic->rSETBANG) { else if (sym == pic->uSETBANG) {
return analyze_set(state, obj); return analyze_set(state, obj);
} }
else if (sym == pic->rQUOTE) { else if (sym == pic->uQUOTE) {
return analyze_quote(state, obj); return analyze_quote(state, obj);
} }
else if (sym == pic->rCONS) { else if (sym == pic->uCONS) {
ARGC_ASSERT(2, "cons"); ARGC_ASSERT(2, "cons");
return CONSTRUCT_OP2(pic->sCONS); return CONSTRUCT_OP2(pic->sCONS);
} }
else if (sym == pic->rCAR) { else if (sym == pic->uCAR) {
ARGC_ASSERT(1, "car"); ARGC_ASSERT(1, "car");
return CONSTRUCT_OP1(pic->sCAR); return CONSTRUCT_OP1(pic->sCAR);
} }
else if (sym == pic->rCDR) { else if (sym == pic->uCDR) {
ARGC_ASSERT(1, "cdr"); ARGC_ASSERT(1, "cdr");
return CONSTRUCT_OP1(pic->sCDR); return CONSTRUCT_OP1(pic->sCDR);
} }
else if (sym == pic->rNILP) { else if (sym == pic->uNILP) {
ARGC_ASSERT(1, "nil?"); ARGC_ASSERT(1, "nil?");
return CONSTRUCT_OP1(pic->sNILP); return CONSTRUCT_OP1(pic->sNILP);
} }
else if (sym == pic->rSYMBOLP) { else if (sym == pic->uSYMBOLP) {
ARGC_ASSERT(1, "symbol?"); ARGC_ASSERT(1, "symbol?");
return CONSTRUCT_OP1(pic->sSYMBOLP); return CONSTRUCT_OP1(pic->sSYMBOLP);
} }
else if (sym == pic->rPAIRP) { else if (sym == pic->uPAIRP) {
ARGC_ASSERT(1, "pair?"); ARGC_ASSERT(1, "pair?");
return CONSTRUCT_OP1(pic->sPAIRP); return CONSTRUCT_OP1(pic->sPAIRP);
} }
else if (sym == pic->rADD) { else if (sym == pic->uADD) {
return analyze_add(state, obj, tailpos); return analyze_add(state, obj, tailpos);
} }
else if (sym == pic->rSUB) { else if (sym == pic->uSUB) {
return analyze_sub(state, obj); return analyze_sub(state, obj);
} }
else if (sym == pic->rMUL) { else if (sym == pic->uMUL) {
return analyze_mul(state, obj, tailpos); return analyze_mul(state, obj, tailpos);
} }
else if (sym == pic->rDIV) { else if (sym == pic->uDIV) {
return analyze_div(state, obj); return analyze_div(state, obj);
} }
else if (sym == pic->rEQ) { else if (sym == pic->uEQ) {
ARGC_ASSERT_WITH_FALLBACK(2); ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sEQ); return CONSTRUCT_OP2(pic->sEQ);
} }
else if (sym == pic->rLT) { else if (sym == pic->uLT) {
ARGC_ASSERT_WITH_FALLBACK(2); ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sLT); return CONSTRUCT_OP2(pic->sLT);
} }
else if (sym == pic->rLE) { else if (sym == pic->uLE) {
ARGC_ASSERT_WITH_FALLBACK(2); ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sLE); return CONSTRUCT_OP2(pic->sLE);
} }
else if (sym == pic->rGT) { else if (sym == pic->uGT) {
ARGC_ASSERT_WITH_FALLBACK(2); ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sGT); return CONSTRUCT_OP2(pic->sGT);
} }
else if (sym == pic->rGE) { else if (sym == pic->uGE) {
ARGC_ASSERT_WITH_FALLBACK(2); ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sGE); return CONSTRUCT_OP2(pic->sGE);
} }
else if (sym == pic->rNOT) { else if (sym == pic->uNOT) {
ARGC_ASSERT(1, "not"); ARGC_ASSERT(1, "not");
return CONSTRUCT_OP1(pic->sNOT); return CONSTRUCT_OP1(pic->sNOT);
} }
else if (sym == pic->rVALUES) { else if (sym == pic->uVALUES) {
return analyze_values(state, obj, tailpos); return analyze_values(state, obj, tailpos);
} }
else if (sym == pic->rCALL_WITH_VALUES) { else if (sym == pic->uCALL_WITH_VALUES) {
return analyze_call_with_values(state, obj, tailpos); return analyze_call_with_values(state, obj, tailpos);
} }
} }
@ -1420,7 +1761,7 @@ pic_codegen(pic_state *pic, pic_value obj)
} }
struct pic_proc * struct pic_proc *
pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
{ {
struct pic_irep *irep; struct pic_irep *irep;
size_t ai = pic_gc_arena_preserve(pic); size_t ai = pic_gc_arena_preserve(pic);
@ -1435,10 +1776,10 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib)
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif #endif
/* macroexpand */ /* expand */
obj = pic_macroexpand(pic, obj, lib); obj = pic_expand(pic, obj, env);
#if DEBUG #if DEBUG
fprintf(stdout, "## macroexpand completed\n"); fprintf(stdout, "## expand completed\n");
pic_debug(pic, obj); pic_debug(pic, obj);
fprintf(stdout, "\n"); fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));

4
extlib/benz/cont.c
View File

@ -288,6 +288,6 @@ pic_init_cont(pic_state *pic)
pic_defun(pic, "call/cc", pic_cont_callcc); pic_defun(pic, "call/cc", pic_cont_callcc);
pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values); pic_defun_vm(pic, "values", pic->uVALUES, pic_cont_values);
pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values); pic_defun_vm(pic, "call-with-values", pic->uCALL_WITH_VALUES, pic_cont_call_with_values);
} }

8
extlib/benz/eval.c
View File

@ -5,13 +5,13 @@
#include "picrin.h" #include "picrin.h"
pic_value pic_value
pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) pic_eval(pic_state *pic, pic_value program, struct pic_env *env)
{ {
struct pic_proc *proc; struct pic_proc *proc;
proc = pic_compile(pic, program, lib); proc = pic_compile(pic, program, env);
return pic_apply(pic, proc, pic_nil_value()); return pic_apply0(pic, proc);
} }
static pic_value static pic_value
@ -26,7 +26,7 @@ pic_eval_eval(pic_state *pic)
if (lib == NULL) { if (lib == NULL) {
pic_errorf(pic, "no library found: ~s", spec); pic_errorf(pic, "no library found: ~s", spec);
} }
return pic_eval(pic, program, lib); return pic_eval(pic, program, lib->env);
} }
void void

40
extlib/benz/gc.c
View File

@ -411,14 +411,23 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_BLOB: { case PIC_TT_BLOB: {
break; break;
} }
case PIC_TT_ID: {
struct pic_id *id = (struct pic_id *)obj;
gc_mark(pic, id->var);
gc_mark_object(pic, (struct pic_object *)id->env);
break;
}
case PIC_TT_ENV: { case PIC_TT_ENV: {
struct pic_env *env = (struct pic_env *)obj; struct pic_env *env = (struct pic_env *)obj;
xh_entry *it;
if (env->up) { if (env->up) {
gc_mark_object(pic, (struct pic_object *)env->up); gc_mark_object(pic, (struct pic_object *)env->up);
} }
gc_mark(pic, env->defer); for (it = xh_begin(&env->map); it != NULL; it = xh_next(it)) {
gc_mark_object(pic, (struct pic_object *)env->map); gc_mark_object(pic, xh_key(it, struct pic_object *));
gc_mark_object(pic, xh_val(it, struct pic_object *));
}
break; break;
} }
case PIC_TT_LIB: { case PIC_TT_LIB: {
@ -519,7 +528,9 @@ gc_mark_global_symbols(pic_state *pic)
{ {
M(sDEFINE); M(sLAMBDA); M(sIF); M(sBEGIN); M(sQUOTE); M(sSETBANG); M(sDEFINE); M(sLAMBDA); M(sIF); M(sBEGIN); M(sQUOTE); M(sSETBANG);
M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING); M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING);
M(sDEFINE_SYNTAX); M(sIMPORT); M(sEXPORT); M(sSYNTAX_QUOTE); M(sSYNTAX_QUASIQUOTE); M(sSYNTAX_UNQUOTE);
M(sSYNTAX_UNQUOTE_SPLICING);
M(sDEFINE_MACRO); M(sIMPORT); M(sEXPORT);
M(sDEFINE_LIBRARY); M(sDEFINE_LIBRARY);
M(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY); M(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY);
M(sONLY); M(sRENAME); M(sPREFIX); M(sEXCEPT); M(sONLY); M(sRENAME); M(sPREFIX); M(sEXCEPT);
@ -531,15 +542,15 @@ gc_mark_global_symbols(pic_state *pic)
M(sCALL); M(sTAILCALL); M(sCALL_WITH_VALUES); M(sTAILCALL_WITH_VALUES); M(sCALL); M(sTAILCALL); M(sCALL_WITH_VALUES); M(sTAILCALL_WITH_VALUES);
M(sGREF); M(sLREF); M(sCREF); M(sRETURN); M(sGREF); M(sLREF); M(sCREF); M(sRETURN);
M(rDEFINE); M(rLAMBDA); M(rIF); M(rBEGIN); M(rQUOTE); M(rSETBANG); M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG);
M(rDEFINE_SYNTAX); M(rIMPORT); M(rEXPORT); M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT);
M(rDEFINE_LIBRARY); M(uDEFINE_LIBRARY);
M(rCOND_EXPAND); M(uCOND_EXPAND);
M(rCONS); M(rCAR); M(rCDR); M(rNILP); M(uCONS); M(uCAR); M(uCDR); M(uNILP);
M(rSYMBOLP); M(rPAIRP); M(uSYMBOLP); M(uPAIRP);
M(rADD); M(rSUB); M(rMUL); M(rDIV); M(uADD); M(uSUB); M(uMUL); M(uDIV);
M(rEQ); M(rLT); M(rLE); M(rGT); M(rGE); M(rNOT); M(uEQ); M(uLT); M(uLE); M(uGT); M(uGE); M(uNOT);
M(rVALUES); M(rCALL_WITH_VALUES); M(uVALUES); M(uCALL_WITH_VALUES);
} }
static void static void
@ -681,7 +692,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_ERROR: { case PIC_TT_ERROR: {
break; break;
} }
case PIC_TT_ID: {
break;
}
case PIC_TT_ENV: { case PIC_TT_ENV: {
struct pic_env *env = (struct pic_env *)obj;
xh_destroy(&env->map);
break; break;
} }
case PIC_TT_LIB: { case PIC_TT_LIB: {

31
extlib/benz/include/picrin.h
View File

@ -98,7 +98,9 @@ typedef struct {
pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG; pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG;
pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING; pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT; pic_sym *sSYNTAX_QUOTE, *sSYNTAX_QUASIQUOTE, *sSYNTAX_UNQUOTE;
pic_sym *sSYNTAX_UNQUOTE_SPLICING;
pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT;
pic_sym *sDEFINE_LIBRARY; pic_sym *sDEFINE_LIBRARY;
pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY; pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY;
pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT; pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT;
@ -111,15 +113,15 @@ typedef struct {
pic_sym *sCALL, *sTAILCALL, *sRETURN; pic_sym *sCALL, *sTAILCALL, *sRETURN;
pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES; pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES;
pic_sym *rDEFINE, *rLAMBDA, *rIF, *rBEGIN, *rQUOTE, *rSETBANG; pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG;
pic_sym *rDEFINE_SYNTAX, *rIMPORT, *rEXPORT; pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT;
pic_sym *rDEFINE_LIBRARY; pic_sym *uDEFINE_LIBRARY;
pic_sym *rCOND_EXPAND; pic_sym *uCOND_EXPAND;
pic_sym *rCONS, *rCAR, *rCDR, *rNILP; pic_sym *uCONS, *uCAR, *uCDR, *uNILP;
pic_sym *rSYMBOLP, *rPAIRP; pic_sym *uSYMBOLP, *uPAIRP;
pic_sym *rADD, *rSUB, *rMUL, *rDIV; pic_sym *uADD, *uSUB, *uMUL, *uDIV;
pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT; pic_sym *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
pic_sym *rVALUES, *rCALL_WITH_VALUES; pic_sym *uVALUES, *uCALL_WITH_VALUES;
struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_BASE;
struct pic_lib *PICRIN_USER; struct pic_lib *PICRIN_USER;
@ -127,6 +129,7 @@ typedef struct {
pic_value features; pic_value features;
xhash syms; /* name to symbol */ xhash syms; /* name to symbol */
int ucnt;
struct pic_dict *globals; struct pic_dict *globals;
struct pic_dict *macros; struct pic_dict *macros;
pic_value libs; pic_value libs;
@ -193,8 +196,6 @@ bool pic_equal_p(pic_state *, pic_value, pic_value);
pic_sym *pic_intern(pic_state *, pic_str *); pic_sym *pic_intern(pic_state *, pic_str *);
pic_sym *pic_intern_cstr(pic_state *, const char *); pic_sym *pic_intern_cstr(pic_state *, const char *);
const char *pic_symbol_name(pic_state *, pic_sym *); const char *pic_symbol_name(pic_state *, pic_sym *);
pic_sym *pic_gensym(pic_state *, pic_sym *);
bool pic_interned_p(pic_state *, pic_sym *);
pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read(pic_state *, struct pic_port *);
pic_value pic_read_cstr(pic_state *, const char *); pic_value pic_read_cstr(pic_state *, const char *);
@ -214,9 +215,9 @@ pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v
pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value); pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value);
pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value); pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value);
pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value); pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value);
pic_value pic_eval(pic_state *, pic_value, struct pic_lib *); pic_value pic_eval(pic_state *, pic_value, struct pic_env *);
struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *); pic_value pic_expand(pic_state *, pic_value, struct pic_env *);
pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *); struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_env *);
struct pic_lib *pic_make_library(pic_state *, pic_value); struct pic_lib *pic_make_library(pic_state *, pic_value);
struct pic_lib *pic_find_library(pic_state *, pic_value); struct pic_lib *pic_find_library(pic_state *, pic_value);

27
extlib/benz/include/picrin/macro.h
View File

@ -9,24 +9,35 @@
extern "C" { extern "C" {
#endif #endif
struct pic_id {
PIC_OBJECT_HEADER
pic_value var;
struct pic_env *env;
};
struct pic_env { struct pic_env {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
struct pic_dict *map; xhash map;
pic_value defer;
struct pic_env *up; struct pic_env *up;
}; };
#define pic_id_p(v) (pic_type(v) == PIC_TT_ID)
#define pic_id_ptr(v) ((struct pic_id *)pic_ptr(v))
#define pic_env_p(v) (pic_type(v) == PIC_TT_ENV) #define pic_env_p(v) (pic_type(v) == PIC_TT_ENV)
#define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) #define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v))
bool pic_identifier_p(pic_state *pic, pic_value obj); struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *);
bool pic_identifier_eq_p(pic_state *, struct pic_env *, pic_sym *, struct pic_env *, pic_sym *);
struct pic_env *pic_make_env(pic_state *, struct pic_env *); struct pic_env *pic_make_env(pic_state *, struct pic_env *);
pic_sym *pic_add_rename(pic_state *, struct pic_env *, pic_sym *); pic_sym *pic_uniq(pic_state *, pic_value);
pic_sym *pic_find_rename(pic_state *, struct pic_env *, pic_sym *);
void pic_put_rename(pic_state *, struct pic_env *, pic_sym *, pic_sym *); pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value);
void pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *);
pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value);
bool pic_var_p(pic_value);
pic_sym *pic_var_name(pic_state *, pic_value);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

4
extlib/benz/include/picrin/value.h
View File

@ -157,6 +157,7 @@ enum pic_tt {
PIC_TT_PROC, PIC_TT_PROC,
PIC_TT_PORT, PIC_TT_PORT,
PIC_TT_ERROR, PIC_TT_ERROR,
PIC_TT_ID,
PIC_TT_CXT, PIC_TT_CXT,
PIC_TT_ENV, PIC_TT_ENV,
PIC_TT_LIB, PIC_TT_LIB,
@ -183,6 +184,7 @@ struct pic_blob;
struct pic_proc; struct pic_proc;
struct pic_port; struct pic_port;
struct pic_error; struct pic_error;
struct pic_env;
/* set aliases to basic types */ /* set aliases to basic types */
typedef pic_value pic_list; typedef pic_value pic_list;
@ -314,6 +316,8 @@ pic_type_repr(enum pic_tt tt)
return "port"; return "port";
case PIC_TT_ERROR: case PIC_TT_ERROR:
return "error"; return "error";
case PIC_TT_ID:
return "id";
case PIC_TT_CXT: case PIC_TT_CXT:
return "cxt"; return "cxt";
case PIC_TT_PROC: case PIC_TT_PROC:

28
extlib/benz/lib.c
View File

@ -9,10 +9,10 @@ setup_default_env(pic_state *pic, struct pic_env *env)
{ {
void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *);
pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY);
pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->rIMPORT); pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->uIMPORT);
pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->rEXPORT); pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->uEXPORT);
pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->rCOND_EXPAND); pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->uCOND_EXPAND);
} }
struct pic_lib * struct pic_lib *
@ -110,14 +110,14 @@ import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
pic_errorf(pic, "library not found: ~a", spec); pic_errorf(pic, "library not found: ~a", spec);
} }
pic_dict_for_each (nick, lib->exports, iter) { pic_dict_for_each (nick, lib->exports, iter) {
pic_sym *realname, *rename; pic_sym *realname, *uid;
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick)); realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick));
if ((rename = pic_find_rename(pic, lib->env, realname)) == NULL) { if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
} }
pic_dict_set(pic, imports, nick, pic_obj_value(rename)); pic_dict_set(pic, imports, nick, pic_obj_value(uid));
} }
} }
@ -133,7 +133,7 @@ import(pic_state *pic, pic_value spec)
import_table(pic, spec, imports); import_table(pic, spec, imports);
pic_dict_for_each (sym, imports, it) { pic_dict_for_each (sym, imports, it) {
pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym))); pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym)));
} }
} }
@ -245,7 +245,7 @@ pic_lib_condexpand(pic_state *pic)
for (i = 0; i < argc; i++) { for (i = 0; i < argc; i++) {
if (condexpand(pic, pic_car(pic, clauses[i]))) { if (condexpand(pic, pic_car(pic, clauses[i]))) {
return pic_cons(pic, pic_obj_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); return pic_cons(pic, pic_obj_value(pic->sBEGIN), pic_cdr(pic, clauses[i]));
} }
} }
@ -299,7 +299,7 @@ pic_lib_define_library(pic_state *pic)
pic->lib = lib; pic->lib = lib;
for (i = 0; i < argc; ++i) { for (i = 0; i < argc; ++i) {
pic_void(pic_eval(pic, argv[i], pic->lib)); pic_void(pic_eval(pic, argv[i], pic->lib->env));
} }
pic->lib = prev; pic->lib = prev;
@ -317,8 +317,8 @@ pic_init_lib(pic_state *pic)
{ {
void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t); void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t);
pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand); pic_defmacro(pic, pic->sCOND_EXPAND, pic->uCOND_EXPAND, pic_lib_condexpand);
pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import); pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import);
pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export); pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export);
pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library); pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY, pic_lib_define_library);
} }

2
extlib/benz/load.c
View File

@ -13,7 +13,7 @@ pic_load_port(pic_state *pic, struct pic_port *port)
size_t ai = pic_gc_arena_preserve(pic); size_t ai = pic_gc_arena_preserve(pic);
while (! pic_eof_p(form = pic_read(pic, port))) { while (! pic_eof_p(form = pic_read(pic, port))) {
pic_eval(pic, form, pic->lib); pic_eval(pic, form, pic->lib->env);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
} }

521
extlib/benz/macro.c
View File

@ -4,434 +4,92 @@
#include "picrin.h" #include "picrin.h"
pic_sym * bool
pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym) pic_var_p(pic_value obj)
{ {
pic_sym *rename = pic_gensym(pic, sym); return pic_sym_p(obj) || pic_id_p(obj);
pic_put_rename(pic, env, sym, rename);
return rename;
} }
void struct pic_id *
pic_put_rename(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rename) pic_make_id(pic_state *pic, pic_value var, struct pic_env *env)
{ {
pic_dict_set(pic, env->map, sym, pic_obj_value(rename)); struct pic_id *id;
}
pic_sym * assert(pic_var_p(var));
pic_find_rename(pic_state *pic, struct pic_env *env, pic_sym *sym)
{
if (! pic_dict_has(pic, env->map, sym)) {
return NULL;
}
return pic_sym_ptr(pic_dict_ref(pic, env->map, sym));
}
static void id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID);
define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac) id->var = var;
{ id->env = env;
pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac)); return id;
}
static struct pic_proc *
find_macro(pic_state *pic, pic_sym *rename)
{
if (! pic_dict_has(pic, pic->macros, rename)) {
return NULL;
}
return pic_proc_ptr(pic_dict_ref(pic, pic->macros, rename));
}
static pic_sym *
make_identifier(pic_state *pic, pic_sym *sym, struct pic_env *env)
{
pic_sym *rename;
while (true) {
if ((rename = pic_find_rename(pic, env, sym)) != NULL) {
return rename;
}
if (! env->up)
break;
env = env->up;
}
if (! pic_interned_p(pic, sym)) {
return sym;
}
else {
return pic_gensym(pic, sym);
}
}
static pic_value macroexpand(pic_state *, pic_value, struct pic_env *);
static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_env *);
static pic_value
macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_env *env)
{
return pic_obj_value(make_identifier(pic, sym, env));
}
static pic_value
macroexpand_quote(pic_state *pic, pic_value expr)
{
return pic_cons(pic, pic_obj_value(pic->rQUOTE), pic_cdr(pic, expr));
}
static pic_value
macroexpand_list(pic_state *pic, pic_value obj, struct pic_env *env)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value x, head, tail;
if (pic_pair_p(obj)) {
head = macroexpand(pic, pic_car(pic, obj), env);
tail = macroexpand_list(pic, pic_cdr(pic, obj), env);
x = pic_cons(pic, head, tail);
} else {
x = macroexpand(pic, obj, env);
}
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, x);
return x;
}
static pic_value
macroexpand_defer(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_value skel = pic_list1(pic, pic_invalid_value()); /* (#<invalid>) */
pic_push(pic, pic_cons(pic, expr, skel), env->defer);
return skel;
}
static void
macroexpand_deferred(pic_state *pic, struct pic_env *env)
{
pic_value defer, val, src, dst, it;
pic_for_each (defer, pic_reverse(pic, env->defer), it) {
src = pic_car(pic, defer);
dst = pic_cdr(pic, defer);
val = macroexpand_lambda(pic, src, env);
/* copy */
pic_pair_ptr(dst)->car = pic_car(pic, val);
pic_pair_ptr(dst)->cdr = pic_cdr(pic, val);
}
env->defer = pic_nil_value();
}
static pic_value
macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_value formal, body;
struct pic_env *in;
pic_value a;
if (pic_length(pic, expr) < 2) {
pic_errorf(pic, "syntax error");
}
in = pic_make_env(pic, env);
for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
pic_value v = pic_car(pic, a);
if (! pic_sym_p(v)) {
pic_errorf(pic, "syntax error");
}
pic_add_rename(pic, in, pic_sym_ptr(v));
}
if (pic_sym_p(a)) {
pic_add_rename(pic, in, pic_sym_ptr(a));
}
else if (! pic_nil_p(a)) {
pic_errorf(pic, "syntax error");
}
formal = macroexpand_list(pic, pic_cadr(pic, expr), in);
body = macroexpand_list(pic, pic_cddr(pic, expr), in);
macroexpand_deferred(pic, in);
return pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, formal, body));
}
static pic_value
macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_sym *sym, *rename;
pic_value var, val;
while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) {
var = pic_car(pic, pic_cadr(pic, expr));
val = pic_cdr(pic, pic_cadr(pic, expr));
expr = pic_list3(pic, pic_obj_value(pic->rDEFINE), var, pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
}
if (pic_length(pic, expr) != 3) {
pic_errorf(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_sym_p(var)) {
pic_errorf(pic, "binding to non-symbol object");
}
sym = pic_sym_ptr(var);
if ((rename = pic_find_rename(pic, env, sym)) == NULL) {
rename = pic_add_rename(pic, env, sym);
}
val = macroexpand(pic, pic_list_ref(pic, expr, 2), env);
return pic_list3(pic, pic_obj_value(pic->rDEFINE), pic_obj_value(rename), val);
}
static pic_value
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env)
{
pic_value var, val;
pic_sym *sym, *rename;
if (pic_length(pic, expr) != 3) {
pic_errorf(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_sym_p(var)) {
pic_errorf(pic, "binding to non-symbol object");
}
sym = pic_sym_ptr(var);
if ((rename = pic_find_rename(pic, env, sym)) == NULL) {
rename = pic_add_rename(pic, env, sym);
} else {
pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym));
}
val = pic_cadr(pic, pic_cdr(pic, expr));
pic_try {
val = pic_eval(pic, val, pic->lib);
} pic_catch {
pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
}
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
val = pic_apply1(pic, pic_proc_ptr(val), pic_obj_value(env));
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
define_macro(pic, rename, pic_proc_ptr(val));
return pic_undef_value();
}
static pic_value
macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env)
{
pic_value v, args;
#if DEBUG
puts("before expand-1:");
pic_debug(pic, expr);
puts("");
#endif
args = pic_list2(pic, expr, pic_obj_value(env));
pic_try {
v = pic_apply(pic, mac, args);
} pic_catch {
pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
}
#if DEBUG
puts("after expand-1:");
pic_debug(pic, v);
puts("");
#endif
return v;
}
static pic_value
macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env)
{
switch (pic_type(expr)) {
case PIC_TT_SYMBOL: {
return macroexpand_symbol(pic, pic_sym_ptr(expr), env);
}
case PIC_TT_PAIR: {
pic_value car;
struct pic_proc *mac;
if (! pic_list_p(expr)) {
pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
}
car = macroexpand(pic, pic_car(pic, expr), env);
if (pic_sym_p(car)) {
pic_sym *tag = pic_sym_ptr(car);
if (tag == pic->rDEFINE_SYNTAX) {
return macroexpand_defsyntax(pic, expr, env);
}
else if (tag == pic->rLAMBDA) {
return macroexpand_defer(pic, expr, env);
}
else if (tag == pic->rDEFINE) {
return macroexpand_define(pic, expr, env);
}
else if (tag == pic->rQUOTE) {
return macroexpand_quote(pic, expr);
}
if ((mac = find_macro(pic, tag)) != NULL) {
return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env);
}
}
return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), env));
}
default:
return expr;
}
}
static pic_value
macroexpand(pic_state *pic, pic_value expr, struct pic_env *env)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v;
#if DEBUG
printf("[macroexpand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
v = macroexpand_node(pic, expr, env);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
return v;
}
pic_value
pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib)
{
struct pic_lib *prev;
pic_value v;
#if DEBUG
puts("before expand:");
pic_debug(pic, expr);
puts("");
#endif
/* change library for macro-expansion time processing */
prev = pic->lib;
pic->lib = lib;
lib->env->defer = pic_nil_value(); /* the last expansion could fail and leave defer field old */
v = macroexpand(pic, expr, lib->env);
macroexpand_deferred(pic, lib->env);
pic->lib = prev;
#if DEBUG
puts("after expand:");
pic_debug(pic, v);
puts("");
#endif
return v;
} }
struct pic_env * struct pic_env *
pic_make_env(pic_state *pic, struct pic_env *up) pic_make_env(pic_state *pic, struct pic_env *up)
{ {
struct pic_env *env; struct pic_env *env;
struct pic_dict *map;
map = pic_make_dict(pic);
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
env->up = up; env->up = up;
env->defer = pic_nil_value(); xh_init_ptr(&env->map, sizeof(pic_sym *));
env->map = map;
return env; return env;
} }
static pic_value pic_sym *
defmacro_call(pic_state *pic) pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var)
{ {
struct pic_proc *self = pic_get_proc(pic); assert(pic_var_p(var));
pic_value args, tmp, proc;
pic_get_args(pic, "oo", &args, &tmp); while (pic_id_p(var)) {
var = pic_id_ptr(var)->var;
}
return pic_sym_ptr(var);
}
proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer"); pic_sym *
pic_uniq(pic_state *pic, pic_value var)
{
pic_str *str;
return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args)); assert(pic_var_p(var));
str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++);
return pic_intern(pic, str);
}
pic_sym *
pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var)
{
pic_sym *uid;
assert(pic_var_p(var));
uid = pic_uniq(pic, var);
pic_put_variable(pic, env, var, uid);
return uid;
} }
void void
pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func) pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid)
{ {
struct pic_proc *proc, *trans; assert(pic_var_p(var));
trans = pic_make_proc(pic, func, pic_symbol_name(pic, name)); xh_put_ptr(&env->map, pic_ptr(var), &uid);
pic_put_rename(pic, pic->lib->env, name, id);
proc = pic_make_proc(pic, defmacro_call, "defmacro_call");
pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans));
/* symbol registration */
define_macro(pic, id, proc);
/* auto export! */
pic_export(pic, name);
} }
bool pic_sym *
pic_identifier_p(pic_state *pic, pic_value obj) pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var)
{ {
return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj)); xh_entry *e;
}
bool assert(pic_var_p(var));
pic_identifier_eq_p(pic_state *pic, struct pic_env *env1, pic_sym *sym1, struct pic_env *env2, pic_sym *sym2)
{
pic_sym *a, *b;
a = make_identifier(pic, sym1, env1); if ((e = xh_get_ptr(&env->map, pic_ptr(var))) == NULL) {
if (a != make_identifier(pic, sym1, env1)) { return NULL;
a = sym1;
} }
return xh_val(e, pic_sym *);
b = make_identifier(pic, sym2, env2);
if (b != make_identifier(pic, sym2, env2)) {
b = sym2;
}
return pic_eq_p(pic_obj_value(a), pic_obj_value(b));
} }
static pic_value static pic_value
@ -441,40 +99,83 @@ pic_macro_identifier_p(pic_state *pic)
pic_get_args(pic, "o", &obj); pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_identifier_p(pic, obj)); return pic_bool_value(pic_id_p(obj));
} }
static pic_value static pic_value
pic_macro_make_identifier(pic_state *pic) pic_macro_make_identifier(pic_state *pic)
{ {
pic_value obj; pic_value var, env;
pic_sym *sym;
pic_get_args(pic, "mo", &sym, &obj); pic_get_args(pic, "oo", &var, &env);
pic_assert_type(pic, obj, env); pic_assert_type(pic, var, var);
pic_assert_type(pic, env, env);
return pic_obj_value(make_identifier(pic, sym, pic_env_ptr(obj))); return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env)));
} }
static pic_value static pic_value
pic_macro_identifier_eq_p(pic_state *pic) pic_macro_identifier_variable(pic_state *pic)
{ {
pic_sym *sym1, *sym2; pic_value id;
pic_value env1, env2;
pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); pic_get_args(pic, "o", &id);
pic_assert_type(pic, env1, env); pic_assert_type(pic, id, id);
pic_assert_type(pic, env2, env);
return pic_bool_value(pic_identifier_eq_p(pic, pic_env_ptr(env1), sym1, pic_env_ptr(env2), sym2)); return pic_id_ptr(id)->var;
}
static pic_value
pic_macro_identifier_environment(pic_state *pic)
{
pic_value id;
pic_get_args(pic, "o", &id);
pic_assert_type(pic, id, id);
return pic_obj_value(pic_id_ptr(id)->env);
}
static pic_value
pic_macro_variable_p(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_var_p(obj));
}
static pic_value
pic_macro_variable_eq_p(pic_state *pic)
{
size_t argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
if (! pic_var_p(argv[i])) {
return pic_false_value();
}
if (! pic_equal_p(pic, argv[i], argv[0])) {
return pic_false_value();
}
}
return pic_true_value();
} }
void void
pic_init_macro(pic_state *pic) pic_init_macro(pic_state *pic)
{ {
pic_defun(pic, "identifier?", pic_macro_identifier_p);
pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
pic_defun(pic, "make-identifier", pic_macro_make_identifier); pic_defun(pic, "make-identifier", pic_macro_make_identifier);
pic_defun(pic, "identifier?", pic_macro_identifier_p);
pic_defun(pic, "identifier-variable", pic_macro_identifier_variable);
pic_defun(pic, "identifier-environment", pic_macro_identifier_environment);
pic_defun(pic, "variable?", pic_macro_variable_p);
pic_defun(pic, "variable=?", pic_macro_variable_eq_p);
} }

18
extlib/benz/number.c
View File

@ -816,17 +816,17 @@ pic_init_number(pic_state *pic)
pic_defun(pic, "inexact?", pic_number_inexact_p); pic_defun(pic, "inexact?", pic_number_inexact_p);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
pic_defun_vm(pic, "=", pic->rEQ, pic_number_eq); pic_defun_vm(pic, "=", pic->uEQ, pic_number_eq);
pic_defun_vm(pic, "<", pic->rLT, pic_number_lt); pic_defun_vm(pic, "<", pic->uLT, pic_number_lt);
pic_defun_vm(pic, ">", pic->rGT, pic_number_gt); pic_defun_vm(pic, ">", pic->uGT, pic_number_gt);
pic_defun_vm(pic, "<=", pic->rLE, pic_number_le); pic_defun_vm(pic, "<=", pic->uLE, pic_number_le);
pic_defun_vm(pic, ">=", pic->rGE, pic_number_ge); pic_defun_vm(pic, ">=", pic->uGE, pic_number_ge);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
pic_defun_vm(pic, "+", pic->rADD, pic_number_add); pic_defun_vm(pic, "+", pic->uADD, pic_number_add);
pic_defun_vm(pic, "-", pic->rSUB, pic_number_sub); pic_defun_vm(pic, "-", pic->uSUB, pic_number_sub);
pic_defun_vm(pic, "*", pic->rMUL, pic_number_mul); pic_defun_vm(pic, "*", pic->uMUL, pic_number_mul);
pic_defun_vm(pic, "/", pic->rDIV, pic_number_div); pic_defun_vm(pic, "/", pic->uDIV, pic_number_div);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
pic_defun(pic, "abs", pic_number_abs); pic_defun(pic, "abs", pic_number_abs);

10
extlib/benz/pair.c
View File

@ -762,11 +762,11 @@ pic_init_pair(pic_state *pic)
{ {
void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
pic_defun_vm(pic, "pair?", pic->rPAIRP, pic_pair_pair_p); pic_defun_vm(pic, "pair?", pic->uPAIRP, pic_pair_pair_p);
pic_defun_vm(pic, "cons", pic->rCONS, pic_pair_cons); pic_defun_vm(pic, "cons", pic->uCONS, pic_pair_cons);
pic_defun_vm(pic, "car", pic->rCAR, pic_pair_car); pic_defun_vm(pic, "car", pic->uCAR, pic_pair_car);
pic_defun_vm(pic, "cdr", pic->rCDR, pic_pair_cdr); pic_defun_vm(pic, "cdr", pic->uCDR, pic_pair_cdr);
pic_defun_vm(pic, "null?", pic->rNILP, pic_pair_null_p); pic_defun_vm(pic, "null?", pic->uNILP, pic_pair_null_p);
pic_defun(pic, "set-car!", pic_pair_set_car); pic_defun(pic, "set-car!", pic_pair_set_car);
pic_defun(pic, "set-cdr!", pic_pair_set_cdr); pic_defun(pic, "set-cdr!", pic_pair_set_cdr);

29
extlib/benz/read.c
View File

@ -153,7 +153,7 @@ read_eval(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
form = read(pic, port, next(port)); form = read(pic, port, next(port));
return pic_eval(pic, form, pic->lib); return pic_eval(pic, form, pic->lib->env);
} }
static pic_value static pic_value
@ -180,6 +180,30 @@ read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port)));
} }
static pic_value
read_syntax_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{
return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUOTE), read(pic, port, next(port)));
}
static pic_value
read_syntax_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{
return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(port)));
}
static pic_value
read_syntax_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{
pic_sym *tag = pic->sSYNTAX_UNQUOTE;
if (peek(port) == '@') {
tag = pic->sSYNTAX_UNQUOTE_SPLICING;
next(port);
}
return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port)));
}
static pic_value static pic_value
read_symbol(pic_state *pic, struct pic_port *port, int c) read_symbol(pic_state *pic, struct pic_port *port, int c)
{ {
@ -799,6 +823,9 @@ reader_table_init(struct pic_reader *reader)
reader->dispatch[';'] = read_datum_comment; reader->dispatch[';'] = read_datum_comment;
reader->dispatch['t'] = read_true; reader->dispatch['t'] = read_true;
reader->dispatch['f'] = read_false; reader->dispatch['f'] = read_false;
reader->dispatch['\''] = read_syntax_quote;
reader->dispatch['`'] = read_syntax_quasiquote;
reader->dispatch[','] = read_syntax_unquote;
reader->dispatch['\\'] = read_char; reader->dispatch['\\'] = read_char;
reader->dispatch['('] = read_vector; reader->dispatch['('] = read_vector;
reader->dispatch['u'] = read_undef_or_blob; reader->dispatch['u'] = read_undef_or_blob;

85
extlib/benz/state.c
View File

@ -103,13 +103,13 @@ pic_init_core(pic_state *pic)
pic_deflibrary (pic, "(picrin base)") { pic_deflibrary (pic, "(picrin base)") {
size_t ai = pic_gc_arena_preserve(pic); size_t ai = pic_gc_arena_preserve(pic);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->uDEFINE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO);
pic_init_undef(pic); DONE; pic_init_undef(pic); DONE;
pic_init_bool(pic); DONE; pic_init_bool(pic); DONE;
@ -222,6 +222,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
/* symbol table */ /* symbol table */
xh_init_str(&pic->syms, sizeof(pic_sym *)); xh_init_str(&pic->syms, sizeof(pic_sym *));
/* unique symbol count */
pic->ucnt = 0;
/* global variables */ /* global variables */
pic->globals = NULL; pic->globals = NULL;
@ -254,7 +257,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
ai = pic_gc_arena_preserve(pic); ai = pic_gc_arena_preserve(pic);
#define S(slot,name) pic->slot = pic_intern_cstr(pic, name); #define S(slot,name) pic->slot = pic_intern_cstr(pic, name)
S(sDEFINE, "define"); S(sDEFINE, "define");
S(sLAMBDA, "lambda"); S(sLAMBDA, "lambda");
@ -265,7 +268,11 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
S(sQUASIQUOTE, "quasiquote"); S(sQUASIQUOTE, "quasiquote");
S(sUNQUOTE, "unquote"); S(sUNQUOTE, "unquote");
S(sUNQUOTE_SPLICING, "unquote-splicing"); S(sUNQUOTE_SPLICING, "unquote-splicing");
S(sDEFINE_SYNTAX, "define-syntax"); S(sSYNTAX_QUOTE, "syntax-quote");
S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote");
S(sSYNTAX_UNQUOTE, "syntax-unquote");
S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing");
S(sDEFINE_MACRO, "define-macro");
S(sIMPORT, "import"); S(sIMPORT, "import");
S(sEXPORT, "export"); S(sEXPORT, "export");
S(sDEFINE_LIBRARY, "define-library"); S(sDEFINE_LIBRARY, "define-library");
@ -308,37 +315,37 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); #define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern_cstr(pic, name)))
R(rDEFINE, "define"); U(uDEFINE, "define");
R(rLAMBDA, "lambda"); U(uLAMBDA, "lambda");
R(rIF, "if"); U(uIF, "if");
R(rBEGIN, "begin"); U(uBEGIN, "begin");
R(rSETBANG, "set!"); U(uSETBANG, "set!");
R(rQUOTE, "quote"); U(uQUOTE, "quote");
R(rDEFINE_SYNTAX, "define-syntax"); U(uDEFINE_MACRO, "define-macro");
R(rIMPORT, "import"); U(uIMPORT, "import");
R(rEXPORT, "export"); U(uEXPORT, "export");
R(rDEFINE_LIBRARY, "define-library"); U(uDEFINE_LIBRARY, "define-library");
R(rCOND_EXPAND, "cond-expand"); U(uCOND_EXPAND, "cond-expand");
R(rCONS, "cons"); U(uCONS, "cons");
R(rCAR, "car"); U(uCAR, "car");
R(rCDR, "cdr"); U(uCDR, "cdr");
R(rNILP, "null?"); U(uNILP, "null?");
R(rSYMBOLP, "symbol?"); U(uSYMBOLP, "symbol?");
R(rPAIRP, "pair?"); U(uPAIRP, "pair?");
R(rADD, "+"); U(uADD, "+");
R(rSUB, "-"); U(uSUB, "-");
R(rMUL, "*"); U(uMUL, "*");
R(rDIV, "/"); U(uDIV, "/");
R(rEQ, "="); U(uEQ, "=");
R(rLT, "<"); U(uLT, "<");
R(rLE, "<="); U(uLE, "<=");
R(rGT, ">"); U(uGT, ">");
R(rGE, ">="); U(uGE, ">=");
R(rNOT, "not"); U(uNOT, "not");
R(rVALUES, "values"); U(uVALUES, "values");
R(rCALL_WITH_VALUES, "call-with-values"); U(uCALL_WITH_VALUES, "call-with-values");
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
/* root tables */ /* root tables */

23
extlib/benz/symbol.c
View File

@ -4,7 +4,7 @@
#include "picrin.h" #include "picrin.h"
pic_sym * static pic_sym *
pic_make_symbol(pic_state *pic, pic_str *str) pic_make_symbol(pic_state *pic, pic_str *str)
{ {
pic_sym *sym; pic_sym *sym;
@ -42,25 +42,6 @@ pic_intern_cstr(pic_state *pic, const char *str)
return pic_intern(pic, pic_make_str(pic, str, strlen(str))); return pic_intern(pic, pic_make_str(pic, str, strlen(str)));
} }
pic_sym *
pic_gensym(pic_state *pic, pic_sym *base)
{
return pic_make_symbol(pic, base->str);
}
bool
pic_interned_p(pic_state *pic, pic_sym *sym)
{
xh_entry *e;
e = xh_get_str(&pic->syms, pic_str_cstr(pic, sym->str));
if (e) {
return sym == xh_val(e, pic_sym *);
} else {
return false;
}
}
const char * const char *
pic_symbol_name(pic_state *pic, pic_sym *sym) pic_symbol_name(pic_state *pic, pic_sym *sym)
{ {
@ -121,7 +102,7 @@ pic_init_symbol(pic_state *pic)
{ {
void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t);
pic_defun_vm(pic, "symbol?", pic->rSYMBOLP, pic_symbol_symbol_p); pic_defun_vm(pic, "symbol?", pic->uSYMBOLP, pic_symbol_symbol_p);
pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);

62
extlib/benz/vm.c
View File

@ -394,9 +394,9 @@ pic_get_args(pic_state *pic, const char *format, ...)
} }
void void
pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rsym) pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid)
{ {
pic_put_rename(pic, env, sym, rsym); pic_put_variable(pic, env, pic_obj_value(sym), uid);
if (pic->lib && pic->lib->env == env) { if (pic->lib && pic->lib->env == env) {
pic_export(pic, sym); pic_export(pic, sym);
@ -406,17 +406,17 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym,
void void
pic_define_noexport(pic_state *pic, const char *name, pic_value val) pic_define_noexport(pic_state *pic, const char *name, pic_value val)
{ {
pic_sym *sym, *rename; pic_sym *sym, *uid;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
if ((rename = pic_find_rename(pic, pic->lib->env, sym)) == NULL) { if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) {
rename = pic_add_rename(pic, pic->lib->env, sym); uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym));
} else { } else {
pic_warnf(pic, "redefining global"); pic_warnf(pic, "redefining global");
} }
pic_dict_set(pic, pic->globals, rename, val); pic_dict_set(pic, pic->globals, uid, val);
} }
void void
@ -430,29 +430,29 @@ pic_define(pic_state *pic, const char *name, pic_value val)
pic_value pic_value
pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
{ {
pic_sym *sym, *rename; pic_sym *sym, *uid;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) {
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
} }
return pic_dict_ref(pic, pic->globals, rename); return pic_dict_ref(pic, pic->globals, uid);
} }
void void
pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
{ {
pic_sym *sym, *rename; pic_sym *sym, *uid;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) { if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) {
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
} }
pic_dict_set(pic, pic->globals, rename, val); pic_dict_set(pic, pic->globals, uid, val);
} }
pic_value pic_value
@ -477,7 +477,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
} }
void void
pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func)
{ {
struct pic_proc *proc; struct pic_proc *proc;
pic_sym *sym; pic_sym *sym;
@ -486,9 +486,9 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func)
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
pic_put_rename(pic, pic->lib->env, sym, rename); pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), uid);
pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc)); pic_dict_set(pic, pic->globals, uid, pic_obj_value(proc));
pic_export(pic, sym); pic_export(pic, sym);
} }
@ -499,6 +499,38 @@ pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *co
pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv))); pic_define(pic, name, pic_obj_value(pic_make_var(pic, init, conv)));
} }
static pic_value
defmacro_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
pic_value args, tmp, proc;
pic_get_args(pic, "oo", &args, &tmp);
proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer");
return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args));
}
void
pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func)
{
struct pic_proc *proc, *trans;
trans = pic_make_proc(pic, func, pic_symbol_name(pic, name));
pic_put_variable(pic, pic->lib->env, pic_obj_value(name), id);
proc = pic_make_proc(pic, defmacro_call, "defmacro_call");
pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans));
/* symbol registration */
pic_dict_set(pic, pic->macros, id, pic_obj_value(proc));
/* auto export! */
pic_export(pic, name);
}
static void static void
vm_push_cxt(pic_state *pic) vm_push_cxt(pic_state *pic)
{ {

3
extlib/benz/write.c
View File

@ -302,6 +302,9 @@ write_core(struct writer_control *p, pic_value obj)
} }
xfprintf(file, ")"); xfprintf(file, ")");
break; break;
case PIC_TT_ID:
xfprintf(file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(pic, obj)));
break;
default: default:
xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
break; break;

19
piclib/picrin/base.scm
View File

@ -6,11 +6,16 @@
quote quote
set! set!
begin begin
define-syntax) define-macro)
(export syntax-error (export syntax-error
define-syntax
let-syntax let-syntax
letrec-syntax) letrec-syntax
syntax-quote
syntax-quasiquote
syntax-unquote
syntax-unquote-splicing)
(export let (export let
let* let*
@ -239,9 +244,13 @@
(export make-parameter (export make-parameter
parameterize) parameterize)
(export identifier? (export make-identifier
identifier=? identifier?
make-identifier) identifier-variable
identifier-environment
variable?
variable=?)
(export call-with-current-continuation (export call-with-current-continuation
call/cc call/cc

67
piclib/picrin/experimental/lambda.scm
View File

@ -3,47 +3,36 @@
(picrin base) (picrin base)
(picrin macro)) (picrin macro))
(define-syntax destructuring-bind (define-syntax (destructuring-let formal value . body)
(ir-macro-transformer (cond
(lambda (form inject compare) ((variable? formal)
(let ((formal (car (cdr form))) #`(let ((#,formal #,value))
(value (car (cdr (cdr form)))) #,@body))
(body (cdr (cdr (cdr form))))) ((pair? formal)
(cond #`(let ((value #,value))
((symbol? formal) (destructuring-let #,(car formal) (car value)
`(let ((,formal ,value)) (destructuring-let #,(cdr formal) (cdr value)
,@body)) #,@body))))
((pair? formal) ((vector? formal)
`(let ((value# ,value)) ;; TODO
(destructuring-bind ,(car formal) (car value#) (error "fixme"))
(destructuring-bind ,(cdr formal) (cdr value#) (else
,@body)))) #`(if (equal? #,value '#,formal)
((vector? formal) (begin
;; TODO #,@body)
(error "fixme")) (error "match failure" #,value '#,formal)))))
(else
`(if (equal? ,value ',formal)
(begin
,@body)
(error "match failure" ,value ',formal))))))))
(define-syntax destructuring-lambda (define-syntax (destructuring-lambda formal . body)
(ir-macro-transformer #`(lambda args
(lambda (form inject compare) (destructuring-let #,formal args #,@body)))
(let ((args (car (cdr form)))
(body (cdr (cdr form))))
`(lambda formal# (destructuring-bind ,args formal# ,@body))))))
(define-syntax destructuring-define (define-syntax (destructuring-define formal . body)
(ir-macro-transformer (if (variable? formal)
(lambda (form inject compare) #`(define #,formal #,@body)
(let ((maybe-formal (cadr form))) #`(destructuring-define #,(car formal)
(if (symbol? maybe-formal) (destructuring-lambda #,(cdr formal)
`(define ,@(cdr form)) #,@body))))
`(destructuring-define ,(car maybe-formal)
(destructuring-lambda ,(cdr maybe-formal)
,@(cddr form))))))))
(export (rename destructuring-bind bind) (export (rename destructuring-let let)
(rename destructuring-lambda lambda) (rename destructuring-lambda lambda)
(rename destructuring-define define))) (rename destructuring-define define)))

263
piclib/picrin/macro.scm
View File

@ -1,141 +1,180 @@
(define-library (picrin macro) (define-library (picrin macro)
(import (picrin base)) (import (picrin base))
(export identifier? ;; macro primitives
identifier=?
(export define-macro
make-identifier make-identifier
identifier?
identifier-variable
identifier-environment
variable?
variable=?)
;; simple macro
(export define-syntax
syntax-quote
syntax-quasiquote
syntax-unquote
syntax-unquote-splicing)
;; misc transformers
(export call-with-current-environment
make-syntactic-closure make-syntactic-closure
close-syntax close-syntax
capture-syntactic-environment strip-syntax
sc-macro-transformer sc-macro-transformer
rsc-macro-transformer rsc-macro-transformer
er-macro-transformer er-macro-transformer
ir-macro-transformer ir-macro-transformer)
;; strip-syntax
define-macro)
;; assumes no derived expressions are provided yet
(define (walk proc expr) (define-macro call-with-current-environment
"walk on symbols" (lambda (form env)
(if (null? expr) `(,(cadr form) ',env)))
'()
(if (pair? expr)
(cons (walk proc (car expr)) ;; syntactic closure
(walk proc (cdr expr)))
(if (vector? expr)
(list->vector (walk proc (vector->list expr)))
(if (symbol? expr)
(proc expr)
expr)))))
(define (memoize f)
"memoize on symbols"
(define cache (make-dictionary))
(lambda (sym)
(define value (dictionary-ref cache sym))
(if (not (undefined? value))
value
(begin
(define val (f sym))
(dictionary-set! cache sym val)
val))))
(define (make-syntactic-closure env free form) (define (make-syntactic-closure env free form)
(letrec
(define resolve ((wrap (let ((register (make-register)))
(memoize (lambda (var)
(lambda (sym) (let ((id (register var)))
(make-identifier sym env)))) (if (undefined? id)
(let ((id (make-identifier var env)))
(walk (register var id)
(lambda (sym) id)
(if (memq sym free) id)))))
sym (walk (lambda (f form)
(resolve sym))) (cond
form)) ((variable? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
((vector? form)
(list->vector (walk f (vector->list form))))
(else
form)))))
(letrec
((f (lambda (var)
(let loop ((free free))
(if (null? free)
(wrap free)
(if (variable=? var (car free))
var
(loop (cdr free))))))))
(walk f form))))
(define (close-syntax form env) (define (close-syntax form env)
(make-syntactic-closure env '() form)) (make-syntactic-closure env '() form))
(define-syntax capture-syntactic-environment (define (strip-syntax form)
(lambda (mac-env) (letrec
(lambda (form use-env) ((unwrap (lambda (var)
(list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))) (identifier-variable var)))
(walk (lambda (f form)
(cond
((variable? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
((vector? form)
(list->vector (walk f (vector->list form))))
(else
form)))))
(walk unwrap form)))
(define (sc-macro-transformer f)
(lambda (mac-env)
(lambda (expr use-env)
(make-syntactic-closure mac-env '() (f expr use-env)))))
(define (rsc-macro-transformer f) ;; transformers
(lambda (mac-env)
(lambda (expr use-env)
(make-syntactic-closure use-env '() (f expr mac-env)))))
(define (er-macro-transformer f)
(lambda (mac-env)
(lambda (expr use-env)
(define rename (define (sc-transformer f)
(memoize (lambda (form use-env mac-env)
(lambda (sym) (make-syntactic-closure mac-env '() (f form use-env))))
(make-identifier sym mac-env))))
(define (compare x y) (define (rsc-transformer f)
(if (not (symbol? x)) (lambda (form use-env mac-env)
#f (make-syntactic-closure use-env '() (f form mac-env))))
(if (not (symbol? y))
#f
(identifier=? use-env x use-env y))))
(f expr rename compare)))) (define (er-transformer f)
(lambda (form use-env mac-env)
(letrec
((rename (let ((register (make-register)))
(lambda (var)
(let ((id (register var)))
(if (undefined? id)
(let ((id (make-identifier var mac-env)))
(register var id)
id)
id)))))
(compare (lambda (x y)
(variable=?
(make-identifier x use-env)
(make-identifier y use-env)))))
(f form rename compare))))
(define (ir-macro-transformer f) (define (ir-transformer f)
(lambda (mac-env) (lambda (form use-env mac-env)
(lambda (expr use-env) (let ((register1 (make-register))
(register2 (make-register)))
(letrec
((inject (lambda (var1)
(let ((var2 (register1 var1)))
(if (undefined? var2)
(let ((var2 (make-identifier var1 use-env)))
(register1 var1 var2)
(register2 var2 var1)
var2)
var2))))
(rename (let ((register (make-register)))
(lambda (var)
(let ((id (register var)))
(if (undefined? id)
(let ((id (make-identifier var mac-env)))
(register var id)
id)
id)))))
(flip (lambda (var2) ; unwrap if injected, wrap if not injected
(let ((var1 (register2 var2)))
(if (undefined? var1)
(rename var2)
var1))))
(walk (lambda (f form)
(cond
((variable? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
((vector? form)
(list->vector (walk f (vector->list form))))
(else
form))))
(compare (lambda (x y)
(variable=?
(make-identifier x mac-env)
(make-identifier y mac-env)))))
(walk flip (f (walk inject form) inject compare))))))
(define icache* (make-dictionary)) (define-macro sc-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((sc-transformer #,(cadr f)) form use-env #,mac-env))))
(define inject (define-macro rsc-macro-transformer
(memoize (lambda (f mac-env)
(lambda (sym) #`(lambda (form use-env)
(define id (make-identifier sym use-env)) ((rsc-transformer #,(cadr f)) form use-env #,mac-env))))
(dictionary-set! icache* id sym)
id)))
(define rename (define-macro er-macro-transformer
(memoize (lambda (f mac-env)
(lambda (sym) #`(lambda (form use-env)
(make-identifier sym mac-env)))) ((er-transformer #,(cadr f)) form use-env #,mac-env))))
(define (compare x y) (define-macro ir-macro-transformer
(if (not (symbol? x)) (lambda (f mac-env)
#f #`(lambda (form use-env)
(if (not (symbol? y)) ((ir-transformer #,(cadr f)) form use-env #,mac-env)))))
#f
(identifier=? mac-env x mac-env y))))
(walk (lambda (sym)
(let ((value (dictionary-ref icache* sym)))
(if (undefined? value)
(rename sym)
value)))
(f (walk inject expr) inject compare)))))
;; (define (strip-syntax form)
;; (walk ungensym form))
(define-syntax define-macro
(er-macro-transformer
(lambda (expr r c)
(define formal (car (cdr expr)))
(define body (cdr (cdr expr)))
(if (symbol? formal)
(list (r 'define-syntax) formal
(list (r 'lambda) (list (r 'form) '_ '_)
(list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))
(list (r 'define-macro) (car formal)
(cons (r 'lambda)
(cons (cdr formal)
body))))))))

96
piclib/picrin/record.scm
View File

@ -2,7 +2,7 @@
(import (picrin base) (import (picrin base)
(picrin macro)) (picrin macro))
;; define-record-type ;; record meta type
(define ((boot-make-record-type <meta-type>) name) (define ((boot-make-record-type <meta-type>) name)
(let ((rectype (make-record <meta-type>))) (let ((rectype (make-record <meta-type>)))
@ -10,70 +10,50 @@
rectype)) rectype))
(define <record-type> (define <record-type>
(let ((<record-type> (let ((<record-type> ((boot-make-record-type #t) 'record-type)))
((boot-make-record-type #t) 'record-type)))
(record-set! <record-type> '@@type <record-type>) (record-set! <record-type> '@@type <record-type>)
<record-type>)) <record-type>))
(define make-record-type (boot-make-record-type <record-type>)) (define make-record-type (boot-make-record-type <record-type>))
(define-syntax define-record-constructor ;; define-record-type
(ir-macro-transformer
(lambda (form inject compare?)
(let ((rectype (car (cdr form)))
(name (car (cdr (cdr form))))
(fields (cdr (cdr (cdr form)))))
`(define (,name ,@fields)
(let ((record (make-record ,rectype)))
,@(map (lambda (field)
`(record-set! record ',field ,field))
fields)
record))))))
(define-syntax define-record-predicate (define-syntax (define-record-constructor type name . fields)
(ir-macro-transformer (let ((record #'record))
(lambda (form inject compare?) #`(define (#,name . #,fields)
(let ((rectype (car (cdr form))) (let ((#,record (make-record #,type)))
(name (car (cdr (cdr form))))) #,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
`(define (,name obj) #,record))))
(and (record? obj)
(eq? (record-type obj)
,rectype)))))))
(define-syntax define-record-field (define-syntax (define-record-predicate type name)
(ir-macro-transformer #`(define (#,name obj)
(lambda (form inject compare?) (and (record? obj)
(let ((pred (car (cdr form))) (eq? (record-type obj) #,type))))
(field-name (car (cdr (cdr form))))
(accessor (car (cdr (cdr (cdr form)))))
(modifier? (cdr (cdr (cdr (cdr form))))))
(if (null? modifier?)
`(define (,accessor record)
(if (,pred record)
(record-ref record ',field-name)
(error (string-append (symbol->string ',accessor) ": wrong record type") record)))
`(begin
(define (,accessor record)
(if (,pred record)
(record-ref record ',field-name)
(error (string-append (symbol->string ',accessor) ": wrong record type") record)))
(define (,(car modifier?) record val)
(if (,pred record)
(record-set! record ',field-name val)
(error (string-append (symbol->string ',(car modifier?)) ": wrong record type") record)))))))))
(define-syntax define-record-type (define-syntax (define-record-accessor pred field accessor)
(ir-macro-transformer #`(define (#,accessor record)
(lambda (form inject compare?) (if (#,pred record)
(let ((name (car (cdr form))) (record-ref record '#,field)
(ctor (car (cdr (cdr form)))) (error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(pred (car (cdr (cdr (cdr form)))))
(fields (cdr (cdr (cdr (cdr form)))))) (define-syntax (define-record-modifier pred field modifier)
`(begin #`(define (#,modifier record val)
(define ,name (make-record-type ',name)) (if (#,pred record)
(define-record-constructor ,name ,@ctor) (record-set! record '#,field val)
(define-record-predicate ,name ,pred) (error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
,@(map (lambda (field) `(define-record-field ,pred ,@field))
fields)))))) (define-syntax (define-record-field pred field accessor . modifier-opt)
(if (null? modifier-opt)
#`(define-record-accessor #,pred #,field #,accessor)
#`(begin
(define-record-accessor #,pred #,field #,accessor)
(define-record-modifier #,pred #,field #,(car modifier-opt)))))
(define-syntax (define-record-type name ctor pred . fields)
#`(begin
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
(export define-record-type)) (export define-record-type))

521
piclib/picrin/syntax-rules.scm
View File

@ -1,348 +1,243 @@
(define-library (picrin syntax-rules) (define-library (picrin syntax-rules)
(import (picrin base) (import (picrin base)
(picrin control)
(picrin macro)) (picrin macro))
(define-syntax define-auxiliary-syntax (define-syntax (define-auxiliary-syntax var)
(er-macro-transformer #`(define-macro #,var
(lambda (expr r c) (lambda _
(list (r 'define-syntax) (cadr expr) (error "invalid use of auxiliary syntax" '#,var))))
(list (r 'lambda) '_
(list (r 'lambda) '_
(list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'"))))))))
(define-auxiliary-syntax _) (define-auxiliary-syntax _)
(define-auxiliary-syntax ...) (define-auxiliary-syntax ...)
(define (walk proc expr) (define (succ n)
(cond (+ n 1))
((null? expr)
'())
((pair? expr)
(cons (walk proc (car expr))
(walk proc (cdr expr))))
((vector? expr)
(list->vector (map proc (vector->list expr))))
(else
(proc expr))))
(define (flatten expr) (define (pred n)
(let ((list '())) (if (= n 0)
(walk 0
(lambda (x) (- n 1)))
(set! list (cons x list)))
expr)
(reverse list)))
(define (reverse* l) (define (every? args)
;; (reverse* '(a b c d . e)) => (e d c b a) (if (null? args)
(let loop ((a '())
(d l))
(if (pair? d)
(loop (cons (car d) a) (cdr d))
(cons d a))))
(define (every? pred l)
(if (null? l)
#t #t
(and (pred (car l)) (every? pred (cdr l))))) (if (car args)
(every? (cdr args))
#f)))
(define-syntax syntax-rules (define (filter f list)
(er-macro-transformer (if (null? list)
(lambda (form r compare) '()
(define _define (r 'define)) (if (f (car list))
(define _let (r 'let)) (cons (car list)
(define _if (r 'if)) (filter f (cdr list)))
(define _begin (r 'begin)) (filter f (cdr list)))))
(define _lambda (r 'lambda))
(define _set! (r 'set!))
(define _not (r 'not))
(define _and (r 'and))
(define _car (r 'car))
(define _cdr (r 'cdr))
(define _cons (r 'cons))
(define _pair? (r 'pair?))
(define _null? (r 'null?))
(define _symbol? (r 'symbol?))
(define _vector? (r 'vector?))
(define _eqv? (r 'eqv?))
(define _string=? (r 'string=?))
(define _map (r 'map))
(define _vector->list (r 'vector->list))
(define _list->vector (r 'list->vector))
(define _quote (r 'quote))
(define _quasiquote (r 'quasiquote))
(define _unquote (r 'unquote))
(define _unquote-splicing (r 'unquote-splicing))
(define _syntax-error (r 'syntax-error))
(define _escape (r 'escape))
(define _er-macro-transformer (r 'er-macro-transformer))
(define (var->sym v) (define (take-tail n list)
(let loop ((cnt 0) (let drop ((n (- (length list) n)) (list list))
(v v)) (if (= n 0)
(if (symbol? v) list
(string->symbol (drop (- n 1) (cdr list)))))
(string-append (symbol->string v) "/" (number->string cnt)))
(loop (+ 1 cnt) (car v)))))
(define push-var list) (define (drop-tail n list)
(let take ((n (- (length list) n)) (list list))
(if (= n 0)
'()
(cons (car list) (take (- n 1) (cdr list))))))
(define (compile-match ellipsis literals pattern) (define (map-keys f assoc)
(letrec ((compile-match-base (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
(lambda (pattern)
(cond ((member pattern literals compare)
(values
`(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
#f
(exit #f))
'()))
((compare pattern (r '_)) (values #f '()))
((and ellipsis (compare pattern ellipsis))
(values `(,_syntax-error "invalid pattern") '()))
((symbol? pattern)
(values `(,_set! ,(var->sym pattern) expr) (list pattern)))
((pair? pattern)
(compile-match-list pattern))
((vector? pattern)
(compile-match-vector pattern))
((string? pattern)
(values
`(,_if (,_not (,_string=? ',pattern expr))
(exit #f))
'()))
(else
(values
`(,_if (,_not (,_eqv? ',pattern expr))
(exit #f))
'())))))
(compile-match-list (define (map-values f assoc)
(lambda (pattern) (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
(let loop ((pattern pattern)
(matches '())
(vars '())
(accessor 'expr))
(cond ;; (hoge)
((not (pair? (cdr pattern)))
(let*-values (((match1 vars1) (compile-match-base (car pattern)))
((match2 vars2) (compile-match-base (cdr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_if (,_pair? ,accessor)
(,_begin
(,_let ((expr (,_car ,accessor)))
,match1)
(,_let ((expr (,_cdr ,accessor)))
,match2))
(exit #f)))
(append vars (append vars1 vars2)))))
;; (hoge ... rest args)
((and ellipsis (compare (cadr pattern) ellipsis))
(let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr (,_let loop ((a ())
(d ,accessor))
(,_if (,_pair? d)
(loop (,_cons (,_car d) a) (,_cdr d))
(,_cons d a)))))
,match-r))
(append vars vars-r))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_if (,_pair? ,accessor)
(,_let ((expr (,_car ,accessor)))
,match1)
(exit #f))
matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-list-reverse ;; TODO
(lambda (pattern) ;; - placeholder
(let loop ((pattern (reverse* pattern)) ;; - vector
(matches '()) ;; - (... template) pattern
(vars '())
(accessor 'expr))
(cond ((and ellipsis (compare (car pattern) ellipsis))
(let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr ,accessor))
,match1))
(append vars vars1))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-ellipsis ;; p ::= constant
(lambda (pattern) ;; | var
(let-values (((match vars) (compile-match-base pattern))) ;; | (p ... . p) (in input pattern, tail p should be a proper list)
(values ;; | (p . p)
`(,_let loop ((expr expr))
(,_if (,_not (,_null? expr))
(,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)
(,_let ((expr (,_car expr)))
,match)
,@(map
(lambda (var)
`(,_set! ,(var->sym (push-var var))
(,_cons ,(var->sym var) ,(var->sym (push-var var)))))
vars)
(loop (,_cdr expr)))))
(map push-var vars)))))
(compile-match-vector (define (compile ellipsis literals rules)
(lambda (pattern)
(let-values (((match vars) (compile-match-base (vector->list pattern))))
(values
`(,_if (,_vector? expr)
(,_let ((expr (,_vector->list expr)))
,match)
(exit #f))
vars)))))
(let-values (((match vars) (compile-match-base (cdr pattern)))) (define (constant? obj)
(values `(,_let ((expr (,_cdr expr))) (and (not (pair? obj))
,match (not (variable? obj))))
#t)
vars))))
;;; compile expand (define (literal? obj)
(define (compile-expand ellipsis reserved template) (and (variable? obj)
(letrec ((compile-expand-base (memq obj literals)))
(lambda (template ellipsis-valid)
(cond ((member template reserved eq?)
(values (var->sym template) (list template)))
((symbol? template)
(values `(rename ',template) '()))
((pair? template)
(compile-expand-list template ellipsis-valid))
((vector? template)
(compile-expand-vector template ellipsis-valid))
(else
(values `',template '())))))
(compile-expand-list (define (many? pat)
(lambda (template ellipsis-valid) (and (pair? pat)
(let loop ((template template) (pair? (cdr pat))
(expands '()) (variable? (cadr pat))
(vars '())) (variable=? (cadr pat) ellipsis)))
(cond ;; (... hoge)
((and ellipsis-valid
(pair? template)
(compare (car template) ellipsis))
(if (and (pair? (cdr template)) (null? (cddr template)))
(compile-expand-base (cadr template) #f)
(values '(,_syntax-error "invalid template") '())))
;; hoge
((not (pair? template))
(let-values (((expand1 vars1)
(compile-expand-base template ellipsis-valid)))
(values
`(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
(append vars vars1))))
;; (a ... rest syms)
((and ellipsis-valid
(pair? (cdr template))
(compare (cadr template) ellipsis))
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cddr template)
(cons
`(,_unquote-splicing
(,_map (,_lambda ,(map var->sym vars1) ,expand1)
,@(map (lambda (v) (var->sym (push-var v))) vars1)))
expands)
(append vars (map push-var vars1)))))
(else
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cdr template)
(cons
`(,_unquote ,expand1)
expands)
(append vars vars1))))))))
(compile-expand-vector (define (pattern-validator pat) ; pattern -> validator
(lambda (template ellipsis-valid) (letrec
(let-values (((expand1 vars1) ((pattern-validator
(compile-expand-base (vector->list template) ellipsis-valid))) (lambda (pat form)
(values (cond
`(,_list->vector ,expand1) ((constant? pat)
vars1))))) #`(equal? '#,pat #,form))
((literal? pat)
#`(and (variable? #,form) (variable=? #'#,pat #,form)))
((variable? pat)
#t)
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
#`(and (list? #,form)
(>= (length #,form) #,(length (cddr pat)))
(every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head))
#,(pattern-validator (cddr pat) tail))))
((pair? pat)
#`(and (pair? #,form)
#,(pattern-validator (car pat) #`(car #,form))
#,(pattern-validator (cdr pat) #`(cdr #,form))))
(else
#f)))))
(pattern-validator pat 'it)))
(compile-expand-base template ellipsis))) (define (pattern-variables pat) ; pattern -> (freevar)
(cond
((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`(,pat))
((many? pat)
(append (pattern-variables (car pat))
(pattern-variables (cddr pat))))
((pair? pat)
(append (pattern-variables (car pat))
(pattern-variables (cdr pat))))))
(define (check-vars vars-pattern vars-template) (define (pattern-levels pat) ; pattern -> ((var * int))
;;fixme (cond
#t) ((constant? pat)
'())
((literal? pat)
'())
((variable? pat)
`((,pat . 0)))
((many? pat)
(append (map-values succ (pattern-levels (car pat)))
(pattern-levels (cddr pat))))
((pair? pat)
(append (pattern-levels (car pat))
(pattern-levels (cdr pat))))))
(define (compile-rule ellipsis literals rule) (define (pattern-selectors pat) ; pattern -> ((var * selector))
(let ((pattern (car rule)) (letrec
(template (cadr rule))) ((pattern-selectors
(let*-values (((match vars-match) (lambda (pat form)
(compile-match ellipsis literals pattern)) (cond
((expand vars-expand) ((constant? pat)
(compile-expand ellipsis (flatten vars-match) template))) '())
(if (check-vars vars-match vars-expand) ((literal? pat)
(list vars-match match expand) '())
'mismatch)))) ((variable? pat)
`((,pat . ,form)))
((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
(let ((envs (pattern-selectors (car pat) 'it)))
(append
(map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs)
(pattern-selectors (cddr pat) tail)))))
((pair? pat)
(append (pattern-selectors (car pat) #`(car #,form))
(pattern-selectors (cdr pat) #`(cdr #,form))))))))
(pattern-selectors pat 'it)))
(define (expand-clauses clauses rename) (define (template-representation pat levels selectors)
(cond ((null? clauses) (cond
`(,_quote (syntax-error "no matching pattern"))) ((constant? pat)
((compare (car clauses) 'mismatch) pat)
`(,_syntax-error "invalid rule")) ((variable? pat)
(else (let ((it (assq pat levels)))
(let ((vars (list-ref (car clauses) 0)) (if it
(match (list-ref (car clauses) 1)) (if (= 0 (cdr it))
(expand (list-ref (car clauses) 2))) (cdr (assq pat selectors))
`(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) (error "unmatched pattern variable level" pat))
(,_let ((result (,_escape (,_lambda (exit) ,match)))) #`(#,'rename '#,pat))))
(,_if result ((many? pat)
,expand (letrec*
,(expand-clauses (cdr clauses) rename)))))))) ((inner-pat
(car pat))
(inner-levels
(map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels))
(inner-freevars
(filter (lambda (v) (assq v levels)) (pattern-variables inner-pat)))
(inner-vars
;; select only vars declared with ellipsis
(filter (lambda (v) (> (cdr (assq v levels)) 0)) inner-freevars))
(inner-tmps
(map (lambda (v) #'it) inner-vars))
(inner-selectors
;; first env '(map cons ...)' shadows second env 'selectors'
(append (map cons inner-vars inner-tmps) selectors))
(inner-rep
(template-representation inner-pat inner-levels inner-selectors))
(sorted-selectors
(map (lambda (v) (assq v selectors)) inner-vars))
(list-of-selectors
;; ((a . xs) (b . ys) (c . zs)) -> (xs ys zs)
(map cdr sorted-selectors)))
(let ((rep1 #`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors))
(rep2 (template-representation (cddr pat) levels selectors)))
#`(append #,rep1 #,rep2))))
((pair? pat)
#`(cons #,(template-representation (car pat) levels selectors)
#,(template-representation (cdr pat) levels selectors)))))
(define (normalize-form form) (define (compile-rule pattern template)
(if (and (list? form) (>= (length form) 2)) (let ((levels
(let ((ellipsis '...) (pattern-levels pattern))
(literals (cadr form)) (selectors
(rules (cddr form))) (pattern-selectors pattern)))
(template-representation template levels selectors)))
(when (symbol? literals) (define (compile-rules rules)
(set! ellipsis literals) (if (null? rules)
(set! literals (car rules)) #`(error "unmatch")
(set! rules (cdr rules))) (let ((pattern (car (car rules)))
(template (cadr (car rules))))
#`(if #,(pattern-validator pattern)
#,(compile-rule pattern template)
#,(compile-rules (cdr rules))))))
(if (and (symbol? ellipsis) (define (compile rules)
(list? literals) #`(call-with-current-environment
(every? symbol? literals) (lambda (env)
(list? rules) (letrec
(every? (lambda (l) (and (list? l) (= (length l) 2))) rules)) ((#,'rename (let ((reg (make-register)))
(if (member ellipsis literals compare) (lambda (x)
`(syntax-rules #f ,literals ,@rules) (if (undefined? (reg x))
`(syntax-rules ,ellipsis ,literals ,@rules)) (let ((id (make-identifier x env)))
#f)) (reg x id)
#f)) id)
(reg x))))))
(lambda #,'it
#,(compile-rules rules))))))
(let ((form (normalize-form form))) (let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
(if form (compile rules)))
(let ((ellipsis (list-ref form 1))
(literals (list-ref form 2)) (define-syntax (syntax-rules . args)
(rules (list-tail form 3))) (if (list? (car args))
(let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) #`(syntax-rules ... #,@args)
rules))) (let ((ellipsis (car args))
`(,_er-macro-transformer (literals (car (cdr args)))
(,_lambda (expr rename cmp) (rules (cdr (cdr args))))
,(expand-clauses clauses r))))) (compile ellipsis literals rules))))
`(,_syntax-error "malformed syntax-rules"))))))
(export syntax-rules (export syntax-rules
_ _

6
t/r7rs-tests.scm
View File

@ -460,9 +460,9 @@
(syntax-rules () (syntax-rules ()
((be-like-begin name) ((be-like-begin name)
(define-syntax name (define-syntax name
(syntax-rules () (syntax-rules ::: ()
((name expr (... ...)) ((name expr :::)
(begin expr (... ...)))))))) (begin expr :::)))))))
(be-like-begin sequence) (be-like-begin sequence)
(test 4 (sequence 1 2 3 4)) (test 4 (sequence 1 2 3 4))