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)
(import (scheme base))
(define (length+ list)
(if (pair? list)
(+ 1 (length+ (cdr list)))
0))
(define-syntax case-lambda
(syntax-rules ()
((case-lambda (params body0 ...) ...)
(lambda args
(let ((len (length args)))
(letrec-syntax
((cl (syntax-rules ::: ()
((cl (syntax-rules ()
((cl)
(error "no matching clause"))
((cl ((p :::) . body) . rest)
(if (= len (length '(p :::)))
(apply (lambda (p :::)
. body)
args)
(cl . rest)))
((cl ((p ::: . tail) . body)
. rest)
(if (>= len (length '(p :::)))
(apply
(lambda (p ::: . tail)
. body)
args)
((cl (formal . body) . rest)
(if (if (list? 'formal)
(= len (length 'formal))
(>= len (length+ 'formal)))
(apply (lambda formal . body) args)
(cl . rest))))))
(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;
}
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:
return false;
}
@ -195,7 +203,7 @@ pic_init_bool(pic_state *pic)
pic_defun(pic, "eqv?", pic_bool_eqv_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_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"
/**
* 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;
#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();
/* 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);
@ -399,7 +740,7 @@ analyze_define(analyze_state *state, pic_value obj)
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_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;
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)) {
pic_sym *sym = pic_sym_ptr(proc);
if (sym == pic->rDEFINE) {
if (sym == pic->uDEFINE) {
return analyze_define(state, obj);
}
else if (sym == pic->rLAMBDA) {
else if (sym == pic->uLAMBDA) {
return analyze_lambda(state, obj);
}
else if (sym == pic->rIF) {
else if (sym == pic->uIF) {
return analyze_if(state, obj, tailpos);
}
else if (sym == pic->rBEGIN) {
else if (sym == pic->uBEGIN) {
return analyze_begin(state, obj, tailpos);
}
else if (sym == pic->rSETBANG) {
else if (sym == pic->uSETBANG) {
return analyze_set(state, obj);
}
else if (sym == pic->rQUOTE) {
else if (sym == pic->uQUOTE) {
return analyze_quote(state, obj);
}
else if (sym == pic->rCONS) {
else if (sym == pic->uCONS) {
ARGC_ASSERT(2, "cons");
return CONSTRUCT_OP2(pic->sCONS);
}
else if (sym == pic->rCAR) {
else if (sym == pic->uCAR) {
ARGC_ASSERT(1, "car");
return CONSTRUCT_OP1(pic->sCAR);
}
else if (sym == pic->rCDR) {
else if (sym == pic->uCDR) {
ARGC_ASSERT(1, "cdr");
return CONSTRUCT_OP1(pic->sCDR);
}
else if (sym == pic->rNILP) {
else if (sym == pic->uNILP) {
ARGC_ASSERT(1, "nil?");
return CONSTRUCT_OP1(pic->sNILP);
}
else if (sym == pic->rSYMBOLP) {
else if (sym == pic->uSYMBOLP) {
ARGC_ASSERT(1, "symbol?");
return CONSTRUCT_OP1(pic->sSYMBOLP);
}
else if (sym == pic->rPAIRP) {
else if (sym == pic->uPAIRP) {
ARGC_ASSERT(1, "pair?");
return CONSTRUCT_OP1(pic->sPAIRP);
}
else if (sym == pic->rADD) {
else if (sym == pic->uADD) {
return analyze_add(state, obj, tailpos);
}
else if (sym == pic->rSUB) {
else if (sym == pic->uSUB) {
return analyze_sub(state, obj);
}
else if (sym == pic->rMUL) {
else if (sym == pic->uMUL) {
return analyze_mul(state, obj, tailpos);
}
else if (sym == pic->rDIV) {
else if (sym == pic->uDIV) {
return analyze_div(state, obj);
}
else if (sym == pic->rEQ) {
else if (sym == pic->uEQ) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sEQ);
}
else if (sym == pic->rLT) {
else if (sym == pic->uLT) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sLT);
}
else if (sym == pic->rLE) {
else if (sym == pic->uLE) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sLE);
}
else if (sym == pic->rGT) {
else if (sym == pic->uGT) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sGT);
}
else if (sym == pic->rGE) {
else if (sym == pic->uGE) {
ARGC_ASSERT_WITH_FALLBACK(2);
return CONSTRUCT_OP2(pic->sGE);
}
else if (sym == pic->rNOT) {
else if (sym == pic->uNOT) {
ARGC_ASSERT(1, "not");
return CONSTRUCT_OP1(pic->sNOT);
}
else if (sym == pic->rVALUES) {
else if (sym == pic->uVALUES) {
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);
}
}
@ -1420,7 +1761,7 @@ pic_codegen(pic_state *pic, pic_value obj)
}
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;
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));
#endif
/* macroexpand */
obj = pic_macroexpand(pic, obj, lib);
/* expand */
obj = pic_expand(pic, obj, env);
#if DEBUG
fprintf(stdout, "## macroexpand completed\n");
fprintf(stdout, "## expand completed\n");
pic_debug(pic, obj);
fprintf(stdout, "\n");
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, "dynamic-wind", pic_cont_dynamic_wind);
pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values);
pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values);
pic_defun_vm(pic, "values", pic->uVALUES, pic_cont_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"
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;
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
@ -26,7 +26,7 @@ pic_eval_eval(pic_state *pic)
if (lib == NULL) {
pic_errorf(pic, "no library found: ~s", spec);
}
return pic_eval(pic, program, lib);
return pic_eval(pic, program, lib->env);
}
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: {
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: {
struct pic_env *env = (struct pic_env *)obj;
xh_entry *it;
if (env->up) {
gc_mark_object(pic, (struct pic_object *)env->up);
}
gc_mark(pic, env->defer);
gc_mark_object(pic, (struct pic_object *)env->map);
for (it = xh_begin(&env->map); it != NULL; it = xh_next(it)) {
gc_mark_object(pic, xh_key(it, struct pic_object *));
gc_mark_object(pic, xh_val(it, struct pic_object *));
}
break;
}
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(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(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY);
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(sGREF); M(sLREF); M(sCREF); M(sRETURN);
M(rDEFINE); M(rLAMBDA); M(rIF); M(rBEGIN); M(rQUOTE); M(rSETBANG);
M(rDEFINE_SYNTAX); M(rIMPORT); M(rEXPORT);
M(rDEFINE_LIBRARY);
M(rCOND_EXPAND);
M(rCONS); M(rCAR); M(rCDR); M(rNILP);
M(rSYMBOLP); M(rPAIRP);
M(rADD); M(rSUB); M(rMUL); M(rDIV);
M(rEQ); M(rLT); M(rLE); M(rGT); M(rGE); M(rNOT);
M(rVALUES); M(rCALL_WITH_VALUES);
M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG);
M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT);
M(uDEFINE_LIBRARY);
M(uCOND_EXPAND);
M(uCONS); M(uCAR); M(uCDR); M(uNILP);
M(uSYMBOLP); M(uPAIRP);
M(uADD); M(uSUB); M(uMUL); M(uDIV);
M(uEQ); M(uLT); M(uLE); M(uGT); M(uGE); M(uNOT);
M(uVALUES); M(uCALL_WITH_VALUES);
}
static void
@ -681,7 +692,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_ERROR: {
break;
}
case PIC_TT_ID: {
break;
}
case PIC_TT_ENV: {
struct pic_env *env = (struct pic_env *)obj;
xh_destroy(&env->map);
break;
}
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 *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 *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY;
pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT;
@ -111,15 +113,15 @@ typedef struct {
pic_sym *sCALL, *sTAILCALL, *sRETURN;
pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES;
pic_sym *rDEFINE, *rLAMBDA, *rIF, *rBEGIN, *rQUOTE, *rSETBANG;
pic_sym *rDEFINE_SYNTAX, *rIMPORT, *rEXPORT;
pic_sym *rDEFINE_LIBRARY;
pic_sym *rCOND_EXPAND;
pic_sym *rCONS, *rCAR, *rCDR, *rNILP;
pic_sym *rSYMBOLP, *rPAIRP;
pic_sym *rADD, *rSUB, *rMUL, *rDIV;
pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT;
pic_sym *rVALUES, *rCALL_WITH_VALUES;
pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG;
pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT;
pic_sym *uDEFINE_LIBRARY;
pic_sym *uCOND_EXPAND;
pic_sym *uCONS, *uCAR, *uCDR, *uNILP;
pic_sym *uSYMBOLP, *uPAIRP;
pic_sym *uADD, *uSUB, *uMUL, *uDIV;
pic_sym *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
pic_sym *uVALUES, *uCALL_WITH_VALUES;
struct pic_lib *PICRIN_BASE;
struct pic_lib *PICRIN_USER;
@ -127,6 +129,7 @@ typedef struct {
pic_value features;
xhash syms; /* name to symbol */
int ucnt;
struct pic_dict *globals;
struct pic_dict *macros;
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_cstr(pic_state *, const char *);
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_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_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_eval(pic_state *, pic_value, struct pic_lib *);
struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *);
pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *);
pic_value pic_eval(pic_state *, pic_value, struct pic_env *);
pic_value pic_expand(pic_state *, pic_value, struct pic_env *);
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_find_library(pic_state *, pic_value);

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

@ -9,24 +9,35 @@
extern "C" {
#endif
struct pic_id {
PIC_OBJECT_HEADER
pic_value var;
struct pic_env *env;
};
struct pic_env {
PIC_OBJECT_HEADER
struct pic_dict *map;
pic_value defer;
xhash map;
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_ptr(v) ((struct pic_env *)pic_ptr(v))
bool pic_identifier_p(pic_state *pic, pic_value obj);
bool pic_identifier_eq_p(pic_state *, struct pic_env *, pic_sym *, struct pic_env *, pic_sym *);
struct pic_id *pic_make_id(pic_state *, pic_value, 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_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_uniq(pic_state *, pic_value);
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)
}

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

@ -157,6 +157,7 @@ enum pic_tt {
PIC_TT_PROC,
PIC_TT_PORT,
PIC_TT_ERROR,
PIC_TT_ID,
PIC_TT_CXT,
PIC_TT_ENV,
PIC_TT_LIB,
@ -183,6 +184,7 @@ struct pic_blob;
struct pic_proc;
struct pic_port;
struct pic_error;
struct pic_env;
/* set aliases to basic types */
typedef pic_value pic_list;
@ -314,6 +316,8 @@ pic_type_repr(enum pic_tt tt)
return "port";
case PIC_TT_ERROR:
return "error";
case PIC_TT_ID:
return "id";
case PIC_TT_CXT:
return "cxt";
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 *);
pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->rIMPORT);
pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->rEXPORT);
pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->rCOND_EXPAND);
pic_define_syntactic_keyword(pic, env, pic->sDEFINE_LIBRARY, pic->uDEFINE_LIBRARY);
pic_define_syntactic_keyword(pic, env, pic->sIMPORT, pic->uIMPORT);
pic_define_syntactic_keyword(pic, env, pic->sEXPORT, pic->uEXPORT);
pic_define_syntactic_keyword(pic, env, pic->sCOND_EXPAND, pic->uCOND_EXPAND);
}
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_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));
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_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);
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++) {
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;
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;
@ -317,8 +317,8 @@ pic_init_lib(pic_state *pic)
{
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->sIMPORT, pic->rIMPORT, pic_lib_import);
pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export);
pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library);
pic_defmacro(pic, pic->sCOND_EXPAND, pic->uCOND_EXPAND, pic_lib_condexpand);
pic_defmacro(pic, pic->sIMPORT, pic->uIMPORT, pic_lib_import);
pic_defmacro(pic, pic->sEXPORT, pic->uEXPORT, pic_lib_export);
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);
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);
}

521
extlib/benz/macro.c
View File

@ -4,434 +4,92 @@
#include "picrin.h"
pic_sym *
pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym)
bool
pic_var_p(pic_value obj)
{
pic_sym *rename = pic_gensym(pic, sym);
pic_put_rename(pic, env, sym, rename);
return rename;
return pic_sym_p(obj) || pic_id_p(obj);
}
void
pic_put_rename(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rename)
struct pic_id *
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 *
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));
}
assert(pic_var_p(var));
static void
define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac)
{
pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac));
}
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;
id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID);
id->var = var;
id->env = env;
return id;
}
struct pic_env *
pic_make_env(pic_state *pic, struct pic_env *up)
{
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->up = up;
env->defer = pic_nil_value();
env->map = map;
xh_init_ptr(&env->map, sizeof(pic_sym *));
return env;
}
static pic_value
defmacro_call(pic_state *pic)
pic_sym *
pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var)
{
struct pic_proc *self = pic_get_proc(pic);
pic_value args, tmp, proc;
assert(pic_var_p(var));
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
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));
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);
xh_put_ptr(&env->map, pic_ptr(var), &uid);
}
bool
pic_identifier_p(pic_state *pic, pic_value obj)
pic_sym *
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
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;
assert(pic_var_p(var));
a = make_identifier(pic, sym1, env1);
if (a != make_identifier(pic, sym1, env1)) {
a = sym1;
if ((e = xh_get_ptr(&env->map, pic_ptr(var))) == NULL) {
return NULL;
}
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));
return xh_val(e, pic_sym *);
}
static pic_value
@ -441,40 +99,83 @@ pic_macro_identifier_p(pic_state *pic)
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
pic_macro_make_identifier(pic_state *pic)
{
pic_value obj;
pic_sym *sym;
pic_value var, env;
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
pic_macro_identifier_eq_p(pic_state *pic)
pic_macro_identifier_variable(pic_state *pic)
{
pic_sym *sym1, *sym2;
pic_value env1, env2;
pic_value id;
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, env2, env);
pic_assert_type(pic, id, id);
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
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, "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_gc_arena_restore(pic, ai);
pic_defun_vm(pic, "=", pic->rEQ, pic_number_eq);
pic_defun_vm(pic, "<", pic->rLT, pic_number_lt);
pic_defun_vm(pic, ">", pic->rGT, pic_number_gt);
pic_defun_vm(pic, "<=", pic->rLE, pic_number_le);
pic_defun_vm(pic, ">=", pic->rGE, pic_number_ge);
pic_defun_vm(pic, "=", pic->uEQ, pic_number_eq);
pic_defun_vm(pic, "<", pic->uLT, pic_number_lt);
pic_defun_vm(pic, ">", pic->uGT, pic_number_gt);
pic_defun_vm(pic, "<=", pic->uLE, pic_number_le);
pic_defun_vm(pic, ">=", pic->uGE, pic_number_ge);
pic_gc_arena_restore(pic, ai);
pic_defun_vm(pic, "+", pic->rADD, pic_number_add);
pic_defun_vm(pic, "-", pic->rSUB, pic_number_sub);
pic_defun_vm(pic, "*", pic->rMUL, pic_number_mul);
pic_defun_vm(pic, "/", pic->rDIV, pic_number_div);
pic_defun_vm(pic, "+", pic->uADD, pic_number_add);
pic_defun_vm(pic, "-", pic->uSUB, pic_number_sub);
pic_defun_vm(pic, "*", pic->uMUL, pic_number_mul);
pic_defun_vm(pic, "/", pic->uDIV, pic_number_div);
pic_gc_arena_restore(pic, ai);
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);
pic_defun_vm(pic, "pair?", pic->rPAIRP, pic_pair_pair_p);
pic_defun_vm(pic, "cons", pic->rCONS, pic_pair_cons);
pic_defun_vm(pic, "car", pic->rCAR, pic_pair_car);
pic_defun_vm(pic, "cdr", pic->rCDR, pic_pair_cdr);
pic_defun_vm(pic, "null?", pic->rNILP, pic_pair_null_p);
pic_defun_vm(pic, "pair?", pic->uPAIRP, pic_pair_pair_p);
pic_defun_vm(pic, "cons", pic->uCONS, pic_pair_cons);
pic_defun_vm(pic, "car", pic->uCAR, pic_pair_car);
pic_defun_vm(pic, "cdr", pic->uCDR, pic_pair_cdr);
pic_defun_vm(pic, "null?", pic->uNILP, pic_pair_null_p);
pic_defun(pic, "set-car!", pic_pair_set_car);
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));
return pic_eval(pic, form, pic->lib);
return pic_eval(pic, form, pic->lib->env);
}
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)));
}
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
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['t'] = read_true;
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_vector;
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)") {
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->sSETBANG, pic->rSETBANG);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->uDEFINE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO);
pic_init_undef(pic); DONE;
pic_init_bool(pic); DONE;
@ -222,6 +222,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
/* symbol table */
xh_init_str(&pic->syms, sizeof(pic_sym *));
/* unique symbol count */
pic->ucnt = 0;
/* global variables */
pic->globals = NULL;
@ -254,7 +257,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
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(sLAMBDA, "lambda");
@ -265,7 +268,11 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
S(sQUASIQUOTE, "quasiquote");
S(sUNQUOTE, "unquote");
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(sEXPORT, "export");
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);
#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");
R(rLAMBDA, "lambda");
R(rIF, "if");
R(rBEGIN, "begin");
R(rSETBANG, "set!");
R(rQUOTE, "quote");
R(rDEFINE_SYNTAX, "define-syntax");
R(rIMPORT, "import");
R(rEXPORT, "export");
R(rDEFINE_LIBRARY, "define-library");
R(rCOND_EXPAND, "cond-expand");
R(rCONS, "cons");
R(rCAR, "car");
R(rCDR, "cdr");
R(rNILP, "null?");
R(rSYMBOLP, "symbol?");
R(rPAIRP, "pair?");
R(rADD, "+");
R(rSUB, "-");
R(rMUL, "*");
R(rDIV, "/");
R(rEQ, "=");
R(rLT, "<");
R(rLE, "<=");
R(rGT, ">");
R(rGE, ">=");
R(rNOT, "not");
R(rVALUES, "values");
R(rCALL_WITH_VALUES, "call-with-values");
U(uDEFINE, "define");
U(uLAMBDA, "lambda");
U(uIF, "if");
U(uBEGIN, "begin");
U(uSETBANG, "set!");
U(uQUOTE, "quote");
U(uDEFINE_MACRO, "define-macro");
U(uIMPORT, "import");
U(uEXPORT, "export");
U(uDEFINE_LIBRARY, "define-library");
U(uCOND_EXPAND, "cond-expand");
U(uCONS, "cons");
U(uCAR, "car");
U(uCDR, "cdr");
U(uNILP, "null?");
U(uSYMBOLP, "symbol?");
U(uPAIRP, "pair?");
U(uADD, "+");
U(uSUB, "-");
U(uMUL, "*");
U(uDIV, "/");
U(uEQ, "=");
U(uLT, "<");
U(uLE, "<=");
U(uGT, ">");
U(uGE, ">=");
U(uNOT, "not");
U(uVALUES, "values");
U(uCALL_WITH_VALUES, "call-with-values");
pic_gc_arena_restore(pic, ai);
/* root tables */

