OBJECT ParameterCheck(OBJECT x, OBJECT env)
{ OBJECT link, y, res, prnt_env, par, prnt;
debug2(DCE, DD, "ParameterCheck(%s, %s)", EchoObject(x), EchoObject(env));
assert( type(x) == CLOSURE, "ParameterCheck given non-CLOSURE!");
/* case x is a parameter */
prnt = SearchEnv(env, enclosing(actual(x)));
if( prnt == nilobj )
{ debug0(DCE, DD, "ParameterCheck returning nilobj (prnt fail)");
return nilobj;
}
prnt_env = GetEnv(prnt);
for( link = Down(prnt); link != prnt; link = NextDown(link) )
{ Child(par, link);
if( type(par) == PAR && actual(par) == actual(x) )
{ assert( Down(par) != par, "ParameterCheck: Down(par)!");
Child(y, Down(par));
res = is_word(type(y)) ? CopyObject(y, no_fpos) : nilobj;
debug1(DCE, DD, " ParameterCheck returning %s", EchoObject(res));
return res;
}
}
/* case x is a default parameter */
y = sym_body(actual(x));
if( y == nilobj )
{ res = nilobj;
}
else if( is_word(type(y)) )
{ res = CopyObject(y, &fpos(y));
}
else if( type(y) == CLOSURE && is_par(type(actual(y))) )
{ res = ParameterCheck(y, prnt_env);
}
else
{ res = nilobj;
}
debug1(DCE, DD, "ParameterCheck returning %s", EchoObject(res));
return res;
} /* end ParameterCheck */
/* domain interface function: for description see domain.h */
BVP *NS_DIM_PREFIX
BVP_GetByName (const char *name)
{
return((BVP *) SearchEnv(name,"/LGM_BVP",theLGMDomainVarID,theBVPDirID));
}
static LGM_PROBLEM *Lgm_Problem_GetByName (const char *name)
{
return((LGM_PROBLEM *) SearchEnv(name,"/LGM_PROBLEM",theProblemVarID,theProblemDirID));
}
FORMAT* NS_DIM_PREFIX GetFormat (const char *name)
{
return((FORMAT *) SearchEnv(name,"/Formats",theFormatDirID,theFormatDirID));
}
OBJECT ClosureExpand(OBJECT x, OBJECT env, BOOLEAN crs_wanted,
OBJECT *crs, OBJECT *res_env)
{ OBJECT link, y, res, prnt_env, par, prnt;
debug3(DCE, D, "[ ClosureExpand( %s, %s, %s, crs, res_env )",
EchoObject(x), EchoObject(env), bool(crs_wanted));
assert( type(x) == CLOSURE, "ClosureExpand given non-CLOSURE!");
assert( predefined(actual(x)) == FALSE, "ClosureExpand given predefined!" );
/* add tag to x if needed but not provided; add cross-reference to crs */
if( has_tag(actual(x)) ) CrossAddTag(x);
if( crs_wanted && has_tag(actual(x)) )
{ OBJECT tmp = CopyObject(x, no_fpos); AttachEnv(env, tmp);
y = CrossMake(actual(x), tmp, CROSS_TARG);
New(tmp, CROSS_TARG); actual(tmp) = y; Link(tmp, y);
if( *crs == nilobj ) New(*crs, CR_LIST); Link(*crs, tmp);
}
/* case x is a parameter */
res = *res_env = nilobj;
if( is_par(type(actual(x))) )
{ prnt = SearchEnv(env, enclosing(actual(x)));
if( prnt != nilobj )
{
prnt_env = GetEnv(prnt);
for( link = Down(prnt); link != prnt; link = NextDown(link) )
{ Child(par, link);
if( type(par) == PAR && actual(par) == actual(x) )
{ assert( Down(par) != par, "ExpandCLosure: Down(par)!");
Child(res, Down(par));
if( dirty(enclosing(actual(par))) || is_enclose(actual(par)) )
{ debug2(DCE, DD, "copy %s %s", SymName(actual(par)), EchoObject(res));
res = CopyObject(res, no_fpos);
}
else
{
debug2(DCE, DD, "link %s %s",
FullSymName(actual(par), AsciiToFull(".")), EchoObject(res));
DeleteLink(Down(par));
y = MakeWord(WORD, STR_NOCROSS, &fpos(res));
Link(par, y);
}
ReplaceNode(res, x);
if( type(actual(x)) == RPAR && has_body(enclosing(actual(x))) )
{ debug0(DCR, DDD, " calling SetEnv from ClosureExpand (a)");
*res_env = SetEnv(prnt, nilobj); DisposeObject(x);
}
else if( type(actual(x)) == NPAR && imports_encl(actual(x)) )
{ debug0(DCR, DDD, " calling SetEnv from ClosureExpand (x)");
AttachEnv(env, x);
*res_env = SetEnv(x, nilobj);
}
else
{ AttachEnv(env, x);
debug0(DCR, DDD, " calling SetEnv from ClosureExpand (b)");
*res_env = SetEnv(x, prnt_env);
}
break;
}
}
}
else
{
/* fail only if there is no default value available */
if( sym_body(actual(x)) == nilobj )
{
debug3(DCE, D, "failing ClosureExpand( %s, crs, %s, %s, res_env )",
EchoObject(x), bool(crs_wanted), EchoObject(env));
Error(9, 2, "no value for parameter %s of symbol %s:", WARN, &fpos(x),
SymName(actual(x)), SymName(enclosing(actual(x))));
Error(9, 1, "symbol with import list misused", FATAL, &fpos(x));
}
}
}
/* case x is a user-defined symbol or default parameter */
if( res == nilobj )
{ if( sym_body(actual(x)) == nilobj )
res = MakeWord(WORD, STR_NOCROSS, &fpos(x));
else
res = CopyObject(sym_body(actual(x)), &fpos(x));
ReplaceNode(res, x); AttachEnv(env, x);
debug0(DCR, DDD, " calling SetEnv from ClosureExpand (c)");
*res_env = SetEnv(x, nilobj);
}
assert( *res_env!=nilobj && type(*res_env)==ENV, "ClosureExpand: *res_env!");
debug0(DCE, D, "] ClosureExpand returning, res =");
ifdebug(DCE, D, DebugObject(res));
debug1(DCE, D, " environment = %s", EchoObject(*res_env));
return res;
} /* end ClosureExpand */
