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;
}
/****************************************************************************
* Writing out a non-empty list. *
****************************************************************************/
static void PRINT_writeCons(WordPtr outStream, DF_TermPtr tmPtr,
OP_FixityType fx, int prec, OP_TermContext tc)
{
DF_TermPtr args = DF_consArgs(tmPtr);
DF_TermPtr arg;
OP_FixityType consfix = (OP_FixityType)AM_cstFixity(PERV_CONS_INDEX);
int consprec = AM_cstPrecedence(PERV_CONS_INDEX);
Boolean pparen = PRINT_parenNeeded(consfix, consprec, tc, fx,prec);
if (pparen) PRINT_writeLParen(outStream);
PRINT_writeTerm(outStream, args, consfix, consprec, OP_LEFT_TERM);
PRINT_writeConsSymbol(outStream);
do {
args++;
tmPtr = DF_termDeref(args);
if (DF_termTag(tmPtr) != DF_TM_TAG_CONS) break;
args = DF_consArgs(tmPtr);
PRINT_writeTerm(outStream, args, consfix, consprec, OP_LEFT_TERM);
PRINT_writeConsSymbol(outStream);
} while(1);
PRINT_writeTerm(outStream, tmPtr, consfix, consprec, OP_RIGHT_TERM);
if (pparen) PRINT_writeRParen(outStream);
}
static DF_TermPtr HN_hnormDispatchOcc(DF_TermPtr tmPtr, Boolean whnf)
{
restart_hnormOcc:
switch (DF_termTag(tmPtr)){
case DF_TM_TAG_VAR:
{
if (!HN_isEmptyEnv()) HN_setEmptyEnv();
HNL_setRegsFlex(tmPtr);
return tmPtr;
}
case DF_TM_TAG_CONST:
case DF_TM_TAG_INT:
case DF_TM_TAG_FLOAT:
case DF_TM_TAG_NIL:
case DF_TM_TAG_STR:
case DF_TM_TAG_STREAM:
{
if (!HN_isEmptyEnv()) HN_setEmptyEnv();
HNL_setRegsRig(tmPtr);
return tmPtr;
}
case DF_TM_TAG_BVAR: { return HN_hnormBVOcc(tmPtr, whnf); }
case DF_TM_TAG_CONS: { return HN_hnormConsOcc(tmPtr, whnf); }
case DF_TM_TAG_LAM: { return HN_hnormLamOcc(tmPtr, whnf); }
case DF_TM_TAG_APP: {
if (AM_vbbreg == tmPtr) EM_THROW(EM_FAIL);
return HN_hnormAppOcc(tmPtr, whnf); }
case DF_TM_TAG_SUSP: { return HN_hnormSuspOcc(tmPtr, whnf); }
case DF_TM_TAG_REF: {tmPtr=DF_termDeref(tmPtr); goto restart_hnormOcc;}
}
//Impossible to reach this point.
return NULL;
}
static DF_TermPtr HN_lnormDispatch(DF_TermPtr tmPtr, Boolean whnf)
{
restart_lnorm:
switch (DF_termTag(tmPtr)){
case DF_TM_TAG_VAR:
{
if (!HN_isEmptyEnv()) HN_setEmptyEnv();
HNL_setRegsFlex(tmPtr);
return tmPtr;
}
case DF_TM_TAG_CONST:
case DF_TM_TAG_INT:
case DF_TM_TAG_FLOAT:
case DF_TM_TAG_NIL:
case DF_TM_TAG_STR:
case DF_TM_TAG_STREAM:
{
if (!HN_isEmptyEnv()) HN_setEmptyEnv();
HNL_setRegsRig(tmPtr);
return tmPtr;
}
case DF_TM_TAG_BVAR: { return HN_lnormBV(tmPtr, whnf); }
case DF_TM_TAG_CONS: { return HN_lnormCons(tmPtr, whnf); }
case DF_TM_TAG_LAM: { return HN_lnormLam(tmPtr, whnf); }
case DF_TM_TAG_APP: { return HN_lnormApp(tmPtr, whnf); }
case DF_TM_TAG_SUSP: { return HN_lnormSusp(tmPtr, whnf); }
case DF_TM_TAG_REF: { tmPtr = DF_termDeref(tmPtr); goto restart_lnorm;}
}
//Impossible to reach this point.
return NULL;
}
/* (weak) head normalize bound variable or implicit suspension with
bound variable as term skeleton. */
static DF_TermPtr HN_hnormBV(DF_TermPtr bvPtr, Boolean whnf)
{
DF_TermPtr rtPtr; //term pointer to be returned
if (HN_isEmptyEnv()){ //[|#i, 0, 0, nil|] -> #i
rtPtr = bvPtr;
HNL_setRegsRig(bvPtr);
} else { //non-empty env
int dbind = DF_bvIndex(bvPtr);
if (dbind > ol) { //[|#i,ol,nl,e|] -> #i-ol+nl
int newind = dbind - ol + nl;
AM_embedError(newind);
rtPtr =(DF_TermPtr)AM_hreg;
HNL_pushBV(newind);
HNL_setRegsRig(rtPtr);
HN_setEmptyEnv();
} else { // i <= ol
DF_EnvPtr envitem = DF_envListNth(envlist, dbind);
int nladj = nl-DF_envIndex(envitem);
if (DF_isDummyEnv(envitem)){ //[|#i,ol,nl,..@l..|]->#(nl-l)
rtPtr = (DF_TermPtr)AM_hreg;
HNL_pushBV(nladj);
HNL_setRegsRig(rtPtr);
HN_setEmptyEnv();
} else { //pair env [|#i,ol,nl,..(s,l)..|] -> [|s,0,(nl-l),nil|]
DF_TermPtr tmPtr = DF_termDeref(DF_envPairTerm(envitem));
if ((nladj != 0) && (DF_isSusp(tmPtr))) {//combine susp
int newnl = DF_suspNL(tmPtr)+nladj;
AM_embedError(newnl);
HN_setEnv(DF_suspOL(tmPtr), newnl, DF_suspEnv(tmPtr));
rtPtr = HN_hnormDispatch(DF_suspTermSkel(tmPtr), whnf);
} else {
HN_setEnv(0, nladj, DF_EMPTY_ENV);
rtPtr = HN_hnormDispatch(tmPtr, whnf);
}
} //pair env
} // i<= ol
} //non-empty env
return rtPtr;
}
/*****************************************************************************
* The main routine for writing out a term; this is called by the interface *
* routines to do the real job of printing. *
*****************************************************************************/
static void PRINT_writeTerm(WordPtr outStream, DF_TermPtr tmPtr,
OP_FixityType infx, int inprec, OP_TermContext tc)
{
tmPtr = DF_termDeref(tmPtr);
switch (DF_termTag(tmPtr)) {
case DF_TM_TAG_INT: PRINT_writeInt(outStream, tmPtr); break;
case DF_TM_TAG_FLOAT: PRINT_writeFloat(outStream, tmPtr); break;
case DF_TM_TAG_STR: PRINT_writeString(outStream, tmPtr); break;
case DF_TM_TAG_STREAM: PRINT_writeStream(outStream, tmPtr); break;
case DF_TM_TAG_CONST: PRINT_writeConst(outStream, tmPtr); break;
case DF_TM_TAG_VAR: PRINT_writeFVar(outStream, tmPtr); break;
case DF_TM_TAG_BVAR: PRINT_writeBVar(outStream, tmPtr); break;
case DF_TM_TAG_NIL: PRINT_writeNil(outStream); break;
case DF_TM_TAG_CONS:
PRINT_writeCons(outStream, tmPtr, infx, inprec, tc); break;
case DF_TM_TAG_LAM:
PRINT_writeAbst(outStream, tmPtr, infx, inprec, tc); break;
case DF_TM_TAG_APP:
PRINT_writeApp(outStream, tmPtr, infx, inprec, tc); break;
} /* switch */
}
/* Main routine for writing out an application term */
static void PRINT_writeApp(WordPtr outStream, DF_TermPtr tmPtr,
OP_FixityType infx, int inprec, OP_TermContext tc)
{
DF_TermPtr head = DF_termDeref(DF_appFunc(tmPtr));
DF_TermPtr args = DF_appArgs(tmPtr);
int arity = DF_appArity(tmPtr);
Boolean pparen = PRINT_parenNeeded(OP_APP_FIXITY, OP_APP_PREC, tc, infx,
inprec);
OP_FixityType fix;
int prec;
HN_hnorm(tmPtr);
PRINT_getHeadInfo(AM_head, &fix, &prec);
switch(fix){
case OP_PREFIX: case OP_PREFIXR:
if (arity == 1) {
pparen = FALSE;
PRINT_writePrefixTerm(outStream, head, fix, prec, tc, infx, inprec,
args);
} else {
if (pparen) PRINT_writeLParen(outStream);
PRINT_writePrefixTerm(outStream, head, fix, prec, OP_LEFT_TERM,
OP_APP_FIXITY, OP_APP_PREC, args);
}
arity--; args++;
break;
case OP_INFIX: case OP_INFIXL: case OP_INFIXR:
if (arity == 2) {
pparen = FALSE;
PRINT_writeInfixTerm(outStream, head, fix, prec, tc, infx, inprec,
args);
} else {
if (pparen) PRINT_writeLParen(outStream);
PRINT_writeInfixTerm(outStream, head, fix, prec, OP_LEFT_TERM,
OP_APP_FIXITY, OP_APP_PREC, args);
}
arity -= 2; args += 2;
break;
case OP_POSTFIX: case OP_POSTFIXL:
if (arity == 1) {
pparen = FALSE;
PRINT_writePostfixTerm(outStream, head, fix, prec, tc, infx,
inprec, args);
} else {
if (pparen) PRINT_writeLParen(outStream);
PRINT_writePostfixTerm(outStream, head, fix, prec, OP_LEFT_TERM,
OP_APP_FIXITY, OP_APP_PREC, args);
}
arity--; args++;
break;
case OP_NONE:
if (pparen) PRINT_writeLParen(outStream);
PRINT_writeTerm(outStream,head,OP_APP_FIXITY,OP_APP_PREC,OP_LEFT_TERM);
break;
} /*switch*/
/* print the arguments (if any) of the application */
while (arity > 0) {
PRINT_writeSpace(outStream, 1);
PRINT_writeTerm(outStream, args, OP_APP_FIXITY, OP_APP_PREC,
OP_RIGHT_TERM);
args++;
arity--;
}
if (pparen) PRINT_writeRParen(outStream);
}
void HN_hnormOcc(DF_TermPtr tmPtr)
{
HN_setEmptyEnv();
HNL_initRegs();
tmPtr = HN_hnormDispatchOcc(DF_termDeref(tmPtr), FALSE);
}