picrin/proc.c

123 lines
2.5 KiB
C

/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/proc.h"
#include "picrin/irep.h"
#include "picrin/dict.h"
struct pic_proc *
pic_make_proc(pic_state *pic, pic_func_t func, const char *name)
{
struct pic_proc *proc;
assert(name != NULL);
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_FUNC;
proc->u.func.f = func;
proc->u.func.name = pic_intern_cstr(pic, name);
proc->env = NULL;
proc->attr = NULL;
return proc;
}
struct pic_proc *
pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
{
struct pic_proc *proc;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_IREP;
proc->u.irep = irep;
proc->env = env;
proc->attr = NULL;
return proc;
}
pic_sym
pic_proc_name(struct pic_proc *proc)
{
switch (proc->kind) {
case PIC_PROC_KIND_FUNC:
return proc->u.func.name;
case PIC_PROC_KIND_IREP:
return proc->u.irep->name;
}
UNREACHABLE();
}
struct pic_dict *
pic_attr(pic_state *pic, struct pic_proc *proc)
{
if (proc->attr == NULL) {
proc->attr = pic_make_dict(pic);
}
return proc->attr;
}
pic_value
pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key)
{
return pic_dict_ref(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key)));
}
void
pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v)
{
pic_dict_set(pic, pic_attr(pic, proc), pic_sym_value(pic_intern_cstr(pic, key)), v);
}
static pic_value
pic_proc_proc_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_proc_p(v));
}
static pic_value
pic_proc_apply(pic_state *pic)
{
struct pic_proc *proc;
pic_value *args;
size_t argc;
pic_value arg_list;
pic_get_args(pic, "l*", &proc, &argc, &args);
if (argc == 0) {
pic_error(pic, "apply: wrong number of arguments");
}
arg_list = args[--argc];
while (argc--) {
arg_list = pic_cons(pic, args[argc], arg_list);
}
return pic_apply_trampoline(pic, proc, arg_list);
}
static pic_value
pic_proc_attribute(pic_state *pic)
{
struct pic_proc *proc;
pic_get_args(pic, "l", &proc);
return pic_obj_value(pic_attr(pic, proc));
}
void
pic_init_proc(pic_state *pic)
{
pic_defun(pic, "procedure?", pic_proc_proc_p);
pic_defun(pic, "apply", pic_proc_apply);
pic_defun(pic, "attribute", pic_proc_attribute);
}