2014-01-17 06:58:31 -05:00
|
|
|
/**
|
|
|
|
* See Copyright Notice in picrin.h
|
|
|
|
*/
|
|
|
|
|
2014-01-17 22:43:38 -05:00
|
|
|
#include "picrin.h"
|
|
|
|
#include "picrin/proc.h"
|
2014-01-08 10:38:09 -05:00
|
|
|
#include "picrin/var.h"
|
|
|
|
|
|
|
|
struct pic_var *
|
2014-01-12 02:05:42 -05:00
|
|
|
pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv /* = NULL */)
|
2014-01-08 10:38:09 -05:00
|
|
|
{
|
|
|
|
struct pic_var *var;
|
|
|
|
|
|
|
|
var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR);
|
|
|
|
var->value = pic_undef_value();
|
|
|
|
var->conv = conv;
|
|
|
|
|
|
|
|
pic_var_set(pic, var, init);
|
|
|
|
|
|
|
|
return var;
|
|
|
|
}
|
|
|
|
|
|
|
|
pic_value
|
|
|
|
pic_var_ref(pic_state *pic, struct pic_var *var)
|
|
|
|
{
|
2014-01-30 04:15:59 -05:00
|
|
|
UNUSED(pic);
|
2014-01-08 10:38:09 -05:00
|
|
|
return var->value;
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_var_set(pic_state *pic, struct pic_var *var, pic_value value)
|
|
|
|
{
|
|
|
|
if (var->conv) {
|
2014-03-25 08:04:30 -04:00
|
|
|
value = pic_apply1(pic, var->conv, value);
|
2014-01-08 10:38:09 -05:00
|
|
|
}
|
|
|
|
pic_var_set_force(pic, var, value);
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_var_set_force(pic_state *pic, struct pic_var *var, pic_value value)
|
|
|
|
{
|
2014-01-30 04:15:59 -05:00
|
|
|
UNUSED(pic);
|
2014-01-08 10:38:09 -05:00
|
|
|
var->value = value;
|
|
|
|
}
|
|
|
|
|
2014-01-17 22:58:00 -05:00
|
|
|
static struct pic_var *
|
|
|
|
get_var_from_proc(pic_state *pic, struct pic_proc *proc)
|
|
|
|
{
|
|
|
|
pic_value v;
|
|
|
|
|
2014-02-25 10:39:16 -05:00
|
|
|
if (! pic_proc_p(v)) {
|
|
|
|
goto typeerror;
|
|
|
|
}
|
|
|
|
if (! pic_proc_func_p(pic_proc_ptr(v))) {
|
2014-01-17 22:58:00 -05:00
|
|
|
goto typeerror;
|
|
|
|
}
|
|
|
|
if (pic_proc_cv_size(pic, proc) != 1) {
|
|
|
|
goto typeerror;
|
|
|
|
}
|
|
|
|
v = pic_proc_cv_ref(pic, proc, 0);
|
|
|
|
if (! pic_var_p(v)) {
|
|
|
|
goto typeerror;
|
|
|
|
}
|
|
|
|
return pic_var_ptr(v);
|
|
|
|
|
|
|
|
typeerror:
|
|
|
|
pic_error(pic, "expected parameter");
|
2014-03-19 04:40:31 -04:00
|
|
|
UNREACHABLE();
|
2014-01-17 22:58:00 -05:00
|
|
|
}
|
|
|
|
|
2014-01-08 10:38:09 -05:00
|
|
|
static pic_value
|
|
|
|
var_call(pic_state *pic)
|
|
|
|
{
|
|
|
|
struct pic_proc *proc;
|
|
|
|
struct pic_var *var;
|
|
|
|
pic_value v;
|
|
|
|
int c;
|
|
|
|
|
|
|
|
proc = pic_get_proc(pic);
|
|
|
|
|
|
|
|
c = pic_get_args(pic, "|o", &v);
|
2014-02-01 00:23:21 -05:00
|
|
|
if (c == 0) {
|
2014-03-22 23:45:36 -04:00
|
|
|
var = pic_var_ptr(proc->env->regs[0]);
|
2014-01-08 10:38:09 -05:00
|
|
|
return pic_var_ref(pic, var);
|
|
|
|
}
|
2014-02-01 00:23:21 -05:00
|
|
|
else if (c == 1) {
|
2014-03-22 23:45:36 -04:00
|
|
|
var = pic_var_ptr(proc->env->regs[0]);
|
2014-01-08 10:38:09 -05:00
|
|
|
|
|
|
|
pic_var_set(pic, var, v);
|
|
|
|
return pic_none_value();
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
pic_abort(pic, "logic flaw");
|
|
|
|
}
|
2014-03-19 04:40:31 -04:00
|
|
|
UNREACHABLE();
|
2014-01-08 10:38:09 -05:00
|
|
|
}
|
|
|
|
|
2014-01-12 02:08:27 -05:00
|
|
|
struct pic_proc *
|
|
|
|
pic_wrap_var(pic_state *pic, struct pic_var *var)
|
|
|
|
{
|
|
|
|
struct pic_proc *proc;
|
|
|
|
|
|
|
|
proc = pic_proc_new(pic, var_call);
|
|
|
|
pic_proc_cv_init(pic, proc, 1);
|
|
|
|
pic_proc_cv_set(pic, proc, 0, pic_obj_value(var));
|
|
|
|
return proc;
|
|
|
|
}
|
|
|
|
|
2014-01-17 22:58:00 -05:00
|
|
|
struct pic_var *
|
|
|
|
pic_unwrap_var(pic_state *pic, struct pic_proc *proc)
|
|
|
|
{
|
|
|
|
return get_var_from_proc(pic, proc);
|
|
|
|
}
|
|
|
|
|
2014-01-08 10:38:09 -05:00
|
|
|
static pic_value
|
|
|
|
pic_var_make_parameter(pic_state *pic)
|
|
|
|
{
|
2014-01-12 02:08:27 -05:00
|
|
|
struct pic_proc *conv = NULL;
|
2014-01-08 10:38:09 -05:00
|
|
|
struct pic_var *var;
|
|
|
|
pic_value init;
|
|
|
|
|
|
|
|
pic_get_args(pic, "o|l", &init, &conv);
|
|
|
|
|
|
|
|
var = pic_var_new(pic, init, conv);
|
2014-01-12 02:08:27 -05:00
|
|
|
return pic_obj_value(pic_wrap_var(pic, var));
|
2014-01-08 10:38:09 -05:00
|
|
|
}
|
|
|
|
|
|
|
|
static pic_value
|
|
|
|
pic_var_parameter_ref(pic_state *pic)
|
|
|
|
{
|
|
|
|
struct pic_proc *proc;
|
|
|
|
struct pic_var *var;
|
|
|
|
|
|
|
|
pic_get_args(pic, "l", &proc);
|
|
|
|
|
|
|
|
var = get_var_from_proc(pic, proc);
|
|
|
|
return pic_var_ref(pic, var);
|
|
|
|
}
|
|
|
|
|
|
|
|
static pic_value
|
|
|
|
pic_var_parameter_set(pic_state *pic)
|
|
|
|
{
|
|
|
|
struct pic_proc *proc;
|
|
|
|
struct pic_var *var;
|
|
|
|
pic_value v;
|
|
|
|
|
|
|
|
pic_get_args(pic, "lo", &proc, &v);
|
|
|
|
|
|
|
|
var = get_var_from_proc(pic, proc);
|
|
|
|
/* no convert */
|
|
|
|
pic_var_set_force(pic, var, v);
|
|
|
|
return pic_none_value();
|
|
|
|
}
|
|
|
|
|
|
|
|
static pic_value
|
|
|
|
pic_var_parameter_converter(pic_state *pic)
|
|
|
|
{
|
|
|
|
struct pic_proc *proc;
|
|
|
|
struct pic_var *var;
|
|
|
|
|
|
|
|
pic_get_args(pic, "l", &proc);
|
|
|
|
|
|
|
|
var = get_var_from_proc(pic, proc);
|
|
|
|
if (var->conv) {
|
|
|
|
return pic_obj_value(var->conv);
|
|
|
|
}
|
|
|
|
else {
|
|
|
|
return pic_false_value();
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_init_var(pic_state *pic)
|
|
|
|
{
|
2014-02-01 01:41:30 -05:00
|
|
|
pic_deflibrary ("(picrin parameter)") {
|
2014-01-08 10:38:09 -05:00
|
|
|
pic_defun(pic, "make-parameter", pic_var_make_parameter);
|
|
|
|
pic_defun(pic, "parameter-ref", pic_var_parameter_ref);
|
|
|
|
pic_defun(pic, "parameter-set!", pic_var_parameter_set); /* no convert */
|
|
|
|
pic_defun(pic, "parameter-converter", pic_var_parameter_converter);
|
|
|
|
}
|
|
|
|
}
|