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

Merge branch 'rewrite-er-in-scheme'

This commit is contained in:
Yuichi Nishiwaki 2014-07-17 16:16:52 +09:00
parent a8751ab3ba 0fb9e18735
commit d2bcee5483
9 changed files with 244 additions and 382 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
include/picrin/macro.h
View File

@ -21,15 +21,6 @@ struct pic_macro {
struct pic_senv *senv;
};
struct pic_sc {
PIC_OBJECT_HEADER
pic_value expr;
struct pic_senv *senv;
};
#define pic_sc_p(v) (pic_type(v) == PIC_TT_SC)
#define pic_sc_ptr(v) ((struct pic_sc *)pic_ptr(v))
#define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO)
#define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v))
@ -38,6 +29,9 @@ struct pic_sc {
struct pic_senv *pic_null_syntactic_environment(pic_state *);
bool pic_identifier_p(pic_state *pic, pic_value obj);
bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym);
pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */);
void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym);

3
include/picrin/value.h
View File

@ -111,7 +111,6 @@ enum pic_tt {
PIC_TT_CONT,
PIC_TT_SENV,
PIC_TT_MACRO,
PIC_TT_SC,
PIC_TT_LIB,
PIC_TT_VAR,
PIC_TT_IREP,
@ -256,8 +255,6 @@ pic_type_repr(enum pic_tt tt)
return "cont";
case PIC_TT_PROC:
return "proc";
case PIC_TT_SC:
return "sc";
case PIC_TT_SENV:
return "senv";
case PIC_TT_MACRO:

165
piclib/built-in.scm
View File

@ -36,7 +36,61 @@
;;; hygienic macros
(define-library (picrin macro)
(import (scheme base))
(import (scheme base)
(picrin dictionary))
(define (memq obj list)
(if (null? list)
#f
(if (eq? obj (car list))
list
(memq obj (cdr list)))))
(define (list->vector list)
(define vector (make-vector (length list)))
(define (go list i)
(if (null? list)
vector
(begin
(vector-set! vector i (car list))
(go (cdr list) (+ i 1)))))
(go list 0))
(define (vector->list vector)
(define (go i)
(if (= i (vector-length vector))
'()
(cons (vector-ref vector i)
(go (+ i 1)))))
(go 0))
(define (vector-map proc expr)
(list->vector (map proc (vector->list expr))))
(define (walk proc expr)
(if (null? expr)
'()
(if (pair? expr)
(cons (walk proc (car expr))
(walk proc (cdr expr)))
(if (vector? expr)
(vector-map proc expr)
(proc expr)))))
(define (make-syntactic-closure form free env)
(define cache (make-dictionary))
(walk
(lambda (atom)
(if (not (symbol? atom))
atom
(if (memq atom free)
atom
(if (dictionary-has? cache atom)
(dictionary-ref cache atom)
(begin
(define id (make-identifier atom env))
(dictionary-set! cache atom id)
id)))))))
(define (sc-macro-transformer f)
(lambda (expr use-env mac-env)
@ -46,8 +100,84 @@
(lambda (expr use-env mac-env)
(make-syntactic-closure use-env '() (f expr mac-env))))
(define (er-macro-transformer f)
(lambda (expr use-env mac-env)
(define cache (make-dictionary))
(define (rename sym)
(if (dictionary-has? cache sym)
(dictionary-ref cache sym)
(begin
(define id (make-identifier sym mac-env))
(dictionary-set! cache sym id)
id)))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#f
(identifier=? use-env x use-env y))))
(f expr rename compare)))
(define (ir-macro-transformer f)
(lambda (expr use-env mac-env)
(define protects (make-dictionary))
(define (wrap expr)
(walk
(lambda (atom)
(if (not (symbol? atom))
atom
(begin
(define id (make-identifier atom use-env))
(dictionary-set! protects id atom) ; lookup *atom* from id
id)))
expr))
(define (unwrap expr)
(define cache (make-dictionary))
(walk
(lambda (atom)
(if (not (symbol? atom))
atom
(if (dictionary-has? protects atom)
(dictionary-ref protects atom)
(if (dictionary-has? cache atom)
(dictionary-ref cache atom)
(begin
;; implicit renaming
(define id (make-identifier atom mac-env))
(dictionary-set! cache atom id)
id)))))
expr))
(define cache (make-dictionary))
(define (inject sym)
(if (dictionary-has? cache sym)
(dictionary-ref cache sym)
(begin
(define id (make-identifier sym use-env))
(dictionary-set! cache sym id)
id)))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#f
(identifier=? mac-env x mac-env y))))
(unwrap (f (wrap expr) inject compare))))
(export sc-macro-transformer
rsc-macro-transformer))
rsc-macro-transformer
er-macro-transformer
ir-macro-transformer))
;;; core syntaces
(define-library (picrin core-syntax)
@ -55,6 +185,20 @@
(scheme cxr)
(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 'error) "invalid use of auxiliary syntax"))))))
(define-auxiliary-syntax else)
(define-auxiliary-syntax =>)
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define-auxiliary-syntax unquote)
(define-auxiliary-syntax unquote-splicing)
(define-syntax let
(er-macro-transformer
(lambda (expr r compare)
@ -308,21 +452,6 @@
(lambda (expr rename compare)
(apply error (cdr expr)))))
(define-syntax define-auxiliary-syntax
(er-macro-transformer
(lambda (expr r c)
`(,(r 'define-syntax) ,(cadr expr)
(,(r 'sc-macro-transformer)
(,(r 'lambda) (expr env)
(,(r 'error) "invalid use of auxiliary syntax")))))))
(define-auxiliary-syntax else)
(define-auxiliary-syntax =>)
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define-auxiliary-syntax unquote)
(define-auxiliary-syntax unquote-splicing)
(export let let* letrec letrec*
quasiquote unquote unquote-splicing
and or
@ -1289,7 +1418,7 @@
(define (compile-expand ellipsis reserved template)
(letrec ((compile-expand-base
(lambda (template ellipsis-valid)
(cond ((member template reserved compare)
(cond ((member template reserved eq?)
(values (var->sym template) (list template)))
((symbol? template)
(values `(rename ',template) '()))

1
src/codegen.c
View File

@ -826,7 +826,6 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
case PIC_TT_ERROR:
case PIC_TT_SENV:
case PIC_TT_MACRO:
case PIC_TT_SC:
case PIC_TT_LIB:
case PIC_TT_VAR:
case PIC_TT_IREP:

12
src/dict.c
View File

@ -109,6 +109,17 @@ pic_dict_dict_set(pic_state *pic)
return pic_none_value();
}
static pic_value
pic_dict_dict_has_p(pic_state *pic)
{
struct pic_dict *dict;
pic_sym key;
pic_get_args(pic, "dm", &dict, &key);
return pic_bool_value(pic_dict_has(pic, dict, key));
}
static pic_value
pic_dict_dict_del(pic_state *pic)
{
@ -155,6 +166,7 @@ pic_init_dict(pic_state *pic)
pic_deflibrary ("(picrin dictionary)") {
pic_defun(pic, "make-dictionary", pic_dict_dict);
pic_defun(pic, "dictionary?", pic_dict_dict_p);
pic_defun(pic, "dictionary-has?", pic_dict_dict_has_p);
pic_defun(pic, "dictionary-ref", pic_dict_dict_ref);
pic_defun(pic, "dictionary-set!", pic_dict_dict_set);
pic_defun(pic, "dictionary-delete", pic_dict_dict_del);

9
src/gc.c
View File

@ -461,12 +461,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
break;
}
case PIC_TT_SC: {
struct pic_sc *sc = (struct pic_sc *)obj;
gc_mark(pic, sc->expr);
gc_mark_object(pic, (struct pic_object *)sc->senv);
break;
}
case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj;
gc_mark(pic, lib->name);
@ -641,9 +635,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_MACRO: {
break;
}
case PIC_TT_SC: {
break;
}
case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj;
xh_destroy(&lib->exports);

385
src/macro.c
View File

@ -74,7 +74,7 @@ find_macro(pic_state *pic, pic_sym rename)
}
static pic_sym
translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv)
{
pic_sym rename;
@ -86,21 +86,15 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c
break;
senv = senv->up;
}
if (pic_dict_has(pic, cxt, sym)) {
return pic_sym(pic_dict_ref(pic, cxt, sym));
} else {
rename = pic_gensym(pic, sym);
pic_dict_set(pic, cxt, sym, pic_sym_value(rename));
return rename;
}
return pic_gensym(pic, sym);
}
static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *);
static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
static pic_value
macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv)
{
return pic_sym_value(translate(pic, sym, senv, cxt));
return pic_sym_value(make_identifier(pic, sym, senv));
}
static pic_value
@ -187,17 +181,17 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr)
}
static pic_value
macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv)
{
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), senv, cxt);
tail = macroexpand_list(pic, pic_cdr(pic, obj), senv, cxt);
head = macroexpand(pic, pic_car(pic, obj), senv);
tail = macroexpand_list(pic, pic_cdr(pic, obj), senv);
x = pic_cons(pic, head, tail);
} else {
x = macroexpand(pic, obj, senv, cxt);
x = macroexpand(pic, obj, senv);
}
pic_gc_arena_restore(pic, ai);
@ -206,7 +200,7 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pi
}
static pic_value
macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_value formal, body;
struct pic_senv *in;
@ -224,7 +218,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
pic_value v = pic_car(pic, a);
if (! pic_sym_p(v)) {
v = macroexpand(pic, v, senv, cxt);
v = macroexpand(pic, v, senv);
}
if (! pic_sym_p(v)) {
pic_error(pic, "syntax error");
@ -232,7 +226,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
pic_add_rename(pic, in, pic_sym(v));
}
if (! pic_sym_p(a)) {
a = macroexpand(pic, a, senv, cxt);
a = macroexpand(pic, a, senv);
}
if (pic_sym_p(a)) {
pic_add_rename(pic, in, pic_sym(a));
@ -241,14 +235,14 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
pic_error(pic, "syntax error");
}
formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt);
body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt);
formal = macroexpand_list(pic, pic_cadr(pic, expr), in);
body = macroexpand_list(pic, pic_cddr(pic, expr), in);
return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body));
}
static pic_value
macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_sym sym;
pic_value formal, body, var, val;
@ -267,7 +261,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
var = formal;
}
if (! pic_sym_p(var)) {
var = macroexpand(pic, var, senv, cxt);
var = macroexpand(pic, var, senv);
}
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
@ -278,15 +272,15 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
}
body = pic_cddr(pic, expr);
if (pic_pair_p(formal)) {
val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv, cxt);
val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv);
} else {
val = macroexpand(pic, pic_car(pic, body), senv, cxt);
val = macroexpand(pic, pic_car(pic, body), senv);
}
return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv), val);
}
static pic_value
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_value var, val;
pic_sym sym, rename;
@ -297,7 +291,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, str
var = pic_cadr(pic, expr);
if (! pic_sym_p(var)) {
var = macroexpand(pic, var, senv, cxt);
var = macroexpand(pic, var, senv);
}
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
@ -372,7 +366,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
}
static pic_value
macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
struct pic_senv *in;
pic_value formal, v, var, val;
@ -393,7 +387,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st
pic_for_each (v, formal) {
var = pic_car(pic, v);
if (! pic_sym_p(var)) {
var = macroexpand(pic, var, senv, cxt);
var = macroexpand(pic, var, senv);
}
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
@ -408,11 +402,11 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st
}
define_macro(pic, rename, pic_proc_ptr(val), senv);
}
return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt));
return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in));
}
static pic_value
macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
{
pic_value v, args;
@ -441,11 +435,11 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
puts("");
#endif
return macroexpand(pic, v, senv, cxt);
return macroexpand(pic, v, senv);
}
static pic_value
macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
#if DEBUG
printf("[macroexpand] expanding... ");
@ -454,11 +448,8 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
#endif
switch (pic_type(expr)) {
case PIC_TT_SC: {
return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, cxt);
}
case PIC_TT_SYMBOL: {
return macroexpand_symbol(pic, pic_sym(expr), senv, cxt);
return macroexpand_symbol(pic, pic_sym(expr), senv);
}
case PIC_TT_PAIR: {
pic_value car;
@ -468,7 +459,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
}
car = macroexpand(pic, pic_car(pic, expr), senv, cxt);
car = macroexpand(pic, pic_car(pic, expr), senv);
if (pic_sym_p(car)) {
pic_sym tag = pic_sym(car);
@ -482,33 +473,33 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
return macroexpand_export(pic, expr);
}
else if (tag == pic->rDEFINE_SYNTAX) {
return macroexpand_defsyntax(pic, expr, senv, cxt);
return macroexpand_defsyntax(pic, expr, senv);
}
else if (tag == pic->rDEFINE_MACRO) {
return macroexpand_defmacro(pic, expr, senv);
}
else if (tag == pic->rLET_SYNTAX) {
return macroexpand_let_syntax(pic, expr, senv, cxt);
return macroexpand_let_syntax(pic, expr, senv);
}
/* else if (tag == pic->sLETREC_SYNTAX) { */
/* return macroexpand_letrec_syntax(pic, expr, senv, cxt); */
/* return macroexpand_letrec_syntax(pic, expr, senv); */
/* } */
else if (tag == pic->rLAMBDA) {
return macroexpand_lambda(pic, expr, senv, cxt);
return macroexpand_lambda(pic, expr, senv);
}
else if (tag == pic->rDEFINE) {
return macroexpand_define(pic, expr, senv, cxt);
return macroexpand_define(pic, expr, senv);
}
else if (tag == pic->rQUOTE) {
return macroexpand_quote(pic, expr);
}
if ((mac = find_macro(pic, tag)) != NULL) {
return macroexpand_macro(pic, mac, expr, senv, cxt);
return macroexpand_macro(pic, mac, expr, senv);
}
}
return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt));
return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
}
case PIC_TT_EOF:
case PIC_TT_NIL:
@ -541,12 +532,12 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
}
static pic_value
macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v;
v = macroexpand_node(pic, expr, senv, cxt);
v = macroexpand_node(pic, expr, senv);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
@ -564,7 +555,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
puts("");
#endif
v = macroexpand(pic, expr, pic->lib->senv, pic_dict_new(pic));
v = macroexpand(pic, expr, pic->lib->senv);
#if DEBUG
puts("after expand:");
@ -615,6 +606,21 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
pic_export(pic, sym);
}
bool
pic_identifier_p(pic_state *pic, pic_value obj)
{
return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj));
}
bool
pic_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_sym x, struct pic_senv *e2, pic_sym y)
{
x = make_identifier(pic, x, e1);
y = make_identifier(pic, y, e2);
return x == y;
}
static pic_value
pic_macro_gensym(pic_state *pic)
{
@ -637,63 +643,6 @@ pic_macro_macroexpand(pic_state *pic)
return pic_macroexpand(pic, expr);
}
static struct pic_sc *
sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
struct pic_sc *sc;
sc = (struct pic_sc *)pic_obj_alloc(pic, sizeof(struct pic_sc), PIC_TT_SC);
sc->expr = expr;
sc->senv = senv;
return sc;
}
static bool
sc_identifier_p(pic_value obj)
{
if (pic_sym_p(obj)) {
return true;
}
if (pic_sc_p(obj)) {
return sc_identifier_p(pic_sc_ptr(obj)->expr);
}
return false;
}
static bool
sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y)
{
struct pic_dict *cxt;
if (! (sc_identifier_p(x) && sc_identifier_p(y))) {
return false;
}
cxt = pic_dict_new(pic);
x = macroexpand(pic, x, e1, cxt);
y = macroexpand(pic, y, e2, cxt);
return pic_eq_p(x, y);
}
static pic_value
pic_macro_make_sc(pic_state *pic)
{
pic_value senv, free_vars, expr;
struct pic_sc *sc;
pic_get_args(pic, "ooo", &senv, &free_vars, &expr);
if (! pic_senv_p(senv))
pic_error(pic, "make-syntactic-closure: senv required");
/* just ignore free_vars for now */
sc = sc_new(pic, expr, pic_senv_ptr(senv));
return pic_obj_value(sc);
}
static pic_value
pic_macro_identifier_p(pic_state *pic)
{
@ -701,16 +650,17 @@ pic_macro_identifier_p(pic_state *pic)
pic_get_args(pic, "o", &obj);
return pic_bool_value(sc_identifier_p(obj));
return pic_bool_value(pic_identifier_p(pic, obj));
}
static pic_value
pic_macro_identifier_eq_p(pic_state *pic)
{
pic_value e, x, f, y;
pic_sym x, y;
pic_value e, f;
struct pic_senv *e1, *e2;
pic_get_args(pic, "oooo", &e, &x, &f, &y);
pic_get_args(pic, "omom", &e, &x, &f, &y);
if (! pic_senv_p(e)) {
pic_error(pic, "unexpected type of argument 1");
@ -721,223 +671,20 @@ pic_macro_identifier_eq_p(pic_state *pic)
}
e2 = pic_senv_ptr(f);
return pic_bool_value(sc_identifier_eq_p(pic, e1, x, e2, y));
return pic_bool_value(pic_identifier_eq_p(pic, e1, x, e2, y));
}
static pic_value
er_macro_rename(pic_state *pic)
pic_macro_make_identifier(pic_state *pic)
{
pic_value obj;
pic_sym sym;
struct pic_senv *mac_env;
struct pic_dict *cxt;
pic_get_args(pic, "m", &sym);
pic_get_args(pic, "mo", &sym, &obj);
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
pic_assert_type(pic, obj, senv);
return pic_sym_value(translate(pic, sym, mac_env, cxt));
}
static pic_value
er_macro_compare(pic_state *pic)
{
pic_value a, b;
struct pic_senv *use_env;
pic_sym m, n;
struct pic_dict *cxt;
pic_get_args(pic, "oo", &a, &b);
if (! pic_sym_p(a) || ! pic_sym_p(b))
return pic_false_value(); /* should be an error? */
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
m = translate(pic, pic_sym(a), use_env, cxt);
n = translate(pic, pic_sym(b), use_env, cxt);
return pic_bool_value(m == n);
}
static pic_value
er_macro_call(pic_state *pic)
{
pic_value expr, use_env, mac_env;
struct pic_proc *rename, *compare, *cb;
struct pic_dict *cxt;
pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
if (! pic_senv_p(use_env)) {
pic_error(pic, "unexpected type of argument 1");
}
if (! pic_senv_p(mac_env)) {
pic_error(pic, "unexpected type of argument 3");
}
cxt = pic_dict_new(pic);
rename = pic_proc_new(pic, er_macro_rename, "<er-macro-renamer>");
pic_proc_cv_init(pic, rename, 3);
pic_proc_cv_set(pic, rename, 0, use_env);
pic_proc_cv_set(pic, rename, 1, mac_env);
pic_proc_cv_set(pic, rename, 2, pic_obj_value(cxt));
compare = pic_proc_new(pic, er_macro_compare, "<er-macro-comparator>");
pic_proc_cv_init(pic, compare, 3);
pic_proc_cv_set(pic, compare, 0, use_env);
pic_proc_cv_set(pic, compare, 1, mac_env);
pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
return pic_apply3(pic, cb, expr, pic_obj_value(rename), pic_obj_value(compare));
}
static pic_value
pic_macro_er_macro_transformer(pic_state *pic)
{
struct pic_proc *cb, *proc;
pic_get_args(pic, "l", &cb);
proc = pic_proc_new(pic, er_macro_call, "<er-macro-procedure>");
pic_proc_cv_init(pic, proc, 1);
pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
return pic_obj_value(proc);
}
static pic_value
ir_macro_inject(pic_state *pic)
{
pic_sym sym;
struct pic_senv *use_env;
struct pic_dict *cxt;
pic_get_args(pic, "m", &sym);
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
return pic_sym_value(translate(pic, sym, use_env, cxt));
}
static pic_value
ir_macro_compare(pic_state *pic)
{
pic_value a, b;
struct pic_senv *mac_env;
pic_sym m, n;
struct pic_dict *cxt;
pic_get_args(pic, "oo", &a, &b);
if (! pic_sym_p(a) || ! pic_sym_p(b))
return pic_false_value(); /* should be an error? */
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
m = translate(pic, pic_sym(a), mac_env, cxt);
n = translate(pic, pic_sym(b), mac_env, cxt);
return pic_bool_value(m == n);
}
static pic_value
ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir)
{
if (pic_sym_p(expr)) {
pic_value r;
r = pic_sym_value(translate(pic, pic_sym(expr), use_env, cxt));
*ir = pic_acons(pic, r, expr, *ir);
return r;
}
else if (pic_pair_p(expr)) {
return pic_cons(pic,
ir_macro_wrap(pic, pic_car(pic, expr), use_env, cxt, ir),
ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir));
}
else {
return expr;
}
}
static pic_value
ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, pic_value *ir)
{
if (pic_sym_p(expr)) {
pic_value r;
if (pic_test(r = pic_assq(pic, expr, *ir))) {
return pic_cdr(pic, r);
}
return pic_sym_value(translate(pic, pic_sym(expr), mac_env, cxt));
}
else if (pic_pair_p(expr)) {
return pic_cons(pic,
ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir),
ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir));
}
else {
return expr;
}
}
static pic_value
ir_macro_call(pic_state *pic)
{
pic_value expr, use_env, mac_env;
struct pic_proc *inject, *compare, *cb;
struct pic_dict *cxt;
pic_value ir = pic_nil_value();
pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
if (! pic_senv_p(use_env)) {
pic_error(pic, "unexpected type of argument 1");
}
if (! pic_senv_p(mac_env)) {
pic_error(pic, "unexpected type of argument 3");
}
cxt = pic_dict_new(pic);
inject = pic_proc_new(pic, ir_macro_inject, "<ir-macro-injecter>");
pic_proc_cv_init(pic, inject, 3);
pic_proc_cv_set(pic, inject, 0, use_env);
pic_proc_cv_set(pic, inject, 1, mac_env);
pic_proc_cv_set(pic, inject, 2, pic_obj_value(cxt));
compare = pic_proc_new(pic, ir_macro_compare, "<ir-macro-comparator>");
pic_proc_cv_init(pic, compare, 3);
pic_proc_cv_set(pic, compare, 0, use_env);
pic_proc_cv_set(pic, compare, 1, mac_env);
pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), cxt, &ir);
expr = pic_apply3(pic, cb, expr, pic_obj_value(inject), pic_obj_value(compare));
expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), cxt, &ir);
return expr;
}
static pic_value
pic_macro_ir_macro_transformer(pic_state *pic)
{
struct pic_proc *cb, *proc;
pic_get_args(pic, "l", &cb);
proc = pic_proc_new(pic, ir_macro_call, "<ir-macro-procedure>");
pic_proc_cv_init(pic, proc, 1);
pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
return pic_obj_value(proc);
return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj)));
}
void
@ -950,10 +697,8 @@ pic_init_macro(pic_state *pic)
pic_defun(pic, "gensym", pic_macro_gensym);
pic_defun(pic, "macroexpand", pic_macro_macroexpand);
pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc);
pic_defun(pic, "identifier?", pic_macro_identifier_p);
pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer);
pic_defun(pic, "ir-macro-transformer", pic_macro_ir_macro_transformer);
pic_defun(pic, "make-identifier", pic_macro_make_identifier);
}
}

