void testmain(void) {
print("macros");
special();
include();
predefined();
simple();
loop();
undef();
cond_incl();
const_expr();
defined();
ifdef();
funclike();
empty();
noarg();
line();
null();
counter();
gnuext();
}
OBJECT InsertSym(FULL_CHAR *str, unsigned char xtype, FILE_POS *xfpos,
unsigned char xprecedence, BOOLEAN xindefinite, BOOLEAN xrecursive,
unsigned xpredefined, OBJECT xenclosing, OBJECT xbody)
{ register int sum, rlen;
register unsigned char *x;
OBJECT p, q, s, tmp, link, entry, plink; int len;
debug3(DST, DD, "InsertSym( %s, %s, in %s )",
Image(xtype), str, SymName(xenclosing));
if( !LexLegalName(str) )
Error(29, 3, "invalid symbol name %s", WARN, xfpos, str);
New(s, xtype);
FposCopy(fpos(s), *xfpos);
has_body(s) = FALSE;
filter(s) = nilobj;
use_invocation(s) = nilobj;
imports(s) = nilobj;
imports_encl(s) = FALSE;
right_assoc(s) = TRUE;
precedence(s) = xprecedence;
indefinite(s) = xindefinite;
recursive(s) = xrecursive;
predefined(s) = xpredefined;
enclosing(s) = xenclosing;
sym_body(s) = xbody;
base_uses(s) = nilobj;
uses(s) = nilobj;
marker(s) = nilobj;
cross_sym(s) = nilobj;
is_extern_target(s) = FALSE;
uses_extern_target(s)= FALSE;
visible(s) = FALSE;
uses_galley(s) = FALSE;
horiz_galley(s) = ROWM;
has_compulsory(s) = 0;
is_compulsory(s) = FALSE;
uses_count(s) = 0;
dirty(s) = FALSE;
if( enclosing(s) != nilobj && type(enclosing(s)) == NPAR )
dirty(s) = dirty(enclosing(s)) = TRUE;
has_par(s) = FALSE;
has_lpar(s) = FALSE;
has_rpar(s) = FALSE;
if( is_par(type(s)) ) has_par(enclosing(s)) = TRUE;
if( type(s) == LPAR ) has_lpar(enclosing(s)) = TRUE;
if( type(s) == RPAR ) has_rpar(enclosing(s)) = TRUE;
/* assign a code letter between a and z to any NPAR symbol */
if( type(s) == NPAR )
{ if( LastDown(enclosing(s)) != enclosing(s) )
{ Child(tmp, LastDown(enclosing(s)));
if( type(tmp) == NPAR )
{ if( npar_code(tmp) == 'z' || npar_code(tmp) == ' ' )
npar_code(s) = ' ';
else
npar_code(s) = npar_code(tmp)+1;
}
else
npar_code(s) = 'a';
}
else npar_code(s) = 'a';
}
has_target(s) = FALSE;
force_target(s) = FALSE;
if( !StringEqual(str, KW_TARGET) ) is_target(s) = FALSE;
else
{ is_target(s) = has_target(enclosing(s)) = TRUE;
/* if @Target is found after @Key, take note of external target */
if( has_key(enclosing(s)) && xbody != nilobj && is_cross(type(xbody)) )
{ if( LastDown(xbody) != Down(xbody) )
{ OBJECT sym;
Child(sym, Down(xbody));
if( type(sym) == CLOSURE )
{ is_extern_target(actual(sym)) = TRUE;
uses_extern_target(actual(sym)) = TRUE;
}
}
}
}
has_tag(s) = is_tag(s) = FALSE;
has_key(s) = is_key(s) = FALSE;
has_optimize(s) = is_optimize(s) = FALSE;
has_merge(s) = is_merge(s) = FALSE;
has_enclose(s) = is_enclose(s) = FALSE;
if( enclosing(s) != nilobj && type(enclosing(s)) == LOCAL )
{
if( StringEqual(str, KW_TAG) )
is_tag(s) = has_tag(enclosing(s)) = dirty(enclosing(s)) = TRUE;
if( StringEqual(str, KW_OPTIMIZE) )
is_optimize(s) = has_optimize(enclosing(s)) = TRUE;
if( StringEqual(str, KW_KEY) )
{ is_key(s) = has_key(enclosing(s)) = dirty(enclosing(s)) = TRUE;
/* if @Key is found after @Target, take note of external target */
for( link=Down(enclosing(s)); link!=enclosing(s); link=NextDown(link) )
{ Child(p, link);
if( is_target(p) && sym_body(p)!=nilobj && is_cross(type(sym_body(p))) )
{ OBJECT sym;
Child(sym, Down(sym_body(p)));
if( type(sym) == CLOSURE )
{ is_extern_target(actual(sym)) = TRUE;
uses_extern_target(actual(sym)) = TRUE;
}
}
}
}
if( StringEqual(str, KW_MERGE) )
is_merge(s) = has_merge(enclosing(s)) = TRUE;
if( StringEqual(str, KW_ENCLOSE) )
is_enclose(s) = has_enclose(enclosing(s)) = TRUE;
}
if( StringEqual(str, KW_FILTER) )
{ if( type(s) != LOCAL || enclosing(s) == StartSym )
Error(29, 4, "%s must be a local definition", WARN, &fpos(s), str);
else if( !has_rpar(enclosing(s)) )
Error(29, 14, "%s must lie within a symbol with a right parameter",
WARN, &fpos(s), KW_FILTER);
else
{ filter(enclosing(s)) = s;
precedence(enclosing(s)) = FILTER_PREC;
}
}
if( type(s) == RPAR && has_body(enclosing(s)) &&
(is_tag(s) || is_key(s) || is_optimize(s)) )
Error(29, 5, "a body parameter may not be named %s", WARN, &fpos(s), str);
if( type(s) == RPAR && has_target(enclosing(s)) &&
(is_tag(s) || is_key(s) || is_optimize(s)) )
Error(29, 6, "the right parameter of a galley may not be called %s",
WARN, &fpos(s), str);
len = StringLength(str);
hash(str, len, sum);
ifdebug(DST, D, sym_spread[sum]++; sym_count++);
entry = (OBJECT) &symtab[sum];
for( plink = Down(entry); plink != entry; plink = NextDown(plink) )
{ Child(p, plink);
if( length(p) == len && StringEqual(str, string(p)) )
{ for( link = Down(p); link != p; link = NextDown(link) )
{ Child(q, link);
if( enclosing(s) == enclosing(q) )
{ Error(29, 7, "symbol %s previously defined at%s",
WARN, &fpos(s), str, EchoFilePos(&fpos(q)) );
if( AltErrorFormat )
{
Error(29, 13, "symbol %s previously defined here",
WARN, &fpos(q), str);
}
break;
}
}
goto wrapup;
}
}
/* need a new OBJECT as well as s */
NewWord(p, WORD, len, xfpos);
length(p) = len;
StringCopy(string(p), str);
Link(entry, p);
wrapup:
Link(p, s);
if( enclosing(s) != nilobj ) Link(enclosing(s), s);
debug2(DST, DD, "InsertSym Link(%s, %s) and returning.",
SymName(enclosing(s)), SymName(s));
return s;
} /* end InsertSym */
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 */