23
extlib/benz/symbol.c
View File

@ -4,7 +4,7 @@
#include "picrin.h"
pic_sym *
static pic_sym *
pic_make_symbol(pic_state *pic, pic_str *str)
{
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)));
}
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 *
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);
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, "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
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) {
pic_export(pic, sym);
@ -406,17 +406,17 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym,
void
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);
if ((rename = pic_find_rename(pic, pic->lib->env, sym)) == NULL) {
rename = pic_add_rename(pic, pic->lib->env, sym);
if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) {
uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym));
} else {
pic_warnf(pic, "redefining global");
}
pic_dict_set(pic, pic->globals, rename, val);
pic_dict_set(pic, pic->globals, uid, val);
}
void
@ -430,29 +430,29 @@ pic_define(pic_state *pic, const char *name, pic_value val)
pic_value
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);
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);
}
return pic_dict_ref(pic, pic->globals, rename);
return pic_dict_ref(pic, pic->globals, uid);
}
void
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);
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_dict_set(pic, pic->globals, rename, val);
pic_dict_set(pic, pic->globals, uid, val);
}
pic_value
@ -477,7 +477,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
}
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;
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);
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);
}
@ -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)));
}
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
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, ")");
break;
case PIC_TT_ID:
xfprintf(file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(pic, obj)));
break;
default:
xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
break;