34
src/vm.c
View File

@ -115,7 +115,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*f = pic_int(v);
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
}
i++;
}
@ -141,7 +141,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*e = true;
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
}
i++;
}
@ -167,7 +167,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*e = true;
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
}
i++;
}
@ -189,7 +189,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*k = pic_int(v);
break;
default:
pic_error(pic, "pic_get_args: expected int");
pic_errorf(pic, "pic_get_args: expected int, but got ~s", v);
}
i++;
}
@ -206,23 +206,23 @@ pic_get_args(pic_state *pic, const char *format, ...)
*str = pic_str_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected string");
pic_errorf(pic, "pic_get_args: expected string, but got ~s", v);
}
i++;
}
break;
}
case 'z': {
pic_value str;
const char **cstr;
pic_value v;
cstr = va_arg(ap, const char **);
if (i < argc) {
str = GET_OPERAND(pic,i);
if (! pic_str_p(str)) {
pic_error(pic, "pic_get_args: expected string");
v = GET_OPERAND(pic,i);
if (! pic_str_p(v)) {
pic_errorf(pic, "pic_get_args: expected string, but got ~s", v);
}
*cstr = pic_str_cstr(pic_str_ptr(str));
*cstr = pic_str_cstr(pic_str_ptr(v));
i++;
}
break;
@ -238,7 +238,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*m = pic_sym(v);
}
else {
pic_error(pic, "pic_get_args: expected symbol");
pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v);
}
i++;
}
@ -255,7 +255,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*vec = pic_vec_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected vector");
pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v);
}
i++;
}
@ -272,7 +272,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*b = pic_blob_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected bytevector");
pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v);
}
i++;
}
@ -289,7 +289,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*c = pic_char(v);
}
else {
pic_error(pic, "pic_get_args: expected char");
pic_errorf(pic, "pic_get_args: expected char, but got ~s", v);
}
i++;
}
@ -306,7 +306,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*l = pic_proc_ptr(v);
}
else {
pic_error(pic, "pic_get_args, expected procedure");
pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v);
}
i++;
}
@ -323,7 +323,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*p = pic_port_ptr(v);
}
else {
pic_error(pic, "pic_get_args, expected port");
pic_errorf(pic, "pic_get_args, expected port, but got ~s", v);
}
i++;
}
@ -340,7 +340,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*d = pic_dict_ptr(v);
}
else {
pic_error(pic, "pic_get_args, expected dictionary");
pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v);
}
i++;
}

5
src/write.c
View File

@ -318,11 +318,6 @@ write_core(struct writer_control *p, pic_value obj)
case PIC_TT_MACRO:
xfprintf(file, "#<macro %p>", pic_ptr(obj));
break;
case PIC_TT_SC:
xfprintf(file, "#<sc %p: ", pic_ptr(obj));
write_core(p, pic_sc_ptr(obj)->expr);
xfprintf(file, ">");
break;
case PIC_TT_LIB:
xfprintf(file, "#<lib %p>", pic_ptr(obj));
break;