/*******************************************************************************
*** FUNCTION REST()
*******************************************************************************
*** DESCRIPTION : Processes REST grammar rule.
***
*** REST -> ( PARAMLIST ) COMPOUND |
*** IDTAIL ; PROG
******************************************************************************/
void RecursiveParser::REST(VarType & type, int & offset, ParamPtr & paramptr, int & local_size, int & param_num)
{
if (global->Token == Global::lparent)
{
depth++;
offset = 2;
param_num = 0;
int param_size = 0;
match(Global::lparent);
PARAMLIST(offset, paramptr, local_size, param_num, param_size);
EntryPtr ptr = symtab->lookup(funcname);
ptr->function.ParamList = base;
ptr->function.SizeOfLocal = local_size + offset;
ptr->function.NumberOfParameters = param_num;
ptr->function.sizeOfParams = param_size;
if (param_num == 0)
base = NULL;
// cout << "Depth change: " << depth-1 << " to " << depth << ": Enter to Continue"<< endl;
// cin.ignore();
// system("clear");
// symtab->writeTable(depth-1);
match(Global::rparent);
COMPOUND(offset);
// cout << "Depth change: " << depth+1 << " to " << depth << ": Enter to Continue"<< endl;
// cin.ignore();
// system("clear");
// symtab->writeTable(depth+1);
}
else
{
IDTAIL(type, offset);
match(Global::semicolont);
PROG();
}
}
int Visit (register Object *p) {
register Object *tag;
register int t, size, reloc = 0;
again:
t = TYPE(*p);
if (!Types[t].haspointer)
return 0;
tag = (Object *)POINTER(*p);
if ((char *)tag >= Free_Start && (char *)tag < Free_End)
return 0;
if (TYPE(*tag) == T_Broken_Heart) {
SETPOINTER(*p, POINTER(*tag));
return 0;
}
ELK_ALIGN(To);
switch (t) {
case T_Bignum:
size = sizeof (struct S_Bignum) - sizeof (gran_t)
+ BIGNUM(*p)->size * sizeof (gran_t);
memcpy (To, tag, size);
break;
case T_Flonum:
size = sizeof (struct S_Flonum);
*(struct S_Flonum *)To = *(struct S_Flonum *)tag;
break;
case T_Symbol:
size = sizeof (struct S_Symbol);
*(struct S_Symbol *)To = *(struct S_Symbol *)tag;
break;
case T_Pair:
case T_Environment:
size = sizeof (struct S_Pair);
*(struct S_Pair *)To = *(struct S_Pair *)tag;
break;
case T_String:
size = sizeof (struct S_String) + STRING(*p)->size - 1;
memcpy (To, tag, size);
break;
case T_Vector:
size = sizeof (struct S_Vector) + (VECTOR(*p)->size - 1) *
sizeof (Object);
memcpy (To, tag, size);
break;
case T_Primitive:
size = sizeof (struct S_Primitive);
*(struct S_Primitive *)To = *(struct S_Primitive *)tag;
break;
case T_Compound:
size = sizeof (struct S_Compound);
*(struct S_Compound *)To = *(struct S_Compound *)tag;
break;
case T_Control_Point:
size = sizeof (struct S_Control) + CONTROL(*p)->size - 1;
reloc = To - (char *)tag;
memcpy (To, tag, size);
break;
case T_Promise:
size = sizeof (struct S_Promise);
*(struct S_Promise *)To = *(struct S_Promise *)tag;
break;
case T_Port:
size = sizeof (struct S_Port);
*(struct S_Port *)To = *(struct S_Port *)tag;
break;
case T_Autoload:
size = sizeof (struct S_Autoload);
*(struct S_Autoload *)To = *(struct S_Autoload *)tag;
break;
case T_Macro:
size = sizeof (struct S_Macro);
*(struct S_Macro *)To = *(struct S_Macro *)tag;
break;
case T_Broken_Heart:
Panic ("broken heart in GC");
default:
if (t < 0 || t >= Num_Types)
Panic ("bad type in GC");
if (Types[t].size == NOFUNC)
size = Types[t].const_size;
else
size = (Types[t].size)(*p);
memcpy (To, tag, size);
}
SETPOINTER(*p, To);
SET(*tag, T_Broken_Heart, To);
To += size;
if (To > Free_End)
Panic ("free exhausted in GC");
switch (t) {
case T_Symbol:
Recursive_Visit (&SYMBOL(*p)->next);
Recursive_Visit (&SYMBOL(*p)->name);
Recursive_Visit (&SYMBOL(*p)->value);
p = &SYMBOL(*p)->plist;
goto again;
case T_Pair:
case T_Environment:
Recursive_Visit (&PAIR(*p)->car);
p = &PAIR(*p)->cdr;
goto again;
case T_Vector: {
register int i, n;
for (i = 0, n = VECTOR(*p)->size; i < n; i++)
Recursive_Visit (&VECTOR(*p)->data[i]);
break;
}
case T_Compound:
Recursive_Visit (&COMPOUND(*p)->closure);
Recursive_Visit (&COMPOUND(*p)->env);
p = &COMPOUND(*p)->name;
goto again;
case T_Control_Point:
Recursive_Visit (&CONTROL(*p)->memsave);
CONTROL(*p)->delta += reloc;
#ifdef HAVE_ALLOCA
Visit_GC_List (CONTROL(*p)->gclist, CONTROL(*p)->delta);
#else
Recursive_Visit (&CONTROL(*p)->gcsave);
#endif
Visit_Wind (CONTROL(*p)->firstwind, CONTROL(*p)->delta);
p = &CONTROL(*p)->env;
goto again;
case T_Promise:
Recursive_Visit (&PROMISE(*p)->env);
p = &PROMISE(*p)->thunk;
goto again;
case T_Port:
p = &PORT(*p)->name;
goto again;
case T_Autoload:
Recursive_Visit (&AUTOLOAD(*p)->files);
p = &AUTOLOAD(*p)->env;
goto again;
case T_Macro:
Recursive_Visit (&MACRO(*p)->body);
p = &MACRO(*p)->name;
goto again;
default:
if (Types[t].visit)
(Types[t].visit)(p, Visit);
}
return 0;
}
term hlist(register term H, register term regs, stack wam)
{ no i; cell xval; bp_long ival; byte stamp;
#if TRACE>0
fprintf(STD_err,"entering hlist, wam=%d, bboard=%d H=%d\n",
wam,g.shared[BBoardStk].base,H);
bbcheck(wam);
#endif
if(!INTEGER(X(1))) return NULL; /* first arg: stamp */
stamp=(byte)(OUTPUT_INT(X(1)));
xval=X(2); /* second arg: starting arity of listed terms */
if(!INTEGER(xval)) return NULL;
ival=OUTPUT_INT(xval);
for(i=0; i<HMAX; i++)
if(hstamp[i]>=stamp && HUSED())
{ term xref=C2T(g.predmark);
if(hstamp[i]<=RUNTIME)
{ /* gets preds of arity < ival `represented' as g.predmark*/
if(g.predmark!=htable[i].pred
|| GETARITY(htable[i].fun)<(no)ival)
continue;
xval=g.predmark;
}
else
{ /* gets RUNTIME data of arity > ival */
cell v=htable[i].val;
if(NULL==(term)v)
continue;
if(VAR(v) &&
!(
ONSTACK(g.shared[BBoardStk],v) ||
ONSTACK(g.shared[InstrStk],v) /*|| ON(HeapStk,v) */
)) {
#if TRACE>0
fprintf(STD_err,
"unexpected data in htable[%d]=>\n<%s,%s>->%s\n",i,
smartref(htable[i].pred,wam),
smartref(htable[i].fun,wam),
smartref(v,wam));
#endif
/* continue; */
}
FDEREF(v);
if((INTEGER(xval) && ival>0)
|| VAR(xval)
|| (GETARITY(xval) < (no)ival)
|| xval==g.empty
)
continue;
if(COMPOUND(xval))
xval=T2C(xref);
}
IF_OVER("COPY_KEYS",(term *)H,HeapStk,bp_halt(9));
SAVE_FUN(htable[i].pred);
SAVE_FUN(htable[i].fun);
#if 0
ASSERT2(( ATOMIC(xval)
|| ONSTACK(g.shared[BBoardStk],xval)
|| ON(HeapStk,xval)), /* will fail with multiple engines */
xval);
#endif
PUSH_LIST(xval);
}
PUSH_NIL();
return H;
}
static Object P_Hack_Procedure_Environment (Object p, Object e) {
Check_Type (p, T_Compound);
Check_Type (e, T_Environment);
COMPOUND(p)->env = e;
return p;
}
