/* Fully normalize or weak head normalize abstractions or implicit suspension
with abstractions as term skeletons.
The actions carried out are the same as the counter part in the head
normalization process, except that HN_lnormDispatch is invoked as opposed
to HN_hnormDispatch when necessary.
*/
static DF_TermPtr HN_lnormLam(DF_TermPtr lamPtr, Boolean whnf)
{
DF_TermPtr rtPtr; //term pointer to be returned
if (whnf) return rtPtr = lamPtr; //weak hn
else { //whnf = FALSE
int numabs = DF_lamNumAbs(lamPtr);
DF_TermPtr newbody;
if (HN_isEmptyEnv()){
newbody = HN_lnormDispatch(DF_lamBody(lamPtr), FALSE);
rtPtr = lamPtr; //body must have been adjusted in place
} else { // non-empty env
//[|lam(n,t),ol,nl,e|] ->lam(n,[|t,ol+n,nl+n,@nl+n-1...::@nl::e|]
int newol = ol+numabs, newnl = nl+numabs;
AM_embedError(newol);
AM_embedError(newnl);
HN_setEnv(newol, newnl, HN_addNDummyEnv(numabs));
newbody = HN_lnormDispatch(DF_lamBody(lamPtr), FALSE);
/* create a new lam on the result of hn the lam body */
rtPtr = (DF_TermPtr)AM_hreg;
HNL_pushLam(newbody, numabs);
} // non-empty env
AM_numAbs += numabs;
} //whnf == FALSE
return rtPtr;
}
static void PRINT_writeAbst(WordPtr outStream, DF_TermPtr tmPtr,
OP_FixityType fx, int prec, OP_TermContext tc)
{
int numabs = 0;
Boolean pparen = PRINT_parenNeeded(OP_LAM_FIXITY,OP_LAM_PREC,tc,fx,prec);
PRINT_BVList tmpbvs;
int tmpbvc = PRINT_bvcounter;
if (pparen) PRINT_writeLParen(outStream);
while (DF_isLam(tmPtr)){
numabs += DF_lamNumAbs(tmPtr);
tmPtr = DF_termDeref(DF_lamBody(tmPtr));
}
PRINT_writeAbstBinders(outStream, numabs);
PRINT_writeTerm(outStream, tmPtr, OP_LAM_FIXITY,OP_LAM_PREC,OP_RIGHT_TERM);
if (pparen) PRINT_writeRParen(outStream);
while (numabs > 0) {
numabs--;
tmpbvs = PRINT_bvs;
PRINT_bvs = PRINT_bvs->next;
PRINT_cleanBV(tmpbvs);
}
PRINT_bvcounter = tmpbvc;
}
static DF_TermPtr HN_pushSuspOverLam(DF_TermPtr lamPtr)
{
DF_TermPtr rtPtr; //term pointer to be returned
DF_TermPtr suspPtr; //explicit susp as the lam body in the result
int numabs =DF_lamNumAbs(lamPtr);
int newol = ol + numabs, newnl = nl + numabs;
MemPtr newhtop = AM_hreg+ DF_TM_SUSP_SIZE+ numabs*DF_TM_ATOMIC_SIZE;
DF_EnvPtr newenv;
AM_embedError(newol);
AM_embedError(newnl);
AM_heapError(newhtop);
newenv = HN_addNDummyEnv(numabs);
suspPtr = HNL_suspAsEnv(DF_lamBody(lamPtr), newol, newnl, newenv);
rtPtr = (DF_TermPtr)AM_hreg; //create lam over the susp
DF_mkLam(AM_hreg, numabs, suspPtr);
AM_hreg = newhtop;
return rtPtr;
}
/* Fully normalize or weak head normalize application or implicit suspension
over application. The actions carried out here is the same as those in
HN_hnormApp except that HN_lnormDispatch is invoked as HN_hnormDispatch, and
in making argument vectors makeArgvecLnorm functions are used to fully
normalize the arguments.
*/
static DF_TermPtr HN_lnormApp(DF_TermPtr appPtr, Boolean whnf)
{
DF_TermPtr funPtr = DF_appFunc(appPtr), argvec = DF_appArgs(appPtr),
rtPtr; // term pointer to be returned
DF_TermPtr oldFunPtr = funPtr;
int arity = DF_appArity(appPtr);
Boolean emptyTopEnv = HN_isEmptyEnv();
int myol, mynl; //for book keeping the implicit suspension env
DF_EnvPtr myenvlist; //for book keeping the implicit suspension env
int myarity = arity; //book keeping the arity before contraction
if (!emptyTopEnv) { //book keeping the current environment
myol = ol; mynl = nl; myenvlist = envlist;
}
funPtr = HN_lnormDispatch(funPtr, TRUE); //whf of the function
while ((arity > 0) && (DF_isLam(funPtr))) {
//perform contraction on top-level redexes while you can
DF_TermPtr lamBody = DF_lamBody(funPtr); //abs body
int numAbsInFun = DF_lamNumAbs(funPtr);
int numContract = ((arity<=numAbsInFun) ? arity : numAbsInFun);
DF_EnvPtr newenv;
int newol = ol + numContract;
AM_embedError(newol);
if (emptyTopEnv) newenv = HN_addNPairEmpEnv(argvec, numContract);
else newenv = HN_addNPair(argvec, myol, mynl, myenvlist, numContract);
HN_setEnv(newol, nl, newenv);
if (arity == numAbsInFun){
funPtr = HN_lnormDispatch(lamBody, whnf);
arity = 0;
} else if (arity > numAbsInFun) {
funPtr = HN_lnormDispatch(lamBody, TRUE);
argvec=(DF_TermPtr)(((MemPtr)argvec)+numAbsInFun*DF_TM_ATOMIC_SIZE);
arity -= numAbsInFun;
} else { //arity < numabsInFun
DF_TermPtr newBody = (DF_TermPtr)AM_hreg;
HNL_pushLam(lamBody, (numAbsInFun-arity));
funPtr = HN_lnormDispatch(newBody, whnf);
arity = 0;
}
}// while ((arity >0) && (DF_IsLam(fun)))
//update or create application
if (arity == 0) { //app disappears
rtPtr = funPtr;
if (emptyTopEnv && HN_isEmptyEnv()) HNL_updateToRef(appPtr, funPtr);
} else { //app persists; Note: now HN_isEmptyEnv must be TRUE
Boolean changed;
if (emptyTopEnv) changed = HN_makeArgvecEmpEnvLnorm(argvec, arity);
else changed = HN_makeArgvecLnorm(argvec,arity,myol,mynl,myenvlist);
if ((!changed) && (arity == myarity) && (oldFunPtr == funPtr)) {
rtPtr = appPtr;
} else {// create new app and in place update the old if empty top env
rtPtr = (DF_TermPtr)AM_hreg;
HNL_pushApp(AM_head, AM_argVec, AM_numArgs);
if (emptyTopEnv) HNL_updateToRef(appPtr, rtPtr);
}
}
return rtPtr;
}
