diff --git a/include/picrin.h b/include/picrin.h index 80bb4e91..87137359 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -16,10 +16,10 @@ typedef struct { pic_value *sp; pic_value *stbase, *stend; - pic_value sDEFINE, sCONS; pic_callinfo *ci; pic_callinfo *cibase, *ciend; + pic_value sDEFINE, sLAMBDA, sCONS; pic_value sADD, sSUB, sMUL, sDIV; struct pic_env *global_env; diff --git a/include/picrin/irep.h b/include/picrin/irep.h index 3b097d63..0ca5d3db 100644 --- a/include/picrin/irep.h +++ b/include/picrin/irep.h @@ -8,6 +8,8 @@ enum pic_instruction { OP_GREF, OP_GSET, OP_CALL, + OP_RET, + OP_LAMBDA, OP_CONS, OP_ADD, OP_SUB, @@ -28,6 +30,9 @@ struct pic_code { struct pic_irep { struct pic_code *code; size_t clen, ccapa; + + struct pic_irep **proto; + size_t plen, pcapa; }; #endif diff --git a/src/gc.c b/src/gc.c index d883d216..2950a7c8 100644 --- a/src/gc.c +++ b/src/gc.c @@ -193,6 +193,7 @@ gc_mark_phase(pic_state *pic) } while ((env = env->parent) != NULL); gc_mark(pic, pic->sDEFINE); + gc_mark(pic, pic->sLAMBDA); gc_mark(pic, pic->sCONS); gc_mark(pic, pic->sADD); gc_mark(pic, pic->sSUB); diff --git a/src/state.c b/src/state.c index a59ddac2..c069757b 100644 --- a/src/state.c +++ b/src/state.c @@ -41,6 +41,7 @@ pic_open() pic->arena_idx = 0; pic->sDEFINE = pic_intern_cstr(pic, "define"); + pic->sLAMBDA = pic_intern_cstr(pic, "lambda"); pic->sCONS = pic_intern_cstr(pic, "cons"); pic->sADD = pic_intern_cstr(pic, "+"); pic->sSUB = pic_intern_cstr(pic, "-"); diff --git a/src/vm.c b/src/vm.c index f982b85f..ddddcf2f 100644 --- a/src/vm.c +++ b/src/vm.c @@ -125,6 +125,12 @@ print_irep(pic_state *pic, struct pic_irep *irep) case OP_CALL: printf("OP_CALL\t%d\n", irep->code[i].u.i); break; + case OP_RET: + puts("OP_RET"); + break; + case OP_LAMBDA: + printf("OP_LAMBDA\t%d\n", irep->code[i].u.i); + break; case OP_CONS: puts("OP_CONS"); break; @@ -150,14 +156,31 @@ print_irep(pic_state *pic, struct pic_irep *irep) } } +static struct pic_irep * +new_irep(pic_state *pic) +{ + struct pic_irep *irep; + + irep = (struct pic_irep *)pic_alloc(pic, sizeof(struct pic_irep)); + irep->code = (struct pic_code *)pic_alloc(pic, sizeof(struct pic_code) * 1024); + irep->clen = 0; + irep->ccapa = 1024; + irep->proto = NULL; + irep->plen = irep->pcapa = 0; + + return irep; +} + static void pic_gen_call(pic_state *, struct pic_irep *, pic_value, struct pic_env *); +static struct pic_irep *pic_gen_lambda(pic_state *, pic_value, struct pic_env *); static void pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *env) { - pic_value sDEFINE, sCONS, sADD, sSUB, sMUL, sDIV; + pic_value sDEFINE, sLAMBDA, sCONS, sADD, sSUB, sMUL, sDIV; sDEFINE = pic->sDEFINE; + sLAMBDA = pic->sLAMBDA; sCONS = pic->sCONS; sADD = pic->sADD; sSUB = pic->sSUB; @@ -194,6 +217,22 @@ pic_gen(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_env *en irep->clen++; break; } + else if (pic_eq_p(pic, proc, sLAMBDA)) { + if (irep->proto == NULL) { + irep->proto = (struct pic_irep **)pic_alloc(pic, sizeof(struct pic_irep **) * 5); + irep->pcapa = 5; + } + if (irep->plen >= irep->pcapa) { + irep->proto = (struct pic_irep **)pic_realloc(pic, irep->proto, irep->pcapa * 2); + irep->pcapa *= 2; + } + irep->code[irep->clen].insn = OP_LAMBDA; + irep->code[irep->clen].u.i = irep->plen; + irep->clen++; + + irep->proto[irep->plen++] = pic_gen_lambda(pic, obj, env); + break; + } else if (pic_eq_p(pic, proc, sCONS)) { pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj))), env); pic_gen(pic, irep, pic_car(pic, pic_cdr(pic, obj)), env); @@ -280,20 +319,33 @@ pic_gen_call(pic_state *pic, struct pic_irep *irep, pic_value obj, struct pic_en irep->clen++; } +static struct pic_irep * +pic_gen_lambda(pic_state *pic, pic_value obj, struct pic_env *env) +{ + pic_value body, v; + struct pic_irep *irep; + + irep = new_irep(pic); + + body = pic_cdr(pic, pic_cdr(pic, obj)); + for (v = body; ! pic_nil_p(v); v = pic_cdr(pic, v)) { + pic_gen(pic, irep, pic_car(pic, v), env); + } + irep->code[irep->clen].insn = OP_RET; + irep->clen++; + + return irep; +} + struct pic_proc * pic_codegen(pic_state *pic, pic_value obj, struct pic_env *env) { struct pic_proc *proc; struct pic_irep *irep; - struct pic_code *code; proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->cfunc_p = false; - proc->u.irep = irep = (struct pic_irep *)pic_alloc(pic, sizeof(struct pic_irep)); - irep->code = code = (struct pic_code *)pic_alloc(pic, sizeof(struct pic_code) * 1024); - irep->clen = 0; - irep->ccapa = 1024; + proc->u.irep = irep = new_irep(pic); pic_gen(pic, irep, obj, env); irep->code[irep->clen].insn = OP_STOP; @@ -373,6 +425,16 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args) pic_gc_arena_restore(pic, ai); NEXT; } + CASE(OP_LAMBDA) { + struct pic_proc *proc; + + proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc *), PIC_TT_PROC); + proc->cfunc_p = false; + proc->u.irep = ci->proc->u.irep->proto[pc->u.i]; + PUSH(pic_obj_value(proc)); + pic_gc_arena_restore(pic, ai); + NEXT; + } CASE(OP_CONS) { pic_value a, b; pic_gc_protect(pic, a = POP());