19
piclib/picrin/base.scm
View File

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

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

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

263
piclib/picrin/macro.scm
View File

@ -1,141 +1,180 @@
(define-library (picrin macro)
(import (picrin base))
(export identifier?
identifier=?
;; macro primitives
(export define-macro
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
close-syntax
capture-syntactic-environment
strip-syntax
sc-macro-transformer
rsc-macro-transformer
er-macro-transformer
ir-macro-transformer
;; strip-syntax
define-macro)
ir-macro-transformer)
;; assumes no derived expressions are provided yet
(define (walk proc expr)
"walk on symbols"
(if (null? expr)
'()
(if (pair? expr)
(cons (walk proc (car expr))
(walk proc (cdr expr)))
(if (vector? expr)
(list->vector (walk proc (vector->list expr)))
(if (symbol? expr)
(proc expr)
expr)))))
(define-macro call-with-current-environment
(lambda (form env)
`(,(cadr form) ',env)))
;; syntactic closure
(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 resolve
(memoize
(lambda (sym)
(make-identifier sym env))))
(walk
(lambda (sym)
(if (memq sym free)
sym
(resolve sym)))
form))
(letrec
((wrap (let ((register (make-register)))
(lambda (var)
(let ((id (register var)))
(if (undefined? id)
(let ((id (make-identifier var env)))
(register var id)
id)
id)))))
(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)))))
(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)
(make-syntactic-closure env '() form))
(define-syntax capture-syntactic-environment
(lambda (mac-env)
(lambda (form use-env)
(list (cadr form) (list (make-identifier 'quote mac-env) mac-env)))))
(define (strip-syntax form)
(letrec
((unwrap (lambda (var)
(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)
(lambda (mac-env)
(lambda (expr use-env)
(make-syntactic-closure use-env '() (f expr mac-env)))))
;; transformers
(define (er-macro-transformer f)
(lambda (mac-env)
(lambda (expr use-env)
(define rename
(memoize
(lambda (sym)
(make-identifier sym mac-env))))
(define (sc-transformer f)
(lambda (form use-env mac-env)
(make-syntactic-closure mac-env '() (f form use-env))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#f
(identifier=? use-env x use-env y))))
(define (rsc-transformer f)
(lambda (form use-env mac-env)
(make-syntactic-closure use-env '() (f form mac-env))))
(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)
(lambda (mac-env)
(lambda (expr use-env)
(define (ir-transformer f)
(lambda (form use-env mac-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
(memoize
(lambda (sym)
(define id (make-identifier sym use-env))
(dictionary-set! icache* id sym)
id)))
(define-macro rsc-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((rsc-transformer #,(cadr f)) form use-env #,mac-env))))
(define rename
(memoize
(lambda (sym)
(make-identifier sym mac-env))))
(define-macro er-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((er-transformer #,(cadr f)) form use-env #,mac-env))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#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))))))))
(define-macro ir-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((ir-transformer #,(cadr f)) form use-env #,mac-env)))))

96
piclib/picrin/record.scm
View File

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

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

@ -1,348 +1,243 @@
(define-library (picrin syntax-rules)
(import (picrin base)
(picrin control)
(picrin macro))
(define-syntax define-auxiliary-syntax
(er-macro-transformer
(lambda (expr r c)
(list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_
(list (r 'lambda) '_
(list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'"))))))))
(define-syntax (define-auxiliary-syntax var)
#`(define-macro #,var
(lambda _
(error "invalid use of auxiliary syntax" '#,var))))
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define (walk proc expr)
(cond
((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 (succ n)
(+ n 1))
(define (flatten expr)
(let ((list '()))
(walk
(lambda (x)
(set! list (cons x list)))
expr)
(reverse list)))
(define (pred n)
(if (= n 0)
0
(- n 1)))
(define (reverse* l)
;; (reverse* '(a b c d . e)) => (e d c b a)
(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)
(define (every? args)
(if (null? args)
#t
(and (pred (car l)) (every? pred (cdr l)))))
(if (car args)
(every? (cdr args))
#f)))
(define-syntax syntax-rules
(er-macro-transformer
(lambda (form r compare)
(define _define (r 'define))
(define _let (r 'let))
(define _if (r 'if))
(define _begin (r 'begin))
(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 (filter f list)
(if (null? list)
'()
(if (f (car list))
(cons (car list)
(filter f (cdr list)))
(filter f (cdr list)))))
(define (var->sym v)
(let loop ((cnt 0)
(v v))
(if (symbol? v)
(string->symbol
(string-append (symbol->string v) "/" (number->string cnt)))
(loop (+ 1 cnt) (car v)))))
(define (take-tail n list)
(let drop ((n (- (length list) n)) (list list))
(if (= n 0)
list
(drop (- n 1) (cdr list)))))
(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)
(letrec ((compile-match-base
(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))
'())))))
(define (map-keys f assoc)
(map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
(compile-match-list
(lambda (pattern)
(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))))))))
(define (map-values f assoc)
(map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
(compile-match-list-reverse
(lambda (pattern)
(let loop ((pattern (reverse* pattern))
(matches '())
(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))))))))
;; TODO
;; - placeholder
;; - vector
;; - (... template) pattern
(compile-match-ellipsis
(lambda (pattern)
(let-values (((match vars) (compile-match-base pattern)))
(values
`(,_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)))))
;; p ::= constant
;; | var
;; | (p ... . p) (in input pattern, tail p should be a proper list)
;; | (p . p)
(compile-match-vector
(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)))))
(define (compile ellipsis literals rules)
(let-values (((match vars) (compile-match-base (cdr pattern))))
(values `(,_let ((expr (,_cdr expr)))
,match
#t)
vars))))
(define (constant? obj)
(and (not (pair? obj))
(not (variable? obj))))
;;; compile expand
(define (compile-expand ellipsis reserved template)
(letrec ((compile-expand-base
(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 '())))))
(define (literal? obj)
(and (variable? obj)
(memq obj literals)))
(compile-expand-list
(lambda (template ellipsis-valid)
(let loop ((template template)
(expands '())
(vars '()))
(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))))))))
(define (many? pat)
(and (pair? pat)
(pair? (cdr pat))
(variable? (cadr pat))
(variable=? (cadr pat) ellipsis)))
(compile-expand-vector
(lambda (template ellipsis-valid)
(let-values (((expand1 vars1)
(compile-expand-base (vector->list template) ellipsis-valid)))
(values
`(,_list->vector ,expand1)
vars1)))))
(define (pattern-validator pat) ; pattern -> validator
(letrec
((pattern-validator
(lambda (pat form)
(cond
((constant? pat)
#`(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)
;;fixme
#t)
(define (pattern-levels pat) ; pattern -> ((var * int))
(cond
((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)
(let ((pattern (car rule))
(template (cadr rule)))
(let*-values (((match vars-match)
(compile-match ellipsis literals pattern))
((expand vars-expand)
(compile-expand ellipsis (flatten vars-match) template)))
(if (check-vars vars-match vars-expand)
(list vars-match match expand)
'mismatch))))
(define (pattern-selectors pat) ; pattern -> ((var * selector))
(letrec
((pattern-selectors
(lambda (pat form)
(cond
((constant? pat)
'())
((literal? pat)
'())
((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)
(cond ((null? clauses)
`(,_quote (syntax-error "no matching pattern")))
((compare (car clauses) 'mismatch)
`(,_syntax-error "invalid rule"))
(else
(let ((vars (list-ref (car clauses) 0))
(match (list-ref (car clauses) 1))
(expand (list-ref (car clauses) 2)))
`(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
(,_let ((result (,_escape (,_lambda (exit) ,match))))
(,_if result
,expand
,(expand-clauses (cdr clauses) rename))))))))
(define (template-representation pat levels selectors)
(cond
((constant? pat)
pat)
((variable? pat)
(let ((it (assq pat levels)))
(if it
(if (= 0 (cdr it))
(cdr (assq pat selectors))
(error "unmatched pattern variable level" pat))
#`(#,'rename '#,pat))))
((many? pat)
(letrec*
((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)
(if (and (list? form) (>= (length form) 2))
(let ((ellipsis '...)
(literals (cadr form))
(rules (cddr form)))
(define (compile-rule pattern template)
(let ((levels
(pattern-levels pattern))
(selectors
(pattern-selectors pattern)))
(template-representation template levels selectors)))
(when (symbol? literals)
(set! ellipsis literals)
(set! literals (car rules))
(set! rules (cdr rules)))
(define (compile-rules rules)
(if (null? rules)
#`(error "unmatch")
(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)
(list? literals)
(every? symbol? literals)
(list? rules)
(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
(if (member ellipsis literals compare)
`(syntax-rules #f ,literals ,@rules)
`(syntax-rules ,ellipsis ,literals ,@rules))
#f))
#f))
(define (compile rules)
#`(call-with-current-environment
(lambda (env)
(letrec
((#,'rename (let ((reg (make-register)))
(lambda (x)
(if (undefined? (reg x))
(let ((id (make-identifier x env)))
(reg x id)
id)
(reg x))))))
(lambda #,'it
#,(compile-rules rules))))))
(let ((form (normalize-form form)))
(if form
(let ((ellipsis (list-ref form 1))
(literals (list-ref form 2))
(rules (list-tail form 3)))
(let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
rules)))
`(,_er-macro-transformer
(,_lambda (expr rename cmp)
,(expand-clauses clauses r)))))
(let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
(compile rules)))
(define-syntax (syntax-rules . args)
(if (list? (car args))
#`(syntax-rules ... #,@args)
(let ((ellipsis (car args))
(literals (car (cdr args)))
(rules (cdr (cdr args))))
(compile ellipsis literals rules))))
`(,_syntax-error "malformed syntax-rules"))))))
(export syntax-rules
_

6
t/r7rs-tests.scm
View File

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