diff options
| author | kr.angelov <kr.angelov@gmail.com> | 2012-07-31 15:16:04 +0000 |
|---|---|---|
| committer | kr.angelov <kr.angelov@gmail.com> | 2012-07-31 15:16:04 +0000 |
| commit | 83b321d862472f31c0c9f7feca8360ad5bfe8a75 (patch) | |
| tree | 0f0ef20ad78e25b320013c7bb160211a8612d4e9 /src/runtime/c/teyjus/simulator | |
| parent | 314662dd09d5d1480007faa79258b0e93cc2aa59 (diff) | |
An initial import of the teyjus source code in the C runtime for GF. The two runtime are still not connected but the source code compiles.
Diffstat (limited to 'src/runtime/c/teyjus/simulator')
32 files changed, 11081 insertions, 0 deletions
diff --git a/src/runtime/c/teyjus/simulator/abstmachine.c b/src/runtime/c/teyjus/simulator/abstmachine.c new file mode 100644 index 000000000..a1b4da273 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/abstmachine.c @@ -0,0 +1,617 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* File abstmachine.c. This file defines the various registers, */ +/* data areas and record types and their operations relevant to the */ +/* abstract machine. */ +/* */ +/****************************************************************************/ +#ifndef ABSTMACHINE_C +#define ABSTMACHINE_C + +#include "mctypes.h" +#include "mcstring.h" +#include "dataformats.h" +#include "abstmachine.h" +#include "instraccess.h" +#include "../system/error.h" +#include "../system/memory.h" + +/****************************************************************************/ +/* ABSTRACT MACHINE REGISTERS (AND FLAGS) */ +/****************************************************************************/ +AM_DataType AM_regs[AM_NUM_OF_REG];//argument regs/temp variable +//data register access: return the address of the ith register +AM_DataTypePtr AM_reg(int i) { return (AM_regs + i); } + +MemPtr AM_hreg; //heap top +MemPtr AM_hbreg; //heap backtrack point +MemPtr AM_ereg; //current environment +MemPtr AM_breg; //last choice point +MemPtr AM_b0reg; //cut point +MemPtr AM_ireg; //impl pt reg, defining prog context +MemPtr AM_cireg; //impl pt for current clause +MemPtr AM_cereg; //closure environment +MemPtr AM_tosreg; //top of stack impl or choice pt. +MemPtr AM_trreg; //trail top +MemPtr AM_pdlTop; //top of pdl +MemPtr AM_pdlBot; //(moving) bottom of pdl +MemPtr AM_typespdlBot; //(moving) bottom of types pdl + +DF_TermPtr AM_sreg; //"structure" pointer +DF_TypePtr AM_tysreg; //type structure pointer + +CSpacePtr AM_preg; //program pointer +CSpacePtr AM_cpreg; //continuation pointer + +Flag AM_bndFlag; //does binding of free var (term) occur? +Flag AM_writeFlag; //in write mode? +Flag AM_tyWriteFlag; //in ty write mode? +Flag AM_ocFlag; //occurs check? + +Flag AM_consFlag; //cons? +Flag AM_rigFlag; //rigid? + +//The size of AM_numAbs is decided by that of relevant fields in term +//representations which can be found in dataformats.c +TwoBytes AM_numAbs; //number of abstractions in hnf +//The size of AM_numArgs is decided by that of relevant fields in term +//representations which can be found in dataformats.c +TwoBytes AM_numArgs; //number of arguments in hnf + +DF_TermPtr AM_head; //head of a hnf +DF_TermPtr AM_argVec; //argument vector of a hnf + +DF_TermPtr AM_vbbreg; //variable being bound for occ +DF_TypePtr AM_tyvbbreg; //type var being bound for occ + +//The size of AM_adjreg is decided by that of relevant fields in term +//representations which can be found in dataformats.c +TwoBytes AM_adjreg; //univ count of variable being bound +TwoBytes AM_ucreg; //universe count register + +DF_DisPairPtr AM_llreg; //ptr to the live list + +/****************************************************************************/ +/* STACK, HEAP, TRAIL AND PDL RELATED STUFF */ +/****************************************************************************/ + +MemPtr AM_heapBeg, //beginning of the heap + AM_heapEnd, //end of the heap + AM_stackBeg, //beginning of the trail + AM_stackEnd, //end of the trail + AM_trailBeg, //beginning of the trail + AM_trailEnd, //end of the trail + AM_pdlBeg, //beginning of pdl + AM_pdlEnd, //end of pdl + AM_fstCP; //the first choice point + +/****************************************************************************/ +/* CODE PLACED IN THE HEAP BY THE SYSTEM */ +/****************************************************************************/ +CSpacePtr AM_failCode; +CSpacePtr AM_andCode; +CSpacePtr AM_orCode; +CSpacePtr AM_allCode; +CSpacePtr AM_solveCode; +CSpacePtr AM_builtinCode; +CSpacePtr AM_eqCode; +CSpacePtr AM_stopCode; +CSpacePtr AM_haltCode; +CSpacePtr AM_notCode1; +CSpacePtr AM_notCode2; +CSpacePtr AM_proceedCode; + + +Boolean AM_isFailInstr(CSpacePtr cptr) { return (cptr == AM_failCode); } +/****************************************************************************/ +/* VITUAL MACHINE MEMORY OPERATIONS */ +/****************************************************************************/ +//is the given addr referring to a register? +Boolean AM_regAddr(MemPtr p) +{ + //TODO: + // AM_reg lacked conversion to MemPtr; why is a function getting + // converted in this way? + return ((((MemPtr)AM_reg) <= p) && (p < (MemPtr)((MemPtr)AM_reg + AM_NUM_OF_REG))); +} +//is the given addr on stack? +Boolean AM_stackAddr(MemPtr p) { return (p > AM_hreg); } +//is the given addr not on heap? +Boolean AM_nHeapAddr(MemPtr p) { return ((p > AM_hreg) || (AM_heapBeg > p));} + + //is the "first" impl/impt record? +Boolean AM_botIP(MemPtr p) { return (p == AM_stackBeg); } +//is the "first" choice point"? +Boolean AM_botCP() { return (AM_breg == AM_fstCP); } +//no env record left on the stack? +Boolean AM_noEnv() { return (AM_ereg == AM_stackBeg); } + + +MemPtr AM_findtos(int i) +{ + return ((AM_tosreg > AM_ereg) ? AM_tosreg : + (MemPtr)(((AM_DataTypePtr)(AM_ereg + 2)) + i)); +} +MemPtr AM_findtosEnv() +{ + return ((AM_tosreg > AM_ereg) ? AM_tosreg : + (MemPtr)(((AM_DataTypePtr)(AM_ereg + 2))+INSACC_CALL_I1(AM_cpreg))); + +} +//set AM_tosreg to the top imp or choice pt +void AM_settosreg() +{ + if (AM_ireg > AM_breg) AM_tosreg = AM_ireg + AM_IMP_FIX_SIZE; + else AM_tosreg = AM_breg + 1; +} + + +/***************************************************************************/ +/* ENVIRONMENT RECORD OPERATIONS */ +/***************************************************************************/ +//environment record creation function +MemPtr AM_mkEnv(MemPtr ep) //create the fixed part of env rec +{ + *((MemPtr *)(ep - 3)) = AM_cireg; //CI field + *((MemPtr *)(ep - 2)) = AM_ereg; //CE field + *((int *)(ep - 1)) = AM_ucreg; //UC field + *((CSpacePtr *)ep) = AM_cpreg; //CP field + return (ep - 1); +} +MemPtr AM_mkEnvWOUC(MemPtr ep) //ct fixed part of env without uc +{ + *((MemPtr *)(ep - 3)) = AM_cireg; //CI field + *((MemPtr *)(ep - 2)) = AM_ereg; //CE field + *((CSpacePtr *)ep) = AM_cpreg; //CP field + return (ep - 1); +} + +//environment record access functions (current top-level env record) +//the env continuation point +CSpacePtr AM_envCP() { return *((CSpacePtr *)(AM_ereg + 1));} +//the uc value +int AM_envUC() { return *((int *)AM_ereg); } +//continuation point +MemPtr AM_envCE() { return *((MemPtr *)(AM_ereg - 1)); } +//impl point +MemPtr AM_envCI(MemPtr ep) { return *((MemPtr *)(AM_ereg - 2)); } +//the nth var fd +AM_DataTypePtr AM_envVar(int n) +{ + return (AM_DataTypePtr)(((AM_DataTypePtr)AM_ereg) + n); +} +//is p an address in the current env? +Boolean AM_inCurEnv(MemPtr p) { return (p > AM_ereg); } + +//access functions for clause environment +AM_DataTypePtr AM_cenvVar(int n) //the nth var fd in clause env +{ + return (AM_DataTypePtr)(((AM_DataTypePtr)AM_cereg) + n); +} + +/****************************************************************************/ +/* CHOICE POINT OPERATIONS */ +/****************************************************************************/ +//choice point creation functions +void AM_mkCP(MemPtr cp, CSpacePtr label, int n) //create a choice pt +{ + *((MemPtr *)cp) = AM_hreg; //heap point + *((CSpacePtr *)(cp - 1)) = label; //next clause ptr + *((MemPtr *)(cp - 2)) = AM_trreg; //trail point + *((DF_DisPairPtr *)(cp - 3)) = AM_llreg; //live list + *((MemPtr *)(cp - 4)) = AM_b0reg; //cut point + *((MemPtr *)(cp - 5)) = AM_breg; //previous choice pt + *((MemPtr *)(cp - 6)) = AM_cireg; //clause context + *((MemPtr *)(cp - 7)) = AM_ireg; //program context + *((CSpacePtr *)(cp - 8)) = AM_cpreg; //cont. code ptr + *((MemPtr *)(cp - 9)) = AM_ereg; //cont. env ptr + *((TwoBytes *)(cp - 10)) = AM_ucreg; //universe count + + for (; n > 0; n--) //save reg(1) to reg(n) + *(((AM_DataTypePtr)(cp - 10)) - n) = *AM_reg(n); +} +void AM_saveStateCP(MemPtr cp, CSpacePtr label) +{ + *((MemPtr *)cp) = AM_hreg; //heap point + *((CSpacePtr *)(cp - 1)) = label; //next clause ptr + *((MemPtr *)(cp - 2)) = AM_trreg; //trail point + *((DF_DisPairPtr *)(cp - 3)) = AM_llreg; //live list + *((MemPtr *)(cp - 4)) = AM_b0reg; //cut point + *((MemPtr *)(cp - 5)) = AM_breg; //previous choice pt + *((MemPtr *)(cp - 6)) = AM_cireg; //clause context + *((MemPtr *)(cp - 7)) = AM_ireg; //program context + *((CSpacePtr *)(cp - 8)) = AM_cpreg; //cont. code ptr + *((MemPtr *)(cp - 9)) = AM_ereg; //cont. env ptr + *((TwoBytes *)(cp - 10)) = AM_ucreg; //universe count +} +//set the next clause field in the current top choice point +void AM_setNClCP(CSpacePtr ncl) +{ + *((CSpacePtr *)(AM_breg - 1)) = ncl; +} + + +//restore function +//restore all components of a choice point except the trail top and the +//backtrack point registers +void AM_restoreRegs(int n) +{ + for (; n > 0; n--) + AM_regs[n] = *(((AM_DataTypePtr)(AM_breg - 10)) - n); + + AM_hreg = *((MemPtr *)AM_breg); + AM_llreg = *((DF_DisPairPtr *)(AM_breg - 3)); + AM_b0reg = *((MemPtr *)(AM_breg - 4)); + AM_cireg = *((MemPtr *)(AM_breg - 6)); + AM_ireg = *((MemPtr *)(AM_breg - 7)); + AM_cpreg = *((CSpacePtr *)(AM_breg - 8)); + AM_ereg = *((MemPtr *)(AM_breg - 9)); + AM_ucreg = *((TwoBytes *)(AM_breg - 10)); +} +//restore all components of a choice point except the trail top, the backtrack +//point and the clause context registers +void AM_restoreRegsWoCI(int n) +{ + for (; n > 0; n--) + AM_regs[n] = *(((AM_DataTypePtr)(AM_breg - 10)) - n); + + AM_hreg = *((MemPtr *)AM_breg); + AM_llreg = *((DF_DisPairPtr *)(AM_breg - 3)); + AM_b0reg = *((MemPtr *)(AM_breg - 4)); + AM_ireg = *((MemPtr *)(AM_breg - 7)); + AM_cpreg = *((CSpacePtr *)(AM_breg - 8)); + AM_ereg = *((MemPtr *)(AM_breg - 9)); + AM_ucreg = *((TwoBytes *)(AM_breg - 10)); +} + +//access functions +MemPtr AM_cpH() { return *((MemPtr *)(AM_breg)); } +CSpacePtr AM_cpNCL() { return *((CSpacePtr *)(AM_breg - 1)); } +MemPtr AM_cpTR() { return *((MemPtr *)(AM_breg - 2)); } +MemPtr AM_cpB() { return *((MemPtr *)(AM_breg - 5)); } +MemPtr AM_cpCI() { return *((MemPtr *)(AM_breg - 6)); } + +AM_DataTypePtr AM_cpArg(MemPtr cp, int n) //addr of nth arg in a given cp +{ + return ((AM_DataTypePtr)(cp - 10)) - n; +} + +/***************************************************************************/ +/* IMPLICATION/IMPORT RECORD OPERATIONS */ +/***************************************************************************/ +/* The tags for distinguishing implication and import records */ +typedef enum +{ + AM_IMPTAG_IMPLICATION, //implication record + AM_IMPTAG_IMPTWOLOCAL, //import record without locals + AM_IMPTAG_IMPTWLOCAL //import record with locals +} AM_ImpTag; + +//finding code for a predicate in the program context given by the value of +//the AM_ireg. +void AM_findCode(int constInd, CSpacePtr *clPtr, MemPtr *iptr) +{ + CSpacePtr myclPtr = NULL; + MemPtr myiptr = AM_ireg; + int size; + while (!AM_botIP(myiptr)) { + if ((size = AM_impPSTS(myiptr)) && + (myclPtr = (*(AM_impFC(myiptr)))(constInd,size,AM_impPST(myiptr)))) + break; + else myiptr = AM_impPIP(myiptr); + } + *clPtr = myclPtr; + *iptr = myiptr; +} +//creating the fixed part of a new implication/import record +void AM_mkImplRec(MemPtr ip, MemPtr sTab, int sTabSize, MEM_FindCodeFnPtr fnPtr) +{ + *((MemPtr *)ip) = AM_ereg; //CE: clause env + *(ip+1) = (Mem)AM_IMPTAG_IMPLICATION; //tag + *((MemPtr *)(ip+2)) = sTab; //PST: search table addr + *((MEM_FindCodeFnPtr *)(ip+3)) = fnPtr; //FC: find code fn ptr + *((MemPtr *)(ip+4)) = AM_ireg; //PIP: previous ip addr + *((int *)(ip+5)) = sTabSize; //PSTS: search table size +} + +//creating the fixed part of a new import record with local consts +void AM_mkImptRecWL(MemPtr ip, int npreds, MemPtr sTab, int sTabSize, + MEM_FindCodeFnPtr fnPtr) +{ + *((int *)ip) = npreds; //NPred: # preds + *(ip+1) = (Mem)AM_IMPTAG_IMPTWLOCAL; //tag + *((MemPtr *)(ip+2)) = sTab; //PST: search table addr + *((MEM_FindCodeFnPtr *)(ip+3)) = fnPtr; //FC: find code fn ptr + *((MemPtr *)(ip+4)) = AM_ireg; //PIP: previous ip addr + *((int *)(ip+5)) = sTabSize; //PSTS: search table size +} +//creating the fixed part of a new import record without local consts +void AM_mkImptRecWOL(MemPtr ip, int npreds, MemPtr sTab, int sTabSize, + MEM_FindCodeFnPtr fnPtr) +{ + *((int *)ip) = npreds; //NPred: # preds + *(ip+1) = (Mem)AM_IMPTAG_IMPTWOLOCAL;//tag + *((MemPtr *)(ip+2)) = sTab; //PST: search table addr + *((MEM_FindCodeFnPtr *)(ip+3)) = fnPtr; //FC: find code fn ptr + *((MemPtr *)(ip+4)) = AM_ireg; //PIP: previous ip addr + *((int *)(ip+5)) = sTabSize; //PSTS: search table size +} + +//creating a dummy import point +void AM_mkDummyImptRec(MemPtr ip) +{ + *((int *)ip) = 0; + *(ip+1) = (Mem)AM_IMPTAG_IMPTWOLOCAL; +} + + +/*initializing the next clause table in an implication/import record.*/ +void AM_mkImpNCLTab(MemPtr ip, MemPtr linkTab, int size) +{ + int constInd; + CSpacePtr clausePtr; + MemPtr iptr; + MemPtr nextCl = AM_impNCL(ip, size);//the first entry in the NCL table + size--; + for (; size >= 0; size--) { + constInd = MEM_implIthLT(linkTab, size); + AM_findCode(constInd, &clausePtr, &iptr); + if (clausePtr) { //if found + *((CSpacePtr *)nextCl) = clausePtr; + *((MemPtr *)(nextCl+1))= iptr; + } else { //not found + *((CSpacePtr *)nextCl) = AM_failCode; + *((MemPtr *)(nextCl+1))= NULL; + } + nextCl += AM_NCLT_ENTRY_SIZE; + } //for loop +} +//initializing the backchained vector in an import record +void AM_initBCKVector(MemPtr ip, int nclTabSize, int nSegs) +{ + MemPtr bcVecPtr = ip - nclTabSize - (AM_BCKV_ENTRY_SIZE * nSegs); + for (; (nSegs > 0); nSegs--){ + *((int *)bcVecPtr) = 0; + *((MemPtr *)(bcVecPtr+1)) = AM_breg; + bcVecPtr += AM_BCKV_ENTRY_SIZE; + } +} +//set back chained number in a given back chained field +void AM_setBCKNo(MemPtr bck, int n) { *((int *)bck) = n; } +//set most recent cp in a given back chained field +void AM_setBCKMRCP(MemPtr bck, MemPtr mrcp) { *((MemPtr *)(bck+1)) = mrcp; } +//initializing the universe indices in the symbol table entries for constants +//local to a module +void AM_initLocs(int nlocs, MemPtr locTab) +{ + nlocs--; + for (; nlocs >= 0; nlocs--) + AM_setCstUnivCount(MEM_impIthLCT(locTab, nlocs), AM_ucreg); +} + +//implication/import record access functions +//the ith entry of next clause tab +MemPtr AM_impNCL(MemPtr ip, int i) {return (ip - AM_NCLT_ENTRY_SIZE * i);} +//code in a next clause field +CSpacePtr AM_impNCLCode(MemPtr ncl) {return *((CSpacePtr *)ncl); } +//ip in a next clause field +MemPtr AM_impNCLIP(MemPtr ncl) {return *((MemPtr *)(ncl+1)); } +//the ith entry of back chained vec +MemPtr AM_cimpBCK(int i) +{ return (AM_cireg-AM_NCLT_ENTRY_SIZE*AM_cimpNPreds()-AM_BCKV_ENTRY_SIZE*i); } +//back chain num in a bck field +int AM_impBCKNo(MemPtr bck) {return *((int *)bck); } +//most recent cp is a bck field +MemPtr AM_impBCKMRCP(MemPtr bck) {return *((MemPtr *)(bck+1)); } +//clause env of in imp rec referred to by cireg +MemPtr AM_cimpCE() {return *((MemPtr *)AM_cireg); } +//# preds of impt rec +int AM_cimpNPreds() {return *((int *)AM_cireg); } + //search table addr +MemPtr AM_impPST(MemPtr ip) {return *((MemPtr *)(ip + 2)); } +//find code function pointer +MEM_FindCodeFnPtr AM_impFC(MemPtr ip) {return *((MEM_FindCodeFnPtr *)(ip + 3));} +//PIP in given imp point +MemPtr AM_impPIP(MemPtr ip) {return *((MemPtr *)(ip + 4)); } +//previous ip in the current top imp point +MemPtr AM_curimpPIP() {return *((MemPtr *)(AM_ireg + 4)); } +//search table size +int AM_impPSTS(MemPtr ip) {return *((int *)(ip + 5)); } + + +Boolean AM_isImptWL(MemPtr ip) { //is an imp rec a import rec w local + return ((AM_ImpTag)(*(ip+1)) == AM_IMPTAG_IMPTWLOCAL); +} +Boolean AM_isImptWOL(MemPtr ip){ //is an imp rec a import rec wo local + return ((AM_ImpTag)(*(ip+1)) == AM_IMPTAG_IMPTWOLOCAL); +} +Boolean AM_isImpl(MemPtr ip){ //is an imp rec a implication rec + return ((AM_ImpTag)(*(ip+1)) == AM_IMPTAG_IMPLICATION); +} +Boolean AM_isImpt(MemPtr ip){ //is an imp rec a import rec + return ((AM_ImpTag)(*(ip+1)) != AM_IMPTAG_IMPLICATION); +} + +Boolean AM_isImplCI(){ //is rec referred to by CI impl? + return ((AM_ImpTag)(*(AM_cireg+1)) == AM_IMPTAG_IMPLICATION); +} +Boolean AM_isCurImptWL(){ //is rec referred to by I impt with loc? + return ((AM_ImpTag)(*(AM_ireg+1)) == AM_IMPTAG_IMPTWLOCAL); +} + +/***************************************************************************/ +/* LIVE LIST OPERATIONS */ +/***************************************************************************/ +//live list is empty? +Boolean AM_empLiveList() { return (AM_llreg == DF_EMPTY_DIS_SET);} + +//live list not empty? +Boolean AM_nempLiveList(){ return (AM_llreg != DF_EMPTY_DIS_SET);} + +//add a dis pair to the live list when not knowning it is empty or not +void AM_addDisPair(DF_TermPtr tPtr1, DF_TermPtr tPtr2) +{ + MemPtr nhtop = AM_hreg + DF_DISPAIR_SIZE; + AM_heapError(nhtop); + DF_mkDisPair(AM_hreg, AM_llreg, tPtr1, tPtr2); + AM_llreg = (DF_DisPairPtr)AM_hreg; + AM_hreg = nhtop; +} + +/***************************************************************************/ +/* PDL OPERATIONS */ +/***************************************************************************/ +//pop (term/type) PDL +MemPtr AM_popPDL() { return (MemPtr)(*(--AM_pdlTop)); } +//push (term/type) PDL +void AM_pushPDL(MemPtr addr) { (*AM_pdlTop++) = (Mem)addr; } +//is empty PDL? +Boolean AM_emptyPDL() { return (AM_pdlTop == AM_pdlBot); } +//is not empty PDL? +Boolean AM_nemptyPDL() { return (AM_pdlTop > AM_pdlBot); } +//initialize PDL +void AM_initPDL() { AM_pdlTop = AM_pdlBot = AM_pdlBeg; } +//is empty type PDL? +Boolean AM_emptyTypesPDL() { return (AM_pdlTop == AM_typespdlBot); } +//is not empty type PDL? +Boolean AM_nemptyTypesPDL() { return (AM_pdlTop > AM_typespdlBot); } +//initialize type PDL +void AM_initTypesPDL() { AM_typespdlBot = AM_pdlTop; } +//recover type PDL to the status before type unification +void AM_resetTypesPDL() { AM_pdlTop = AM_typespdlBot; } + + +/****************************************************************************/ +/* RUN-TIME SYMBOL TABLES */ +/****************************************************************************/ +MEM_KstPtr AM_kstBase; //starting addr of the kind symbol table +MEM_TstPtr AM_tstBase; //starting addr of the type skel table +MEM_CstPtr AM_cstBase; //starting addr of the const symbol table + +/* Kind symbol table */ +char* AM_kstName(int n) //name of a type constructor in a given entry +{ + return MCSTR_toCString( + DF_strDataValue(((MEM_KstPtr)(((MemPtr)AM_kstBase) + + n*MEM_KST_ENTRY_SIZE)) -> name)); +} + +int AM_kstArity(int n) //arity of a type constructor in a given entry +{ + return ((MEM_KstPtr)(((MemPtr)AM_kstBase) + n*MEM_KST_ENTRY_SIZE)) -> arity; +} + +/* Type skeleton table */ +DF_TypePtr AM_tstSkel(int n) //type skeleton in a given entry +{ + return (DF_TypePtr)(((MemPtr)AM_tstBase) + n*MEM_TST_ENTRY_SIZE); +} + +/* Constant symbol table */ +char* AM_cstName(int n) //name of a constant in a given entry +{ + DF_StrDataPtr nameData = ((MEM_CstPtr)(((MemPtr)AM_cstBase) + + n * MEM_CST_ENTRY_SIZE)) -> name; + if (nameData) return MCSTR_toCString(DF_strDataValue(nameData)); + else return NULL; + //return MCSTR_toCString( + // DF_strDataValue(((MEM_CstPtr)(((MemPtr)AM_cstBase) + + // n*MEM_CST_ENTRY_SIZE)) -> name)); +} + +int AM_cstTyEnvSize(int n) //type environment size +{ + return ((MEM_CstPtr)(((MemPtr)AM_cstBase)+n*MEM_CST_ENTRY_SIZE))-> + typeEnvSize; +} +int AM_cstNeeded(int n) //neededness info +{ + return ((MEM_CstPtr)(((MemPtr)AM_cstBase)+n*MEM_CST_ENTRY_SIZE))-> + neededness; + +} +int AM_cstUnivCount(int n) //universe count +{ + return ((MEM_CstPtr)(((MemPtr)AM_cstBase)+n*MEM_CST_ENTRY_SIZE))->univCount; +} +int AM_cstPrecedence(int n) //precedence +{ + return ((MEM_CstPtr)(((MemPtr)AM_cstBase)+n*MEM_CST_ENTRY_SIZE))-> + precedence; +} +int AM_cstFixity(int n) //fixity +{ + return ((MEM_CstPtr)(((MemPtr)AM_cstBase)+n*MEM_CST_ENTRY_SIZE))->fixity; +} +int AM_cstTySkelInd(int n) //type skeleton index +{ + return ((MEM_CstPtr)(((MemPtr)AM_cstBase)+n*MEM_CST_ENTRY_SIZE))-> + tskTabIndex; +} + +void AM_setCstUnivCount(int n, int uc) //set universe count +{ + ((MEM_CstPtr)(((MemPtr)AM_cstBase)+n*MEM_CST_ENTRY_SIZE))->univCount = uc; +} + +/**************************************************************************** + * OVERFLOW ERROR FUNCTIONS * + ****************************************************************************/ +void AM_heapError(MemPtr p) //heap overflow +{ + if (AM_heapEnd < p) EM_error(SIM_ERROR_HEAP_OVERFL); +} +void AM_stackError(MemPtr p) //stack overflow +{ + if (AM_stackEnd < p) EM_error(SIM_ERROR_STACK_OVERFL); +} +void AM_pdlError(int n) //pdl overflow for n cells +{ + if (AM_pdlEnd < (AM_pdlTop + n)) EM_error(SIM_ERROR_PDL_OVERFL); +} +void AM_trailError(int n) //trail overflow for n cells +{ + if (AM_trailEnd < (AM_trreg + n)) + EM_error(SIM_ERROR_TRAIL_OVERFL); +} + + +/**************************************************************************** + * MISCELLANEOUS OTHER ERRORS * + ****************************************************************************/ +void AM_embedError(int n) //violation of max number of lambda embeddings +{ + if (n > DF_MAX_BV_IND) + EM_error(SIM_ERROR_TOO_MANY_ABSTRACTIONS, DF_MAX_BV_IND); +} +void AM_arityError(int n) // violation of max number of arity in applications +{ + if (n > DF_TM_MAX_ARITY) EM_error(SIM_ERROR_TOO_MANY_ARGUMENTS, + DF_TM_MAX_ARITY); +} +void AM_ucError(int n) //violation of maximum of universe count +{ + if (n == DF_MAX_UNIVIND) EM_error(SIM_ERROR_TOO_MANY_UNIV_QUANTS); +} + +#endif //ABSTMACHINE_C diff --git a/src/runtime/c/teyjus/simulator/abstmachine.h b/src/runtime/c/teyjus/simulator/abstmachine.h new file mode 100644 index 000000000..c43fdb4f7 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/abstmachine.h @@ -0,0 +1,346 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* File abstmachine.h. This header file defines the various registers, */ +/* data areas and record types relevant to the abstract machine. */ +/* */ +/****************************************************************************/ +#ifndef ABSTMACHINE_H +#define ABSTMACHINE_H + +#include <stdlib.h> +#include <math.h> +#include "mctypes.h" +#include "dataformats.h" +#include "../system/memory.h" +#include "../system/error.h" + +/***************************######******************************************** + * ERROR INFORMATION + *********************************######**************************************/ + +#define SIM_NUM_ERROR_MESSAGES 13 +enum +{ + SIM_ERROR = SIM_FIRST_ERR_INDEX, + SIM_ERROR_TOO_MANY_ABSTRACTIONS, + SIM_ERROR_TOO_MANY_ARGUMENTS, + SIM_ERROR_TOO_MANY_UNIV_QUANTS, + SIM_ERROR_HEAP_TOO_BIG, + SIM_ERROR_HEAP_TOO_SMALL, + SIM_ERROR_CANNOT_ALLOCATE_HEAP, + SIM_ERROR_CANNOT_ALLOCATE_HEAP_MESSAGE, + SIM_ERROR_CANNOT_ALLOCATE_HEAP_SUGGESTION, + SIM_ERROR_TRAIL_OVERFL, + SIM_ERROR_HEAP_OVERFL, + SIM_ERROR_STACK_OVERFL, + SIM_ERROR_PDL_OVERFL, +}; + +typedef union //the type of data: (atomic) term or type +{ + DF_Term term; + DF_Type type; +} AM_DataType; + +typedef AM_DataType *AM_DataTypePtr; + +//#define AM_DATA_SIZE (int)ceil((double)sizeof(AM_DataType)/WORD_SIZE) +#define AM_DATA_SIZE 2 + +/****************************************************************************/ +/* ABSTRACT MACHINE REGISTERS (AND FLAGS) */ +/****************************************************************************/ + +typedef enum {OFF = 0, ON = 1} AM_FlagTypes; //FLAG type +typedef Byte Flag; + + +/*There are 255 argument registers numbered 1 through 255; Reg_0 is never + used. (agree with instruction format)*/ +#define AM_NUM_OF_REG 256 +extern AM_DataType AM_regs[AM_NUM_OF_REG];//argument regs/temp variables + +//data register access: return the address of the ith register +AM_DataTypePtr AM_reg(int i); + +extern MemPtr AM_hreg; //heap top +extern MemPtr AM_hbreg; //heap backtrack point +extern MemPtr AM_ereg; //current environment +extern MemPtr AM_breg; //last choice point +extern MemPtr AM_b0reg; //cut point +extern MemPtr AM_ireg; //impl pt reg, defining prog context +extern MemPtr AM_cireg; //impl pt for current clause +extern MemPtr AM_cereg; //closure environment +extern MemPtr AM_tosreg; //top of stack impl or choice pt. +extern MemPtr AM_trreg; //trail top +extern MemPtr AM_pdlTop; //top of pdl +extern MemPtr AM_pdlBot; //(moving) bottom of pdl +extern MemPtr AM_typespdlBot; //(moving) bottom of types pdl + +extern DF_TermPtr AM_sreg; //"structure" pointer +extern DF_TypePtr AM_tysreg; //type structure pointer + +extern CSpacePtr AM_preg; //program pointer +extern CSpacePtr AM_cpreg; //continuation pointer + +extern DF_DisPairPtr AM_llreg; //ptr to the live list + +extern Flag AM_bndFlag; //does binding on fv (term) occur? +extern Flag AM_writeFlag; //in write mode? +extern Flag AM_tyWriteFlag; //in ty write mode? +extern Flag AM_ocFlag; //occurs check? + +extern Flag AM_consFlag; //cons? +extern Flag AM_rigFlag; //rigid? + +extern TwoBytes AM_numAbs; //number of abstractions in hnf +extern TwoBytes AM_numArgs; //number of arguments in hnf + +extern DF_TermPtr AM_head; //head of a hnf +extern DF_TermPtr AM_argVec; //argument vector of a hnf + +extern DF_TermPtr AM_vbbreg; //variable being bound for occ +extern DF_TypePtr AM_tyvbbreg; //type var being bound for occ +extern TwoBytes AM_adjreg; //univ count of variable being bound + +extern TwoBytes AM_ucreg; //universe count register + +/****************************************************************************/ +/* STACK, HEAP, TRAIL AND PDL RELATED STUFF */ +/****************************************************************************/ +extern MemPtr AM_heapBeg, //beginning of the heap + AM_heapEnd, //end of the heap + AM_stackBeg, //beginning of the stack + AM_stackEnd, //end of the stack + AM_trailBeg, //beginning of the trail + AM_trailEnd, //end of the trail + AM_pdlBeg, //beginning of pdl + AM_pdlEnd, //end of pdl + AM_fstCP; //the first choice point + + +/****************************************************************************/ +/* CODE PLACED IN THE HEAP BY THE SYSTEM */ +/****************************************************************************/ +extern CSpacePtr AM_failCode; +extern CSpacePtr AM_andCode; +extern CSpacePtr AM_orCode; +extern CSpacePtr AM_allCode; +extern CSpacePtr AM_solveCode; +extern CSpacePtr AM_builtinCode; +extern CSpacePtr AM_eqCode; +extern CSpacePtr AM_stopCode; +extern CSpacePtr AM_haltCode; +extern CSpacePtr AM_notCode1; +extern CSpacePtr AM_notCode2; +extern CSpacePtr AM_proceedCode; + + +Boolean AM_isFailInstr(CSpacePtr cptr); +/****************************************************************************/ +/* VITUAL MACHINE MEMORY OPERATIONS */ +/****************************************************************************/ +Boolean AM_regAddr(MemPtr p); //is the given addr referring to a register? +Boolean AM_stackAddr(MemPtr p); //is the given addr on stack? +Boolean AM_nHeapAddr(MemPtr p); //is the given addr on heap? + +Boolean AM_botIP(MemPtr p); //is the "first" impl/impt record? +Boolean AM_botCP(); //is the "first" choice point? +Boolean AM_noEnv(); //no env record left on the stack? + +MemPtr AM_findtos(int i); +MemPtr AM_findtosEnv(); +void AM_settosreg(); //set AM_tosreg to the top imp or choice pt + +/***************************************************************************/ +/* ENVIRONMENT RECORD OPERATIONS */ +/***************************************************************************/ +#define AM_ENV_FIX_SIZE 4 //size of the fix part of env rec + +//environment record creation function +MemPtr AM_mkEnv(MemPtr ep); //create the fixed part of env rec +MemPtr AM_mkEnvWOUC(MemPtr ep); //ct fixed part of env without uc + +//environment record access functions (current top env record) +AM_DataTypePtr AM_envVar(int n); //the nth var fd +int AM_envUC(); //the env universe count +CSpacePtr AM_envCP(); //the env continuation point +MemPtr AM_envCE(); //continuation point +MemPtr AM_envCI(); //impl point +Boolean AM_inCurEnv(MemPtr p); //is p an addr in the curr env? + +//access functions for clause environment +AM_DataTypePtr AM_cenvVar(int n); //the nth var fd in clause env + +/****************************************************************************/ +/* CHOICE POINT OPERATIONS */ +/****************************************************************************/ +#define AM_CP_FIX_SIZE 11 //size of the fix part of choice point + +//choice point creation functions +void AM_mkCP(MemPtr cp, CSpacePtr label, int n); //create a choice pt +void AM_saveStateCP(MemPtr cp, CSpacePtr label); +void AM_setNClCP(CSpacePtr ncl); //set the ncl fd in top ch pt + +//restore functions +//restore all components of a choice point except the trail top and the +//backtrack point registers +void AM_restoreRegs(int n); +//restore all components of a choice point except the trail top, the backtrack +//point and the clause context registers +void AM_restoreRegsWoCI(int n); +//access functions +MemPtr AM_cpH(); +CSpacePtr AM_cpNCL(); +MemPtr AM_cpTR(); +MemPtr AM_cpB(); +MemPtr AM_cpCI(); + +AM_DataTypePtr AM_cpArg(MemPtr cp, int n); //addr of nth arg in a given cp + +/***************************************************************************/ +/* IMPLICATION/IMPORT RECORD OPERATIONS */ +/***************************************************************************/ +#define AM_IMP_FIX_SIZE 6 //size of the fix part of impl/impt rec +#define AM_DUMMY_IMPT_REC_SIZE 2 //size of a dummy impt rec +#define AM_NCLT_ENTRY_SIZE 2 //size of each entry in next clause tab +#define AM_BCKV_ENTRY_SIZE 2 //size of ent. in back chained vector + + +//finding code for a predicate in the program context given by the value of +//the AM_ireg. +void AM_findCode(int constInd, CSpacePtr *clPtr, MemPtr *iptr); + +//creating the fixed part of a new implication record +void AM_mkImplRec(MemPtr ip,MemPtr sTab,int sTabSize, MEM_FindCodeFnPtr fnPtr); +//creating the fixed part of a new import record with local consts +void AM_mkImptRecWL(MemPtr ip, int npreds, MemPtr sTab, int sTabSize, + MEM_FindCodeFnPtr fnPtr); +//creating the fixed part of a new import record without local consts +void AM_mkImptRecWOL(MemPtr ip, int npreds, MemPtr sTab, int sTabSize, + MEM_FindCodeFnPtr fnPtr); +//creating a dummy import point +void AM_mkDummyImptRec(MemPtr ip); + +//initializing the next clause table in an implication/import record. +void AM_mkImpNCLTab(MemPtr ip, MemPtr linkTab, int size); +//initializing the backchained vector in an import record +void AM_initBCKVector(MemPtr ip, int nclTabSize, int noSegs); +//set back chained number in a given back chained field +void AM_setBCKNo(MemPtr bck, int n); +//set most recent cp in a given back chained field +void AM_setBCKMRCP(MemPtr bck, MemPtr cp); +//initializing the universe indices in the symbol table entries for constants +//local to a module +void AM_initLocs(int nlocs, MemPtr locTab); + +//implication/import record access functions +MemPtr AM_impNCL(MemPtr ip, int i); //the ith entry of next clause tab +CSpacePtr AM_impNCLCode(MemPtr ncl); //code in a next clause field +MemPtr AM_impNCLIP(MemPtr ncl); //ip in a next clause field +MemPtr AM_cimpBCK(int i); //the ith entry of back chained vec in CI +int AM_impBCKNo(MemPtr bck); //back chain num in a bck field +MemPtr AM_impBCKMRCP(MemPtr bck); //most recent cp is a bck field +MemPtr AM_cimpCE(); //clause env of impl rec in CI +int AM_cimpNPreds(); //# preds of impt rec in CI +MemPtr AM_impPST(MemPtr ip); //search table field addr +MEM_FindCodeFnPtr AM_impFC(MemPtr ip); //find code function field addr +MemPtr AM_impPIP(MemPtr ip); //PIP in given imp point +MemPtr AM_curimpPIP(); //PIP in the current top imp point +int AM_impPSTS(MemPtr ip); //search table size field + +Boolean AM_isImptWL(MemPtr ip); //is an imp rec a import rec w local +Boolean AM_isImptWOL(MemPtr ip); //is an imp rec a import rec wo local +Boolean AM_isImpl(MemPtr ip); //is an imp rec a implication rec +Boolean AM_isImpt(MemPtr ip); //is an imp rec a import rec + +Boolean AM_isImplCI(); //is rec referred to by CI impl? +Boolean AM_isCurImptWL(); //is rec referred to by I impt with loc? + + +/***************************************************************************/ +/* LIVE LIST OPERATIONS */ +/***************************************************************************/ +Boolean AM_empLiveList(); //live list is empty? +Boolean AM_nempLiveList(); //live list not empty? + +//add a dpair to the beginning of live list +void AM_addDisPair(DF_TermPtr tPtr1, DF_TermPtr tPtr2); + +/***************************************************************************/ +/* PDL OPERATIONS */ +/***************************************************************************/ +MemPtr AM_popPDL(); //pop (term/type) PDL +void AM_pushPDL(MemPtr); //push (term/type) PDL + +Boolean AM_emptyPDL(); //is empty PDL? +Boolean AM_nemptyPDL(); //is not empty PDL? +void AM_initPDL(); //initialize PDL + +Boolean AM_emptyTypesPDL(); //is empty type PDL? +Boolean AM_nemptyTypesPDL(); //is not empty type PDL? +void AM_initTypesPDL(); //initialize type PDL +void AM_resetTypesPDL(); //reset PDL to that before ty unif + +/****************************************************************************/ +/* RUN-TIME SYMBOL TABLES */ +/****************************************************************************/ +extern MEM_KstPtr AM_kstBase; //starting addr of the kind symbol table +extern MEM_TstPtr AM_tstBase; //starting addr of the type skel table +extern MEM_CstPtr AM_cstBase; //starting addr of the const symbol table + +/* Kind symbol table */ +char* AM_kstName(int n); //name of a type constructor in a given entry +int AM_kstArity(int n); //arity of a type constructor in a given entry + +/* Type skeleton table */ +DF_TypePtr AM_tstSkel(int n); //type skeleton in a given entry + +/* Constant symbol table */ +char* AM_cstName(int n); //name of a constant in a given entry +int AM_cstTyEnvSize(int n); //type environment size +int AM_cstNeeded(int n); //neededness info +int AM_cstUnivCount(int n); //universe count +int AM_cstPrecedence(int n); //precedence +int AM_cstFixity(int n); //fixity +int AM_cstTySkelInd(int n); //type skeleton index + +void AM_setCstUnivCount(int n, int uc); //set universe count +/**************************************************************************** + * OVERFLOW ERROR FUNCTIONS * + ****************************************************************************/ +void AM_heapError(MemPtr); //heap overflow +void AM_stackError(MemPtr); //stack overflow +void AM_pdlError(int); //pdl stack overflow for n cells +void AM_trailError(int); //trail overflow for n cells + + +/**************************************************************************** + * MISCELLANEOUS OTHER ERRORS * + ****************************************************************************/ +void AM_embedError(int); // violation of max number of lambda embeddings +void AM_arityError(int); // violation of max number of arity in applications +void AM_ucError(int); // violation of maximum of universe count + + +#endif //ABSTMACHINE_H diff --git a/src/runtime/c/teyjus/simulator/dataformats.c b/src/runtime/c/teyjus/simulator/dataformats.c new file mode 100644 index 000000000..ecc1ce5c0 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/dataformats.c @@ -0,0 +1,711 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File dataformat.c. */ +/* The header file identifies the low-level representation of data objects */ +/* that are manipulated by the machine, through various structure types. */ +/****************************************************************************/ +#ifndef DATAFORMATS_C +#define DATAFORMATS_C + +#include <math.h> +#include <string.h> +#include "dataformats.h" +#include "mctypes.h" +#include "mcstring.h" + +/********************************************************************/ +/* */ +/* TYPE REPRESENTATION */ +/* */ +/********************************************************************/ + +/* Types of relevant fields in type representations. */ +typedef TwoBytes DF_KstTabInd; //kind symbol table index +typedef TwoBytes DF_StrTypeArity; //arity of type structure +typedef TwoBytes DF_SkelInd; //offset of variables in type skeletons + + +/* Structure definitions of each type category. */ +typedef struct //type sort +{ + DF_Tag tag; + DF_KstTabInd kindTabIndex; +} DF_SortType; + +typedef struct //type reference +{ + DF_Tag tag; + DF_TypePtr target; +} DF_RefType; + +typedef struct //variables in type skeletons +{ + DF_Tag tag; + DF_SkelInd offset; +} DF_SkVarType; + +typedef struct //type arrows +{ + DF_Tag tag; + DF_TypePtr args; +} DF_ArrowType; + +typedef struct //type functors +{ + DF_Tag tag; + DF_StrTypeArity arity; + DF_KstTabInd kindTabIndex; +} DF_FuncType; + +typedef struct //type structures +{ + DF_Tag tag; + DF_FuncType *funcAndArgs; +} DF_StrType; + +/******************************************************************/ +/* Interface functions */ +/******************************************************************/ + +/* TYPE DEREFERENCE */ +DF_TypePtr DF_typeDeref(DF_TypePtr tyPtr) +{ + DF_Type ty = *tyPtr; + while ((ty.tag.categoryTag == DF_TY_TAG_REF)){ + DF_TypePtr target = (DF_TypePtr)(ty.dummy); + if (tyPtr == target) return tyPtr; + tyPtr = target; + ty = *tyPtr; + } + return tyPtr; +} + +/* TYPE RECOGNITION */ + +Boolean DF_isSortType(DF_TypePtr tyPtr) +{ return (tyPtr->tag.categoryTag == DF_TY_TAG_SORT); } +Boolean DF_isRefType(DF_TypePtr tyPtr) +{ return (tyPtr->tag.categoryTag == DF_TY_TAG_REF); } +Boolean DF_isSkelVarType(DF_TypePtr tyPtr) +{ return (tyPtr->tag.categoryTag == DF_TY_TAG_SKVAR);} +Boolean DF_isArrowType(DF_TypePtr tyPtr) +{ return (tyPtr->tag.categoryTag == DF_TY_TAG_ARROW);} +Boolean DF_isStrType(DF_TypePtr tyPtr) +{ return (tyPtr->tag.categoryTag == DF_TY_TAG_STR); } +Boolean DF_isFreeVarType(DF_TypePtr tyPtr) +{ return ((tyPtr->tag.categoryTag == DF_TY_TAG_REF) + && ((DF_RefType*)tyPtr)->target == tyPtr); } + + +/* TYPE DECOMPOSITION */ +int DF_typeTag(DF_TypePtr tyPtr) //generic type +{ + return tyPtr->tag.categoryTag; +} +int DF_typeKindTabIndex(DF_TypePtr tyPtr) //sorts +{ + return ((DF_SortType*)tyPtr) -> kindTabIndex; +} +int DF_typeSkelVarIndex(DF_TypePtr tyPtr) //skel var +{ + return ((DF_SkVarType*)tyPtr) -> offset; +} +DF_TypePtr DF_typeRefTarget(DF_TypePtr tyPtr) //reference +{ + return ((DF_RefType*)tyPtr) -> target; +} +DF_TypePtr DF_typeArrowArgs(DF_TypePtr tyPtr) //arrows +{ + return ((DF_ArrowType*)tyPtr) -> args; +} +DF_TypePtr DF_typeStrFuncAndArgs(DF_TypePtr tyPtr) //structures +{ + return (DF_TypePtr)(((DF_StrType*)tyPtr)->funcAndArgs); +} +int DF_typeStrFuncInd(DF_TypePtr tyPtr) +{//Note tyPtr must refer to funcAndArgs field + return ((DF_FuncType*)tyPtr)->kindTabIndex; +} +int DF_typeStrFuncArity(DF_TypePtr tyPtr) +{//Note tyPtr must refer to funcAndArgs field + return ((DF_FuncType*)tyPtr)->arity; +} +DF_TypePtr DF_typeStrArgs(DF_TypePtr tyPtr) +{//Note tyPtr must refer to funcAndArgs field + return (DF_TypePtr)(((MemPtr)tyPtr) + DF_TY_ATOMIC_SIZE); +} + +/* TYPE CONSTRUCTION */ +void DF_copyAtomicType(DF_TypePtr src, MemPtr dest) +{ + *((DF_TypePtr)dest) = *src; +} +void DF_mkSortType(MemPtr loc, int ind) +{ + ((DF_SortType*)loc)->tag.categoryTag = DF_TY_TAG_SORT; + ((DF_SortType*)loc)->kindTabIndex = ind; +} +void DF_mkRefType(MemPtr loc, DF_TypePtr target) +{ + ((DF_RefType*)loc)->tag.categoryTag = DF_TY_TAG_REF; + ((DF_RefType*)loc)->target = target; +} +void DF_mkFreeVarType(MemPtr loc) +{ + ((DF_RefType*)loc)->tag.categoryTag = DF_TY_TAG_REF; + ((DF_RefType*)loc)->target = (DF_TypePtr)loc; +} +void DF_mkSkelVarType(MemPtr loc, int offset) +{ + ((DF_SkVarType*)loc)->tag.categoryTag = DF_TY_TAG_SKVAR; + ((DF_SkVarType*)loc)->offset = offset; +} +void DF_mkArrowType(MemPtr loc, DF_TypePtr args) +{ + ((DF_ArrowType*)loc)->tag.categoryTag = DF_TY_TAG_ARROW; + ((DF_ArrowType*)loc)->args = args; +} +void DF_mkStrType(MemPtr loc, DF_TypePtr funcAndArgs) +{ + ((DF_StrType*)loc)->tag.categoryTag = DF_TY_TAG_STR; + ((DF_StrType*)loc)->funcAndArgs = (DF_FuncType*)funcAndArgs; +} +void DF_mkStrFuncType(MemPtr loc, int ind, int n) +{ + ((DF_FuncType*)loc)->tag.categoryTag = DF_TY_TAG_FUNC; + ((DF_FuncType*)loc)->kindTabIndex = ind; + ((DF_FuncType*)loc)->arity = n; +} + +/********************************************************************/ +/* */ +/* TERM REPRESENTATION */ +/* */ +/********************************************************************/ + +/* types of relevant fields in term representions */ +typedef TwoBytes DF_UnivInd; //universe count +typedef TwoBytes DF_CstTabInd; //constant symbol table index +typedef TwoBytes DF_Arity; //application arity +typedef TwoBytes DF_DBInd; //de Bruijn ind, embed level and num of lams +typedef WordPtr DF_StreamTabInd; + +typedef struct //logic variables +{ + DF_Tag tag; + DF_UnivInd univCount; +} DF_VarTerm; + +typedef struct //de Bruijn indices +{ + DF_Tag tag; + DF_DBInd index; +} DF_BVTerm; + +typedef struct { //name and universe count field for constants + DF_UnivInd univCount; + DF_CstTabInd symTabIndex; +} DF_NameAndUC; + +typedef struct { //constant without type association + DF_Tag tag; + Boolean withType; + union { + unsigned int value; + DF_NameAndUC nameAndUC; + } data; +} DF_ConstTerm; + +typedef struct { //constant with type association + DF_Tag tag; + Boolean withType; + union { + unsigned int value; + DF_NameAndUC nameAndUC; + } data; + DF_TypePtr typeEnv; +} DF_TConstTerm; + +typedef struct //integers +{ + DF_Tag tag; + long int value; +} DF_IntTerm; + +typedef struct //floats +{ + DF_Tag tag; + float value; +} DF_FloatTerm; + +typedef struct //string +{ + DF_Tag tag; + DF_StrDataPtr value; +} DF_StrTerm; + +typedef struct //stream +{ + DF_Tag tag; + DF_StreamTabInd index; +} DF_StreamTerm; + +typedef struct //empty list +{ + DF_Tag tag; +} DF_NilTerm; + +typedef struct //reference +{ + DF_Tag tag; + DF_TermPtr target; +} DF_RefTerm; + +typedef struct //list cons +{ + DF_Tag tag; + DF_TermPtr args; +} DF_ConsTerm; + +typedef struct //abstractions +{ + DF_Tag tag; + DF_DBInd numOfLams; + DF_TermPtr body; +} DF_LamTerm; + +typedef struct //applications +{ + DF_Tag tag; + DF_Arity arity; + DF_TermPtr functor; + DF_TermPtr args; +} DF_AppTerm; + +typedef struct //suspensions +{ + DF_Tag tag; + DF_DBInd ol; + DF_DBInd nl; + DF_TermPtr termSkel; + DF_EnvPtr envList; +} DF_SuspTerm; + + +//environment items +typedef struct //dummy environment item +{ + //Boolean isDummy; + DF_Tag tag; + DF_DBInd embedLevel; + DF_EnvPtr rest; +} DF_DummyEnv; + +typedef struct //pair environment item +{ + //Boolean isDummy; + DF_Tag tag; + DF_DBInd embedLevel; + DF_EnvPtr rest; + DF_TermPtr term; +} DF_PairEnv; + + +/******************************************************************/ +/* Interface functions */ +/******************************************************************/ + +/* DEREFERENCE */ +DF_TermPtr DF_termDeref(DF_TermPtr tmPtr) +{ + while (DF_isRef(tmPtr)) tmPtr = ((DF_RefTerm*)tmPtr)->target; + return tmPtr; +} + +/* TERM RECOGNITION */ +//note ref is neither atomic nor complex +Boolean DF_isAtomic(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag < DF_TM_TAG_REF); } +Boolean DF_isNAtomic(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag > DF_TM_TAG_REF); } +Boolean DF_isFV(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_VAR); } +Boolean DF_isConst(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_CONST); } +/*assume the tmPtr is known to be a constant */ +Boolean DF_isTConst(DF_TermPtr tmPtr) +{ return ((DF_ConstTerm*)tmPtr) -> withType; } +Boolean DF_isInt(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_INT); } +Boolean DF_isFloat(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_FLOAT); } +Boolean DF_isNil(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_NIL); } +Boolean DF_isStr(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_STR); } +Boolean DF_isBV(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_BVAR); } +Boolean DF_isStream(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_STREAM);} +Boolean DF_isRef(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_REF); } +Boolean DF_isCons(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_CONS); } +Boolean DF_isLam(DF_TermPtr tmPtr) +{ return (tmPtr -> tag.categoryTag == DF_TM_TAG_LAM); } +Boolean DF_isApp(DF_TermPtr tmPtr) +{ return (tmPtr-> tag.categoryTag == DF_TM_TAG_APP); } +Boolean DF_isSusp(DF_TermPtr tmPtr) +{ return (tmPtr-> tag.categoryTag == DF_TM_TAG_SUSP); } +Boolean DF_isEmpEnv(DF_EnvPtr envPtr) +{ return (envPtr == DF_EMPTY_ENV); } +Boolean DF_isDummyEnv(DF_EnvPtr envPtr) +{ return envPtr -> tag.categoryTag == DF_ENV_TAG_DUMMY; } + + +/* TERM DECOMPOSITION */ +int DF_termTag(DF_TermPtr tmPtr) // tag +{ + return tmPtr -> tag.categoryTag; +} +//unbound variables +int DF_fvUnivCount(DF_TermPtr tmPtr) //universe count +{ + return ((DF_VarTerm*)tmPtr)->univCount; +} +//constant (w/oc type associations) +int DF_constUnivCount(DF_TermPtr tmPtr) //universe count +{ + return ((DF_ConstTerm*)tmPtr)->data.nameAndUC.univCount; +} +int DF_constTabIndex(DF_TermPtr tmPtr) //table index +{ + return ((DF_ConstTerm*)tmPtr)->data.nameAndUC.symTabIndex; +} +//constants with type associations +DF_TypePtr DF_constType(DF_TermPtr tmPtr) //type env +{ + return ((DF_TConstTerm*)tmPtr)->typeEnv; +} +//integer +long DF_intValue(DF_TermPtr tmPtr) //integer value +{ + return ((DF_IntTerm*)tmPtr)->value; +} +//float +float DF_floatValue(DF_TermPtr tmPtr) //float value +{ + return ((DF_FloatTerm*)tmPtr)->value; +} +//string +MCSTR_Str DF_strValue(DF_TermPtr tmPtr) //string value +{ + return (MCSTR_Str)(((MemPtr)(((DF_StrTerm*)tmPtr)->value)) + + DF_STRDATA_HEAD_SIZE); +} +DF_StrDataPtr DF_strData(DF_TermPtr tmPtr) //string data field +{ + return ((DF_StrTerm*)tmPtr)->value; +} +MCSTR_Str DF_strDataValue(DF_StrDataPtr tmPtr) //acc str value from data fd +{ + return (MCSTR_Str)(((MemPtr)tmPtr) + DF_STRDATA_HEAD_SIZE); +} + +//stream TEMP +WordPtr DF_streamTabIndex(DF_TermPtr tmPtr) //stream table index +{ + return ((DF_StreamTerm*)tmPtr)->index; +} +//de Bruijn index +int DF_bvIndex(DF_TermPtr tmPtr) //de Bruijn index +{ + return ((DF_BVTerm*)tmPtr)->index; +} +//reference +DF_TermPtr DF_refTarget(DF_TermPtr tmPtr) //target +{ + return ((DF_RefTerm*)tmPtr)->target; +} +//list cons +DF_TermPtr DF_consArgs(DF_TermPtr tmPtr) //arg vector +{ + return ((DF_ConsTerm*)tmPtr)->args; +} +//abstraction +int DF_lamNumAbs(DF_TermPtr tmPtr) //embedding level +{ + return ((DF_LamTerm*)tmPtr)->numOfLams; +} +DF_TermPtr DF_lamBody(DF_TermPtr tmPtr) //abstraction body +{ + return ((DF_LamTerm*)tmPtr)->body; +} +//application +int DF_appArity(DF_TermPtr tmPtr) //arity +{ + return ((DF_AppTerm*)tmPtr)->arity; +} +DF_TermPtr DF_appFunc(DF_TermPtr tmPtr) //functor +{ + return ((DF_AppTerm*)tmPtr)->functor; +} +DF_TermPtr DF_appArgs(DF_TermPtr tmPtr) //arg vector +{ + return ((DF_AppTerm*)tmPtr)->args; +} +//suspension +int DF_suspOL(DF_TermPtr tmPtr) //ol +{ + return ((DF_SuspTerm*)tmPtr)->ol; +} +int DF_suspNL(DF_TermPtr tmPtr) //nl +{ + return ((DF_SuspTerm*)tmPtr)->nl; +} +DF_TermPtr DF_suspTermSkel(DF_TermPtr tmPtr) //term skeleton +{ + return ((DF_SuspTerm*)tmPtr)->termSkel; +} +DF_EnvPtr DF_suspEnv(DF_TermPtr tmPtr) //environment list +{ + return ((DF_SuspTerm*)tmPtr)->envList; +} + +//environment item (dummy/pair) +DF_EnvPtr DF_envListRest(DF_EnvPtr envPtr) //next env item +{ + return envPtr->rest; +} +DF_EnvPtr DF_envListNth(DF_EnvPtr envPtr, int n) //nth item +{ + int i; + for (i=n; (i!=1); i--) envPtr = envPtr -> rest; + return envPtr; +} +int DF_envIndex(DF_EnvPtr envPtr) //l in @l or (t,l) +{ + return envPtr -> embedLevel; +} +//pair environment item +DF_TermPtr DF_envPairTerm(DF_EnvPtr envPtr) //t in (t,l) +{ + return ((DF_PairEnv*)envPtr) -> term; +} + +/* TERM CONSTRUCTION */ +void DF_copyAtomic(DF_TermPtr src, MemPtr dest) //copy atomic +{ + *((DF_TermPtr)dest) = *src; +} +void DF_copyApp(DF_TermPtr src, MemPtr dest) //copy application +{ + *((DF_AppTerm*)dest) = *((DF_AppTerm*)src); +} +void DF_copySusp(DF_TermPtr src, MemPtr dest) //copy suspension +{ + *((DF_SuspTerm*)dest) = *((DF_SuspTerm*)src); +} +void DF_mkVar(MemPtr loc, int uc) //unbound variable +{ + ((DF_VarTerm*)loc) -> tag.categoryTag = DF_TM_TAG_VAR; + ((DF_VarTerm*)loc) -> univCount = uc; +} +void DF_mkBV(MemPtr loc, int ind) //de Bruijn index +{ + ((DF_BVTerm*)loc) -> tag.categoryTag = DF_TM_TAG_BVAR; + ((DF_BVTerm*)loc) -> index = ind; +} +void DF_mkConst(MemPtr loc, int uc, int ind) //const +{ + ((DF_ConstTerm*)loc) -> tag.categoryTag = DF_TM_TAG_CONST; + ((DF_ConstTerm*)loc) -> withType = FALSE; + (((DF_ConstTerm*)loc) -> data).nameAndUC.univCount = uc; + (((DF_ConstTerm*)loc) -> data).nameAndUC.symTabIndex = ind; +} +void DF_mkTConst(MemPtr loc, int uc, int ind, DF_TypePtr typeEnv) + //const with type association +{ + ((DF_TConstTerm*)loc) -> tag.categoryTag = DF_TM_TAG_CONST; + ((DF_TConstTerm*)loc) -> withType = TRUE; + (((DF_TConstTerm*)loc) -> data).nameAndUC.univCount = uc; + (((DF_TConstTerm*)loc) -> data).nameAndUC.symTabIndex = ind; + ((DF_TConstTerm*)loc) -> typeEnv = typeEnv; +} +void DF_mkInt(MemPtr loc, long value) //int +{ + ((DF_IntTerm*)loc) -> tag.categoryTag = DF_TM_TAG_INT; + ((DF_IntTerm*)loc) -> value = value; +} +void DF_mkFloat(MemPtr loc, float value) //float +{ + ((DF_FloatTerm*)loc) -> tag.categoryTag = DF_TM_TAG_FLOAT; + ((DF_FloatTerm*)loc) -> value = value; +} +void DF_mkStr(MemPtr loc, DF_StrDataPtr data) //string +{ + ((DF_StrTerm*)loc) -> tag.categoryTag = DF_TM_TAG_STR; + ((DF_StrTerm*)loc) -> value = data; +} +void DF_mkStrDataHead(MemPtr loc) //string data head +{ + ((DF_StrDataPtr)loc) -> tag.categoryTag = DF_TM_TAG_STRBODY; +} + +void DF_mkStream(MemPtr loc, WordPtr ind) //stream +{ + ((DF_StreamTerm*)loc) -> tag.categoryTag = DF_TM_TAG_STREAM; + ((DF_StreamTerm*)loc) -> index = ind; +} +void DF_setStreamInd(DF_TermPtr tm, WordPtr ind) //update stream ind +{ + ((DF_StreamTerm*)tm) -> index = ind; +} +void DF_mkNil(MemPtr loc) //nil +{ + ((DF_NilTerm*)loc) -> tag.categoryTag = DF_TM_TAG_NIL; +} +void DF_mkRef(MemPtr loc, DF_TermPtr target) //reference +{ + ((DF_RefTerm*)loc) -> tag.categoryTag = DF_TM_TAG_REF; + ((DF_RefTerm*)loc) -> target = target; +} +void DF_mkCons(MemPtr loc, DF_TermPtr args) //cons +{ + ((DF_ConsTerm*)loc) -> tag.categoryTag = DF_TM_TAG_CONS; + ((DF_ConsTerm*)loc) -> args = args; +} +void DF_mkLam(MemPtr loc, int n, DF_TermPtr body) //abstraction +{ + ((DF_LamTerm*)loc) -> tag.categoryTag = DF_TM_TAG_LAM; + ((DF_LamTerm*)loc) -> numOfLams = n; + ((DF_LamTerm*)loc) -> body = body; +} +void DF_mkApp(MemPtr loc, int n, DF_TermPtr func, DF_TermPtr args) +{ //application + ((DF_AppTerm*)loc) -> tag.categoryTag = DF_TM_TAG_APP; + ((DF_AppTerm*)loc) -> arity = n; + ((DF_AppTerm*)loc) -> functor = func; + ((DF_AppTerm*)loc) -> args = args; +} +void DF_mkSusp(MemPtr loc, int ol, int nl, DF_TermPtr tmPtr, DF_EnvPtr env) + //suspension +{ + ((DF_SuspTerm*)loc) -> tag.categoryTag = DF_TM_TAG_SUSP; + ((DF_SuspTerm*)loc) -> ol = ol; + ((DF_SuspTerm*)loc) -> nl = nl; + ((DF_SuspTerm*)loc) -> termSkel = tmPtr; + ((DF_SuspTerm*)loc) -> envList = env; +} + +void DF_mkDummyEnv(MemPtr loc, int l, DF_EnvPtr rest) //@l env item +{ + ((DF_DummyEnv*)loc) -> tag.categoryTag = DF_ENV_TAG_DUMMY; + ((DF_DummyEnv*)loc) -> embedLevel = l; + ((DF_DummyEnv*)loc) -> rest = rest; +} +void DF_mkPairEnv(MemPtr loc, int l, DF_TermPtr t, DF_EnvPtr rest) +{ + // (t, l) env item + ((DF_PairEnv*)loc) -> tag.categoryTag = DF_ENV_TAG_PAIR; + ((DF_PairEnv*)loc) -> embedLevel = l; + ((DF_PairEnv*)loc) -> rest = rest; + ((DF_PairEnv*)loc) -> term = t; +} + + +/* TERM MODIFICATION */ +void DF_modVarUC(DF_TermPtr vPtr, int uc) +{ + ((DF_VarTerm*)vPtr) -> univCount = uc; +} + + +/* (NON_TRIVIAL) TERM COMPARISON */ +Boolean DF_sameConsts(DF_TermPtr const1, DF_TermPtr const2) //same constant? +{ + return (((DF_ConstTerm*)const1)->data.value == + ((DF_ConstTerm*)const2)->data.value); +} +Boolean DF_sameStrs(DF_TermPtr str1, DF_TermPtr str2) //same string? +{ + if (str1 == str2) return TRUE; + else if (((DF_StrTerm*)str1)->value == + ((DF_StrTerm*)str2)->value) return TRUE; //compare data fd addr + //compare literals + return MCSTR_sameStrs( + (MCSTR_Str)(((MemPtr)(((DF_StrTerm*)str1)->value)) + + DF_STRDATA_HEAD_SIZE), + (MCSTR_Str)(((MemPtr)(((DF_StrTerm*)str2)->value)) + + DF_STRDATA_HEAD_SIZE)); + +} +Boolean DF_sameStrData(DF_TermPtr tmPtr, DF_StrDataPtr strData) +{ + if (((DF_StrTerm*)tmPtr) -> value == strData) return TRUE; //compare addr + return MCSTR_sameStrs( + (MCSTR_Str)(((MemPtr)(((DF_StrTerm*)tmPtr)->value)) + + DF_STRDATA_HEAD_SIZE), + (MCSTR_Str)(((MemPtr)strData) + DF_STRDATA_HEAD_SIZE)); +} + +/********************************************************************/ +/* */ +/* DISAGREEMENT SET REPRESENTATION */ +/* */ +/* A double linked list */ +/********************************************************************/ + +//create a new node at the given location +void DF_mkDisPair(MemPtr loc, DF_DisPairPtr next, DF_TermPtr first, + DF_TermPtr second) +{ + ((DF_DisPairPtr)(loc)) -> tag.categoryTag = DF_DISPAIR; + ((DF_DisPairPtr)(loc)) -> next = next; + ((DF_DisPairPtr)(loc)) -> firstTerm = first; + ((DF_DisPairPtr)(loc)) -> secondTerm = second; +} + +//decomposition +DF_DisPairPtr DF_disPairNext(DF_DisPairPtr disPtr){return disPtr -> next; } +DF_TermPtr DF_disPairFirstTerm(DF_DisPairPtr disPtr) +{ + return disPtr -> firstTerm; +} +DF_TermPtr DF_disPairSecondTerm(DF_DisPairPtr disPtr) +{ + return disPtr -> secondTerm; +} + +//whether a given disagreement set is empty +Boolean DF_isEmpDisSet(DF_DisPairPtr disPtr) +{ + return (disPtr == DF_EMPTY_DIS_SET); +} + +Boolean DF_isNEmpDisSet(DF_DisPairPtr disPtr) +{ + return (disPtr != DF_EMPTY_DIS_SET); +} + + +#endif //DATAFORMATS_C diff --git a/src/runtime/c/teyjus/simulator/dataformats.h b/src/runtime/c/teyjus/simulator/dataformats.h new file mode 100644 index 000000000..3905cd8c2 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/dataformats.h @@ -0,0 +1,417 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File dataformat.h. */ +/* The header file identifies the low-level representation of data objects */ +/* that are manipulated by the machine, through various structure types. */ +/****************************************************************************/ +#ifndef DATAFORMATS_H +#define DATAFORMATS_H + +#include <limits.h> // to be removed +#include <stdlib.h> +//#include <math.h> +#include "mctypes.h" +#include "mcstring.h" + +/********************************************************************/ +/* DATA TAG FIELD IN TYPES AND TERMS */ +/********************************************************************/ + +/* The first byte is assumed to contain a type or term category tag, + and the second is to be used for marking in garbage collection */ +typedef struct +{ + Byte categoryTag; + Byte mark; //to be used in garbage collection +} DF_Tag; + +/* The tags of heap items */ +typedef enum +{ + //type categories + DF_TY_TAG_SORT = 0, //sort + DF_TY_TAG_REF, //reference + DF_TY_TAG_SKVAR, //skeleton variable + DF_TY_TAG_ARROW, //type arrow + DF_TY_TAG_STR, //type structure + DF_TY_TAG_FUNC, //functor of type structure + + //term categories + DF_TM_TAG_VAR = 6, // existential variables + DF_TM_TAG_CONST, // constants + DF_TM_TAG_INT, // integers + DF_TM_TAG_FLOAT, // floats + DF_TM_TAG_NIL, // empty lists + DF_TM_TAG_STR, // strings + DF_TM_TAG_STREAM, // streams + DF_TM_TAG_BVAR, // lambda bound variables (de Bruijn index) + // -- atoms above + DF_TM_TAG_REF, // references + // -- complex terms below + DF_TM_TAG_CONS, // list constructors + DF_TM_TAG_LAM, // abstractions + DF_TM_TAG_APP, // applications + DF_TM_TAG_SUSP, // suspensions + + DF_TM_TAG_STRBODY = 19, // string body + + //suspension environment items + DF_ENV_TAG_DUMMY = 20, //dummy environment + DF_ENV_TAG_PAIR, //pair environment + + //disagreement pair + DF_DISPAIR = 22 +} DF_HeapDataCategory; + + +/********************************************************************/ +/* */ +/* TYPE REPRESENTATION */ +/* */ +/********************************************************************/ + +/********************************************************************/ +/* Only generic types are visible from outside. */ +/* The "public" information for each specific type category is their*/ +/* sizes. Their structure declarations are hidden in dataformat.c. */ +/* Construction, recognization and decomposition of types should be */ +/* performed through interface functions with declarations present */ +/* in this file. */ +/********************************************************************/ + +/* +//type categories +enum DF_TypeCategory +{ + DF_TY_TAG_SORT, //sort + DF_TY_TAG_REF, //reference + DF_TY_TAG_SKVAR, //skeleton variable + DF_TY_TAG_ARROW, //type arrow + DF_TY_TAG_STR //type structure +}; +*/ + +//generic type (head) for every category +typedef struct +{ + DF_Tag tag; /* the common field for every type (head); can + be any one of enum TypeCategory. + rely on struct alignment */ + Word dummy; /* a place holder which enforces the size of the + generic term to be 2 words. */ +} DF_Type; + +typedef DF_Type *DF_TypePtr; //type pointer + +//sizes of different type items +#define DF_TY_ATOMIC_SIZE 2 //atomic size + +//attributes of special type constructors +#define DF_TY_ARROW_ARITY 2 //arity of type arrow + + +/******************************************************************/ +/* Interface functions */ +/******************************************************************/ + +/* TYPE DEREFERENCE */ +DF_TypePtr DF_typeDeref(DF_TypePtr); + +/* TYPE RECOGNITION */ +Boolean DF_isSortType(DF_TypePtr); // is sort? +Boolean DF_isRefType(DF_TypePtr); // is reference? (including free var) +Boolean DF_isFreeVarType(DF_TypePtr); // is free var? +Boolean DF_isSkelVarType(DF_TypePtr); // is skeleton var? +Boolean DF_isArrowType(DF_TypePtr); // is type arrow? +Boolean DF_isStrType(DF_TypePtr); // is type structure? + +/* TYPE DECOMPOSITION */ +int DF_typeTag(DF_TypePtr); //generic type +int DF_typeKindTabIndex(DF_TypePtr); //sorts +int DF_typeSkelVarIndex(DF_TypePtr); //skel var +DF_TypePtr DF_typeRefTarget(DF_TypePtr); //reference +DF_TypePtr DF_typeArrowArgs(DF_TypePtr); //arrows +DF_TypePtr DF_typeStrFuncAndArgs(DF_TypePtr); //structures +int DF_typeStrFuncInd(DF_TypePtr); +int DF_typeStrFuncArity(DF_TypePtr); +DF_TypePtr DF_typeStrArgs(DF_TypePtr); + +/* TYPE CONSTRUCTION */ +void DF_copyAtomicType(DF_TypePtr src, MemPtr dest); +void DF_mkSortType(MemPtr loc, int ind); +void DF_mkRefType(MemPtr loc, DF_TypePtr target); +void DF_mkFreeVarType(MemPtr loc); +void DF_mkSkelVarType(MemPtr loc, int offset); +void DF_mkArrowType(MemPtr loc, DF_TypePtr args); +void DF_mkStrType(MemPtr loc, DF_TypePtr funcAndArgs); +void DF_mkStrFuncType(MemPtr loc, int ind, int n); + + +/********************************************************************/ +/* */ +/* TERM REPRESENTATION */ +/* */ +/********************************************************************/ + +/********************************************************************/ +/* Only generic terms (environment items) are visible from outside. */ +/* The "public" information for each specific term category is their*/ +/* sizes. Their structure declarations are hidden in dataformat.c. */ +/* Construction, recognization and decomposition of terms should be */ +/* performed through interface functions with declarations present */ +/* in this file. */ +/********************************************************************/ + +/* +//term categories +enum DF_TermCategory +{ + DF_TM_TAG_VAR, // existential variables + DF_TM_TAG_CONST, // constants + DF_TM_TAG_INT, // integers + DF_TM_TAG_FLOAT, // floats + DF_TM_TAG_NIL, // empty lists + DF_TM_TAG_STR, // strings + DF_TM_TAG_STREAM, // streams + DF_TM_TAG_BVAR, // lambda bound variables (de Bruijn index) + // -- atoms above + DF_TM_TAG_REF, // references + // -- complex terms below + DF_TM_TAG_CONS, // list constructors + DF_TM_TAG_LAM, // abstractions + DF_TM_TAG_APP, // applications + DF_TM_TAG_SUSP // suspensions +}; +*/ + +// a generic term (head) for every category +typedef struct +{ + DF_Tag tag; /* the common field for every term (head); can + be any one of enum TermCategory. + rely on struct alignment */ + Word dummy; /* a place holder which enforces the size of the + generic term to be 2 words. */ +} DF_Term; + +typedef DF_Term *DF_TermPtr; //term pointer + +//sizes of different term items +#define DF_TM_ATOMIC_SIZE 2 // atomic size +#define DF_TM_TCONST_SIZE 3 // type associated constant (config set) +#define DF_TM_APP_SIZE 3 // application head +#define DF_TM_LAM_SIZE 2 // abstraction +#define DF_TM_CONS_SIZE 2 // cons +#define DF_TM_SUSP_SIZE 4 // suspension (config set) + +// attributes of some special constants +#define DF_CONS_ARITY 2 //arity of cons + +// head of string body (a tag word should be followed by encoding of literals) +typedef union +{ + DF_Tag tag; + Word dummy; +} DF_StrData; + +typedef DF_StrData *DF_StrDataPtr; + +//#define DF_STRDATA_HEAD_SIZE (int)ceil((double)sizeof(DF_StrData)/WORD_SIZE) +#define DF_STRDATA_HEAD_SIZE 2 + +//a generic environment item in suspension +typedef struct DF_env +{ + //Boolean isDummy; + DF_Tag tag; + TwoBytes embedLevel; + struct DF_env *rest; //the tail of the list +} DF_Env; + +typedef DF_Env *DF_EnvPtr; + +// empty environment list +#define DF_EMPTY_ENV NULL + +//sizes of different environment items +#define DF_ENV_DUMMY_SIZE 2 // dummy environment item +#define DF_ENV_PAIR_SIZE 3 // pair environment item + +//limits (to be set by configuration) +#define DF_MAX_BV_IND USHRT_MAX //max db ind (embedding level) +#define DF_TM_MAX_ARITY USHRT_MAX //max arity +#define DF_MAX_UNIVIND USHRT_MAX //max universe index + + +/******************************************************************/ +/* Interface functions */ +/******************************************************************/ + +/* DEREFERENCE */ +DF_TermPtr DF_termDeref(DF_TermPtr); // term dereference + +/* TERM RECOGNITION */ +Boolean DF_isAtomic(DF_TermPtr); //note ref is neither atomic nor complex +Boolean DF_isNAtomic(DF_TermPtr); +Boolean DF_isFV(DF_TermPtr); // is unbound variable? +Boolean DF_isConst(DF_TermPtr); // is constant (typed and untyped)? +Boolean DF_isTConst(DF_TermPtr); // is a type associated constant? + // Note we assume the arg is known to be const +Boolean DF_isInt(DF_TermPtr); // is integer? +Boolean DF_isFloat(DF_TermPtr); // is float? +Boolean DF_isNil(DF_TermPtr); // is list nil? +Boolean DF_isStr(DF_TermPtr); // is string? +Boolean DF_isBV(DF_TermPtr); // is de Bruijn index? +Boolean DF_isStream(DF_TermPtr); // is stream? +Boolean DF_isRef(DF_TermPtr); // is reference? +Boolean DF_isCons(DF_TermPtr); // is list cons? +Boolean DF_isLam(DF_TermPtr); // is abstraction? +Boolean DF_isApp(DF_TermPtr); // is application? +Boolean DF_isSusp(DF_TermPtr); // is suspension? + +Boolean DF_isEmpEnv(DF_EnvPtr); // is empty environment? +Boolean DF_isDummyEnv(DF_EnvPtr);// is dummy environment item? + +/* TERM DECOMPOSITION */ +//generic term +int DF_termTag(DF_TermPtr); // term category tag +//unbound variable +int DF_fvUnivCount(DF_TermPtr); // universe count +//constants (w/oc type associations) +int DF_constUnivCount(DF_TermPtr); // universe index +int DF_constTabIndex(DF_TermPtr); // symbol table index +//constants with type associations +DF_TypePtr DF_constType(DF_TermPtr); // type environment +//integer +long DF_intValue(DF_TermPtr); // integer value (long) +//float +float DF_floatValue(DF_TermPtr); // float value +//string +MCSTR_Str DF_strValue(DF_TermPtr); // string value +DF_StrDataPtr DF_strData(DF_TermPtr tmPtr); // string data field +MCSTR_Str DF_strDataValue(DF_StrDataPtr tmPtr); //acc str value from data fd +//stream +WordPtr DF_streamTabIndex(DF_TermPtr); // stream table index +//de Bruijn indices +int DF_bvIndex(DF_TermPtr); // de Bruijn index +//reference +DF_TermPtr DF_refTarget(DF_TermPtr); // target +//list cons +DF_TermPtr DF_consArgs(DF_TermPtr); // arg vector +//abstractions +int DF_lamNumAbs(DF_TermPtr); // embedding level +DF_TermPtr DF_lamBody(DF_TermPtr); // lambda body +//application +int DF_appArity(DF_TermPtr); // arity +DF_TermPtr DF_appFunc(DF_TermPtr); // functor +DF_TermPtr DF_appArgs(DF_TermPtr); // arg vector +//suspension +int DF_suspOL(DF_TermPtr); // ol +int DF_suspNL(DF_TermPtr); // nl +DF_TermPtr DF_suspTermSkel(DF_TermPtr); // term skel +DF_EnvPtr DF_suspEnv(DF_TermPtr); // environment list + +//environment item (dummy/pair) +DF_EnvPtr DF_envListRest(DF_EnvPtr); // next env item +DF_EnvPtr DF_envListNth(DF_EnvPtr, int); // the nth item +int DF_envIndex(DF_EnvPtr); // l in @l or (t,l) +//pair environment item +DF_TermPtr DF_envPairTerm(DF_EnvPtr); // t in (t,l) + + +/* TERM CONSTRUCTION */ +void DF_copyAtomic(DF_TermPtr src, MemPtr dest); //copy atomic +void DF_copyApp(DF_TermPtr src, MemPtr dest); //copy application +void DF_copySusp(DF_TermPtr src, MemPtr dest); //copy suspension +void DF_mkVar(MemPtr loc, int uc); //unbound variable +void DF_mkBV(MemPtr loc, int ind); //de Bruijn index +void DF_mkConst(MemPtr loc, int uc, int ind); //const +void DF_mkTConst(MemPtr loc, int uc, int ind, DF_TypePtr typeEnv); + //const with type association +void DF_mkInt(MemPtr loc, long value); //int +void DF_mkFloat(MemPtr loc, float value); //float +void DF_mkStr(MemPtr loc, DF_StrDataPtr data); //string +void DF_mkStrDataHead(MemPtr loc); //string data head +void DF_mkStream(MemPtr loc, WordPtr ind); //stream +void DF_setStreamInd(DF_TermPtr tm, WordPtr ind); //update index of a stream +void DF_mkNil(MemPtr loc); //nil +void DF_mkRef(MemPtr loc, DF_TermPtr target); //reference +void DF_mkCons(MemPtr loc, DF_TermPtr args); //cons +void DF_mkLam(MemPtr loc, int n, DF_TermPtr body); //abstraction +void DF_mkApp(MemPtr loc, int n, DF_TermPtr func, DF_TermPtr args); + //application +void DF_mkSusp(MemPtr loc, int ol, int nl, DF_TermPtr tp, DF_EnvPtr env); + //suspension +void DF_mkDummyEnv(MemPtr loc, int l, DF_EnvPtr rest); //@l env item +void DF_mkPairEnv(MemPtr loc, int l, DF_TermPtr t, DF_EnvPtr rest); + // (t, l) env item + +/* TERM MODIFICATION */ +void DF_modVarUC(DF_TermPtr vPtr, int uc); + +/* (NON_TRIVIAL) TERM COMPARISON */ +Boolean DF_sameConsts(DF_TermPtr const1, DF_TermPtr const2); //same const? +Boolean DF_sameStrs(DF_TermPtr str1, DF_TermPtr str2); //same string? +Boolean DF_sameStrData(DF_TermPtr tmPtr, DF_StrDataPtr strData); //same str? + +/********************************************************************/ +/* */ +/* DISAGREEMENT SET REPRESENTATION */ +/* */ +/* Linked list */ +/********************************************************************/ + +typedef struct DF_disPair //each node in the disagreement set +{ + DF_Tag tag; + struct DF_disPair *next; + DF_TermPtr firstTerm; + DF_TermPtr secondTerm; +} DF_DisPair; + +typedef DF_DisPair *DF_DisPairPtr; //pointer to a disagreement pair + +//note this arithmatic should in reality be performed in configuration +#define DF_DISPAIR_SIZE (int)ceil((double)sizeof(DF_DisPair)/WORD_SIZE) + +#define DF_EMPTY_DIS_SET NULL //empty disagreement set + +/******************************************************************/ +/* Interface functions */ +/******************************************************************/ + +//create a new node at the given location +void DF_mkDisPair(MemPtr loc, DF_DisPairPtr next, DF_TermPtr first, + DF_TermPtr second); + +//decomposition +DF_DisPairPtr DF_disPairNext(DF_DisPairPtr disPtr); +DF_TermPtr DF_disPairFirstTerm(DF_DisPairPtr disPtr); +DF_TermPtr DF_disPairSecondTerm(DF_DisPairPtr disPtr); + +//whether a given disagreement set is empty +Boolean DF_isEmpDisSet(DF_DisPairPtr disPtr); +Boolean DF_isNEmpDisSet(DF_DisPairPtr disPtr); + +#endif //DATAFORMATS_H + + diff --git a/src/runtime/c/teyjus/simulator/hnorm.c b/src/runtime/c/teyjus/simulator/hnorm.c new file mode 100644 index 000000000..7f84087cb --- /dev/null +++ b/src/runtime/c/teyjus/simulator/hnorm.c @@ -0,0 +1,1128 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File hnorm.c. */ +/* This file contains the head normalization routines. */ +/* These procedures are based on the suspension calculus, and the reduction */ +/* strategy with lazy reduction, lazy substitution and lazy heap */ +/* commitment is chosen. A SML realization of this process is described in */ +/* paper "Choices in Representation and Reduction Strategies for Lambda */ +/* Terms in Intersional Contexts". */ +/****************************************************************************/ + +#ifndef HNORM_C +#define HNORM_C + +#include <stdlib.h> +#include "dataformats.h" +#include "mctypes.h" +#include "hnorm.h" +#include "hnormlocal.h" +#include "abstmachine.h" +#include "../system/error.h" + +//for debugging: to be removed +#include <stdio.h> +#include "printterm.h" +#include "../system/stream.h" + +/*****************************************************************************/ +/* a global(to file hnorm.c) encoding of the explicit suspension environment*/ +/* and simple checking and updating functions on this environment */ +/*****************************************************************************/ +/* environment of the implicit suspension, which is initialized to empty*/ +static int ol, nl; +static DF_EnvPtr envlist; + +/* clean the environment to empty */ +static void HN_setEmptyEnv() { ol = 0; nl = 0; envlist = DF_EMPTY_ENV; } +/* set the environment according to given values */ +static void HN_setEnv(int o, int n, DF_EnvPtr e) +{ ol = o; nl = n; envlist = e; } +/* is an empty environment? */ +static Boolean HN_isEmptyEnv() { return ((ol == 0) && (nl == 0)); } + +/****************************************************************************/ +/* Functions for creating (modifying) the environment list in the suspension*/ +/* environment defined by ol, nl and envlist according to their current */ +/* values. */ +/****************************************************************************/ + +/* Add n (n > 0) dummy environment items to the front of the current + environment list: @(nl+n-1) :: ... :: @nl :: envlist. + New dummy env items are created on the current heap top. +*/ +static DF_EnvPtr HN_addNDummyEnv(int n) +{ + int i; + DF_EnvPtr last = envlist, current; + + AM_heapError(AM_hreg + n * DF_ENV_DUMMY_SIZE); + for (i = 0; i < n; i++){ + current = (DF_EnvPtr)AM_hreg; + DF_mkDummyEnv(AM_hreg, nl+i, last); + AM_hreg += DF_ENV_DUMMY_SIZE; + last = current; + } + return current; +} + +/* Add n (n > 0) pair environment items to the front of the current + environment list as the following: + ([|an,myol,mynl,myenv|],nl):: ... ::([|ai,myol,mynl,myenv|],nl)::envlist, + where ai is the ith argument in the vector referred to by argvec. + Note if ai is an atomic term, the suspension over it is eagerly evaluated. + */ +static DF_EnvPtr HN_addNPair(DF_TermPtr argvec, int myol, int mynl, + DF_EnvPtr myenv, int n) +{ + int i; + DF_EnvPtr last = envlist, current; + MemPtr myEnvlist = AM_hreg; + MemPtr newhtop = AM_hreg + n * DF_ENV_PAIR_SIZE; + + AM_heapError(newhtop); + AM_hreg = newhtop; //spare space for n pair env items + for (i = 1; i<= n; i++) { + current = (DF_EnvPtr)myEnvlist; + DF_mkPairEnv(myEnvlist, nl, HNL_suspAsEnv(argvec,myol,mynl,myenv), + last); + myEnvlist += DF_ENV_PAIR_SIZE; + last = current; + argvec = (DF_TermPtr)(((MemPtr)argvec) + DF_TM_ATOMIC_SIZE); + } + return current; +} + +/* A specialized version of HN_addNPair when the incoming environment is + empty. + Now, n (n > 0) pair environment items are added to the front of the + current environment list as the following: + (an,0) :: ... :: (a1,0) :: envlist, where ai is the ith argument in the + vector referred to by argvec. + */ +static DF_EnvPtr HN_addNPairEmpEnv(DF_TermPtr argvec, int n) +{ + int i; + DF_EnvPtr last = envlist, current; + AM_heapError(AM_hreg + n * DF_ENV_PAIR_SIZE); + for (i = 1; i <= n; i++) { + current = (DF_EnvPtr)AM_hreg; + DF_mkPairEnv(AM_hreg, 0, argvec, last); + AM_hreg += DF_ENV_PAIR_SIZE; + last = current; + argvec = (DF_TermPtr)(((MemPtr)argvec) + DF_TM_ATOMIC_SIZE); + } + return current; +} + +/****************************************************************************/ +/* A function for pushing suspension over n abstractions following the rule */ +/* [|lam(n,body), ol, nl, envlist|] */ +/* -> lam(n, [|body, ol+n, nl+n, @(nl+n-1) :: ... :: @nl :: envlist |] */ +/* The result is committed on the current top of heap. */ +/* The top-level (implicit) suspension is given by the global variable */ +/* ol, nl, and envlist. */ +/* This function is used in HN_hnormSusp, HN_hnormSuspOCC and HN_lnormSusp. */ +/****************************************************************************/ +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; +} + +/****************************************************************************/ +/* functions for (weak) head normalizing terms of known categories */ +/*--------------------------------------------------------------------------*/ +/* General comments: */ +/* An implicit suspension is given by the global variables ol, nl and */ +/* envlist together with the first argument tmPtr to the sub-functions: */ +/* [|tmPtr, ol, nl, envlist|] */ +/* The suspension environment could be empty in which case the term */ +/* being normalized is tmPtr itself. */ +/* The second argument of the sub-functions whnf is a flag indicating */ +/* whether a head normal form or a weak head normal form is being */ +/* computed. */ +/****************************************************************************/ +static DF_TermPtr HN_hnormDispatch(DF_TermPtr tmPtr, Boolean whnf); + +/* (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; +} + + +/* (weak) head normalize an abstraction or implicit suspension with term + skeleton as an abstraction. + If an implicit suspension is weak head normalized, the suspension itself + is returned. The descendant of this suspension over its abstraction skeleton + is performed in the subsequent app case on a fly. + Note that this is the only case that hnorm termniates with a non-empty + environment. +*/ +static DF_TermPtr HN_hnormLam(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_hnormDispatch(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_hnormDispatch(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; +} + +/* (weak) head normalize cons or implicit suspension over cons */ +static DF_TermPtr HN_hnormCons(DF_TermPtr consPtr, Boolean whnf) +{ + DF_TermPtr argvec = DF_consArgs(consPtr), + rtPtr; //term pointer to be returned + if (HN_isEmptyEnv()){ + AM_argVec = argvec; + AM_numArgs = DF_CONS_ARITY; + rtPtr = consPtr; + } else { + Boolean changed = HNL_makeConsArgvec(argvec, ol, nl, envlist); + if (changed){ //new argvec is built because of pushing susp + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushCons(AM_argVec); + } else rtPtr = consPtr; + HN_setEmptyEnv(); + } + HNL_setRegsCons(rtPtr); + return rtPtr; +} + +/* (weak) head normalize application or implicit suspension over + application. The old application term is destructively changed into + a reference to its head normal form or its weak head normal form if + the weak heap normal form is not an implicit suspension (in which + case the term skeleton must be an abstraction.). +*/ +static DF_TermPtr HN_hnormApp(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_hnormDispatch(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_hnormDispatch(lamBody, whnf); + arity = 0; + } else if (arity > numAbsInFun) { + funPtr = HN_hnormDispatch(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_hnormDispatch(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 = HNL_makeArgvecEmpEnv(argvec, arity); + else changed = HNL_makeArgvec(argvec,arity,myol,mynl,myenvlist); + + if ((!changed) && (arity == myarity) && (funPtr == oldFunPtr)) { + 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; +} + +/* (weak) head normalize (explicit) suspension or implicit suspension + with a suspension term skeletion. The explicit suspension is destructivly + changed to its head normal form or weak head normal form in case + that the whn is not an implicit susp itself (in which case the term + skeleton must be an abstraction). +*/ +static DF_TermPtr HN_hnormSusp(DF_TermPtr suspPtr, Boolean whnf) +{ + DF_TermPtr rtPtr; //term pointer to be returned + int myol, mynl ; // for book keeping the env of implicit susp + DF_EnvPtr myenvlist; + Boolean emptyTopEnv = HN_isEmptyEnv(); + + if (!emptyTopEnv){ + myol = ol; mynl = nl; myenvlist = envlist; + } + //first (weak) head normalize the explicit susp + HN_setEnv(DF_suspOL(suspPtr), DF_suspNL(suspPtr), DF_suspEnv(suspPtr)); + rtPtr = HN_hnormDispatch(DF_suspTermSkel(suspPtr), whnf); + if (emptyTopEnv) { + if (HN_isEmptyEnv()) { + HNL_updateToRef(suspPtr, rtPtr); + } + } else { // ! emptyTopEnv + if (HN_isEmptyEnv()) HNL_updateToRef(suspPtr, rtPtr); + else rtPtr = HN_pushSuspOverLam(rtPtr); + //(weak) head norm the top-level (imp) susp + HN_setEnv(myol, mynl, myenvlist); + /* note that AM_numabs, AM_numargs and AM_argvec have to be + re-initialized, because the (w)hnf of the inner suspension + is to be traversed again. */ + HNL_initRegs(); + rtPtr = HN_hnormDispatch(rtPtr, whnf); + } + return rtPtr; +} + +/****************************************************************************/ +/* Dispatching on various term categories. */ +/****************************************************************************/ +static DF_TermPtr HN_hnormDispatch(DF_TermPtr tmPtr, Boolean whnf) +{ + restart: + 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_hnormBV(tmPtr, whnf); } + case DF_TM_TAG_CONS: { return HN_hnormCons(tmPtr, whnf); } + case DF_TM_TAG_LAM: { return HN_hnormLam(tmPtr, whnf); } + case DF_TM_TAG_APP: { return HN_hnormApp(tmPtr, whnf); } + case DF_TM_TAG_SUSP: { return HN_hnormSusp(tmPtr, whnf); } + case DF_TM_TAG_REF: { tmPtr = DF_termDeref(tmPtr); goto restart;} + } + + //Impossible to reach this point. + return NULL; +} + +/****************************************************************************/ +/* the interface routine for head normalization */ +/****************************************************************************/ +void HN_hnorm(DF_TermPtr tmPtr) +{ + HN_setEmptyEnv(); + HNL_initRegs(); + HN_hnormDispatch(DF_termDeref(tmPtr), FALSE); +} + + +/****************************************************************************/ +/* HEAD (WEAK HEAD) NORMALIZATION WITH OCCURS CHECK */ +/*--------------------------------------------------------------------------*/ +/* General comments: */ +/* Checkings are added when the (dereference of) term to be normlized is */ +/* an application or a cons. If the term is an application, checking is */ +/* made on whether the application is currently referred */ +/* to by register AM_vbbreg, and this checking is added in the APP case */ +/* of the dispatch function. If the term is a cons, checking is made on */ +/* whether its argument vector is currently referred to by the register */ +/* AM_vbbreg, and this checking is added in sub-function HN_hnormConsOcc. */ +/****************************************************************************/ +static DF_TermPtr HN_hnormDispatchOcc(DF_TermPtr tmPtr, Boolean whnf); + +/****************************************************************************/ +/* functions for (weak) head normalizing terms with occurs-check */ +/* of known categories */ +/****************************************************************************/ + +/* (weak) head normalize bound variable or implicit suspension with + bound variable as term skeleton. */ +static DF_TermPtr HN_hnormBVOcc(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_hnormDispatchOcc(DF_suspTermSkel(tmPtr), whnf); + } else { + HN_setEnv(0, nladj, DF_EMPTY_ENV); + rtPtr = HN_hnormDispatchOcc(tmPtr, whnf); + } + } //pair env + } // i<= ol + } //non-empty env + return rtPtr; +} + +/* (weak) head normalize an abstraction or implicit suspension with term + skeleton as an abstraction. */ +static DF_TermPtr HN_hnormLamOcc(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_hnormDispatchOcc(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_hnormDispatchOcc(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; +} + +/* (weak) head normalize cons or implicit suspension over cons. + Note checking on whether the argument vector of the cons term is referred to + by the register AM_vbbreg is made. +*/ +static DF_TermPtr HN_hnormConsOcc(DF_TermPtr consPtr, Boolean whnf) +{ + DF_TermPtr argvec = DF_consArgs(consPtr), + rtPtr; //term pointer to be returned + if (AM_vbbreg == argvec) EM_THROW(EM_FAIL); + if (HN_isEmptyEnv()){ + AM_argVec = argvec; + AM_numArgs = DF_CONS_ARITY; + rtPtr = consPtr; + } else { + Boolean changed = HNL_makeConsArgvec(argvec, ol, nl, envlist); + if (changed){ //new argvec is built because of pushing susp + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushCons(AM_argVec); + } else rtPtr = consPtr; + HN_setEmptyEnv(); + } + HNL_setRegsCons(rtPtr); + return rtPtr; +} + +/* (weak) head normalize application or implicit suspension over + application. +*/ +static DF_TermPtr HN_hnormAppOcc(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_hnormDispatchOcc(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_hnormDispatchOcc(lamBody, whnf); + arity = 0; + } else if (arity > numAbsInFun) { + funPtr = HN_hnormDispatchOcc(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_hnormDispatchOcc(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 = HNL_makeArgvecEmpEnv(argvec, arity); + else changed = HNL_makeArgvec(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; +} + +/* (weak) head normalize (explicit) suspension or implicit suspension + with a suspension term skeletion. +*/ +static DF_TermPtr HN_hnormSuspOcc(DF_TermPtr suspPtr, Boolean whnf) +{ + DF_TermPtr rtPtr; //term pointer to be returned + int myol, mynl ; // for book keeping the env of implicit susp + DF_EnvPtr myenvlist; + Boolean emptyTopEnv = HN_isEmptyEnv(); + + if (!emptyTopEnv){ + myol = ol; mynl = nl; myenvlist = envlist; + } + //first (weak) head normalize the explicit susp + HN_setEnv(DF_suspOL(suspPtr), DF_suspNL(suspPtr), DF_suspEnv(suspPtr)); + rtPtr = HN_hnormDispatchOcc(DF_suspTermSkel(suspPtr), whnf); + + if (emptyTopEnv) { + if (HN_isEmptyEnv()) HNL_updateToRef(suspPtr, rtPtr); + } else { // ! emptyTopEnv + if (HN_isEmptyEnv()) HNL_updateToRef(suspPtr, rtPtr); + else rtPtr = HN_pushSuspOverLam(rtPtr); + //(weak) head norm the top-level (imp) susp + HN_setEnv(myol, mynl, myenvlist); + /* note that AM_numabs, AM_numargs and AM_argvec have to be + re-initialized, because the (w)hnf of the inner suspension + is to be traversed again. */ + HNL_initRegs(); + rtPtr = HN_hnormDispatchOcc(rtPtr, whnf); + } + return rtPtr; +} + +/****************************************************************************/ +/* Dispatching on various term categories. */ +/****************************************************************************/ +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; +} + +/****************************************************************************/ +/* the interface routine for head normalization */ +/****************************************************************************/ +void HN_hnormOcc(DF_TermPtr tmPtr) +{ + HN_setEmptyEnv(); + HNL_initRegs(); + tmPtr = HN_hnormDispatchOcc(DF_termDeref(tmPtr), FALSE); +} + + +/****************************************************************************/ +/* FULL NORMALIZATION */ +/****************************************************************************/ +static DF_TermPtr HN_lnormDispatch(DF_TermPtr, Boolean whnf); + +/****************************************************************************/ +/* Functions for creating argument vectors in full normalization */ +/*--------------------------------------------------------------------------*/ +/* General comments: */ +/* This is the counter part of HNL_makeArgvec functions (hnormlocal.c) */ +/* in the full normalization process for arranging arguments of */ +/* applications (cons) when their "heads" are in (head) normal forms. */ +/* Nested applications are unfolded. */ +/* The difference is that HN_lnormDispatch is invoked on each argument */ +/* to fully normalize it. */ +/****************************************************************************/ + +/* Fully normalize (implicit) suspensions [| ai, myol, mynl, myenv |], + where ai's are those in the vector referred to by argvec with size arity, + and myol, mynl, myenv are given by other parameters. + Note that a new argument vector is always created. +*/ +static void HN_lnormArgvec(DF_TermPtr argvec, int arity, int myol, int mynl, + DF_EnvPtr myenv) +{ + int i; + //book keeping relevant regs. + DF_TermPtr head = AM_head, myArgvec = AM_argVec; + int numAbs = AM_numAbs, numArgs = AM_numArgs; + Flag rigFlag = AM_rigFlag, consFlag = AM_consFlag; + + MemPtr newArgvec = AM_hreg; //new argvec + MemPtr newhtop = newArgvec + arity * DF_TM_ATOMIC_SIZE; + AM_heapError(newhtop); + AM_hreg = newhtop; //arrange heap top for creating terms in norm args + + for (i = 1; i <= arity; i++){ + HN_setEnv(myol, mynl, myenv); //imp susp environment + HNL_initRegs(); + DF_mkRef(newArgvec, HN_lnormDispatch(argvec, FALSE)); + newArgvec += DF_TM_ATOMIC_SIZE; + argvec = (DF_TermPtr)(((MemPtr)argvec)+DF_TM_ATOMIC_SIZE); + } + //reset registers + AM_head = head; AM_argVec = myArgvec; + AM_numAbs = numAbs; AM_numArgs = numArgs; + AM_rigFlag = rigFlag; AM_consFlag = consFlag; +} + +/* A specialized version of HN_lnormArgvec when the implicit suspension + over each argument in the vector is known to be empty. + Note that upon the return of HN_lnormDispatch, the argument has been + destructively updated to its normal form, which means the old argument + vector is always used. +*/ +static void HN_lnormArgvecEmpEnv(DF_TermPtr argvec, int arity) +{ + int i; + //book keeping relevant regs. + DF_TermPtr head = AM_head, myArgvec = AM_argVec; + int numAbs = AM_numAbs, numArgs = AM_numArgs; + Flag rigFlag = AM_rigFlag, consFlag = AM_consFlag; + + for (i = 1; i <= arity; i++){ + HNL_initRegs(); + HN_lnormDispatch(argvec, FALSE); + argvec = (DF_TermPtr)(((MemPtr)argvec) + DF_TM_ATOMIC_SIZE); + } + //reset registers + AM_head = head; AM_argVec = myArgvec; + AM_numAbs = numAbs; AM_numArgs = numArgs; + AM_rigFlag = rigFlag; AM_consFlag = consFlag; +} + +/* Create an argument vector for applications within a non-empty environment. + Actions are carried out in two steps: + First, nested applications are unfolded if arising. Second, the (implicit) + suspensions formed by each argument and given parameters are fully + normalized. + Note that a new argument vector is always created. +*/ +static Boolean HN_makeArgvecLnorm(DF_TermPtr argvec, int arity, int myol, + int mynl, DF_EnvPtr myenv) +{ + DF_TermPtr newArgvec = (DF_TermPtr)AM_hreg; //new argvec + int newArity; + + if (AM_numArgs != 0){ //unfold nested app first + MemPtr newhtop = AM_hreg + AM_numArgs * DF_TM_ATOMIC_SIZE; + AM_heapError(newhtop); + newArity = arity + AM_numArgs; + AM_arityError(newArity); + HNL_copyArgs(AM_argVec, AM_numArgs); //layout inner args + } else newArity = arity; + + //fully normalize arguments + HN_lnormArgvec(argvec, arity, myol, mynl, myenv); + AM_argVec = newArgvec; + AM_numArgs = newArity; + return TRUE; +} + +/* A specilized version of HN_makeArgvecLnorm when the enclosing environment + is known to be empty. Note that new argument vecoter is created + if nested applications were unfolded. Otherwise, the old is used. + Boolean values TRUE or FALSE is returned to inidicate which situation it is. +*/ +static Boolean HN_makeArgvecEmpEnvLnorm(DF_TermPtr argvec, int arity) +{ + HN_lnormArgvecEmpEnv(argvec, arity); //lnorm arguments + + if (AM_numArgs != 0){ //unfold nested app + int newArity = arity + AM_numArgs; + DF_TermPtr newArgvec = (DF_TermPtr)AM_hreg; //new argument vector + AM_arityError(newArity); + AM_heapError(((MemPtr)newArgvec + newArity * DF_TM_ATOMIC_SIZE)); + + HNL_copyArgs(AM_argVec, AM_numArgs); + HNL_copyArgs(argvec, arity); + + AM_argVec = newArgvec; + AM_numArgs = newArity; + return TRUE; + } else { + AM_argVec = argvec; + AM_numArgs = arity; + return FALSE; + } +} + +/****************************************************************************/ +/* functions for fully normalizing terms of known categories */ +/*--------------------------------------------------------------------------*/ +/* General comments: */ +/* */ +/* An implicit suspension is given by the global variables ol, nl and */ +/* envlist together with the first argument tmPtr to the sub-functions: */ +/* [|tmPtr, ol, nl, envlist|] */ +/* The suspension environment could be empty in which case the term */ +/* being normalized is tmPtr itself. */ +/* The second argument of the sub-functions whnf is a flag indicating */ +/* whether a head normal form or a weak head normal form is being */ +/* computed. */ +/****************************************************************************/ + +/* Fully normalize or weak head normalize bound variable or implicit + suspension with bound variable as term skeleton. + The actions carried out are the same as the counter part in the head + normalization proceee, except that HN_lnormDispatch is invoked as opposed + to HN_hnormDispatch when necessary. +*/ +static DF_TermPtr HN_lnormBV(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_lnormDispatch(DF_suspTermSkel(tmPtr), whnf); + } else { + HN_setEnv(0, nladj, DF_EMPTY_ENV); + rtPtr = HN_lnormDispatch(tmPtr, whnf); + } + } //pair env + } // i<= ol + } //non-empty env + return rtPtr; +} + +/* 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; +} + +/* Fully normalize or weak head normalize cons or implicit suspension over + cons. The difference from HN_hnormCons is that the arguments of the cons + are fully normalized. +*/ +static DF_TermPtr HN_lnormCons(DF_TermPtr consPtr, Boolean whnf) +{ + DF_TermPtr argvec = DF_consArgs(consPtr), + rtPtr; //term pointer to be returned + if (HN_isEmptyEnv()){ + HN_lnormArgvecEmpEnv(argvec, DF_CONS_ARITY); + AM_argVec = argvec; + AM_numArgs = DF_CONS_ARITY; + rtPtr = consPtr; + } else { + DF_TermPtr newArgvec = (DF_TermPtr)AM_hreg; //new argument vector + HN_lnormArgvec(argvec, DF_CONS_ARITY, ol, nl, envlist); + AM_argVec = newArgvec; + AM_numArgs = DF_CONS_ARITY; + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushCons(AM_argVec); + HN_setEmptyEnv(); + } + HNL_setRegsCons(rtPtr); + 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; +} + +/* Fuuly normlize or weak head normalize (explicit) suspension or implicit + suspension with a suspension term skeletion. The actions are the same + as those in HN_hnormSusp except that HN_lnormDispatch is used as opposed + to HN_hnormSusp with one exception: when the environment of the top-level + suspension is not empty, the inner suspension is head normalized + (HN_hnormDispatch). +*/ + +static DF_TermPtr HN_lnormSusp(DF_TermPtr suspPtr, Boolean whnf) +{ + DF_TermPtr rtPtr; //term pointer to be returned + int myol, mynl; // for book keeping the env of implicit susp + DF_EnvPtr myenvlist; + Boolean emptyTopEnv = HN_isEmptyEnv(); + + if (!emptyTopEnv) { + myol = ol; mynl = nl; myenvlist = envlist; + } + HN_setEnv(DF_suspOL(suspPtr), DF_suspNL(suspPtr), DF_suspEnv(suspPtr)); + + if (emptyTopEnv){ + rtPtr = HN_lnormDispatch(DF_suspTermSkel(suspPtr), whnf); + if (HN_isEmptyEnv()) HNL_updateToRef(suspPtr, rtPtr); + } else { //non-empty top-level env + rtPtr = HN_hnormDispatch(DF_suspTermSkel(suspPtr), whnf); + + if (HN_isEmptyEnv()) HNL_updateToRef(suspPtr, rtPtr); + else rtPtr = HN_pushSuspOverLam(rtPtr); + //fully normalize top-level susp + HN_setEnv(myol, mynl, myenvlist); + /* note that AM_numabs, AM_numargs and AM_argvec have to be + re-initialized, because the (w)hnf of the inner suspension + is to be traversed again. */ + HNL_initRegs(); + rtPtr = HN_lnormDispatch(rtPtr, whnf); + } + return rtPtr; +} + +/****************************************************************************/ +/* Dispatching on various term categories. */ +/****************************************************************************/ +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; +} + +/****************************************************************************/ +/* the interface routine for head normalization */ +/****************************************************************************/ +void HN_lnorm(DF_TermPtr tmPtr) +{ + HN_setEmptyEnv(); + HNL_initRegs(); + tmPtr = HN_lnormDispatch(DF_termDeref(tmPtr), FALSE); +} + +#endif //HNORM_C + + + + + + + + + + + diff --git a/src/runtime/c/teyjus/simulator/hnorm.h b/src/runtime/c/teyjus/simulator/hnorm.h new file mode 100644 index 000000000..d57a7349f --- /dev/null +++ b/src/runtime/c/teyjus/simulator/hnorm.h @@ -0,0 +1,42 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* File hnorm.h. */ +/* This header file identifies routines defined in hnorm.c that are */ +/* exported from there. */ +/****************************************************************************/ +#ifndef HNORM_H +#define HNORM_H + +#include "dataformats.h" + +/* head normalization of the term in the argument */ +void HN_hnorm(DF_TermPtr); + +/* head normalization of the term in the argument with occurs-check */ +void HN_hnormOcc(DF_TermPtr); + +/* full normalization of the term in the argument */ +void HN_lnorm(DF_TermPtr); + + +#endif //HNORM_H diff --git a/src/runtime/c/teyjus/simulator/hnormlocal.c b/src/runtime/c/teyjus/simulator/hnormlocal.c new file mode 100644 index 000000000..2f55246bd --- /dev/null +++ b/src/runtime/c/teyjus/simulator/hnormlocal.c @@ -0,0 +1,598 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* File hnormlocal.c. */ +/* This file contains the definitions of some auxiliary functionw that are */ +/* used exclusively in the (head) normalization routines. (hnorm.c) */ +/*****************************************************************************/ + +#ifndef HNORMLOCAL_C +#define HNORMLOCAL_C + +#include <stdlib.h> +#include "abstmachine.h" +#include "dataformats.h" +#include "trail.h" + + +/**********************************************************************/ +/* Register setting upon hnorm initiation or termination */ +/**********************************************************************/ + +/* initialize relevant registers */ +void HNL_initRegs() +{ + AM_numAbs = AM_numArgs = 0; + AM_head = AM_argVec = NULL; +} + +/* when a cons head is found */ +void HNL_setRegsCons(DF_TermPtr consPtr) +{ + AM_consFlag = AM_rigFlag = ON; + AM_head = consPtr; +} + +/* when a (special) constant head is found */ +void HNL_setRegsRig(DF_TermPtr headPtr) +{ + AM_consFlag = OFF; + AM_rigFlag = ON; + AM_head = headPtr; +} + +/* when a unbound variable head is found */ +void HNL_setRegsFlex(DF_TermPtr headPtr) +{ + AM_consFlag = AM_rigFlag = OFF; + AM_head = headPtr; +} + +/************************************************************************/ +/* Term creation functions */ +/************************************************************************/ + +/* Push de Bruijn index #ind on the current heap top */ +void HNL_pushBV(int ind) +{ + MemPtr newhtop = AM_hreg + DF_TM_ATOMIC_SIZE; //new heap top + AM_heapError(newhtop); + DF_mkBV(AM_hreg, ind); + AM_hreg = newhtop; +} + +/* Push abstraction lam(n, body) on the current heap top. */ +void HNL_pushLam(DF_TermPtr bodyPtr, int n) +{ + MemPtr newhtop = AM_hreg + DF_TM_LAM_SIZE; //new heap top + AM_heapError(newhtop); + DF_mkLam(AM_hreg, n, bodyPtr); + AM_hreg = newhtop; +} + +/* Push cons(argvecPtr) on the current heap top */ +void HNL_pushCons(DF_TermPtr argvecPtr) +{ + MemPtr newhtop = AM_hreg + DF_TM_CONS_SIZE; //new heap top + AM_heapError(newhtop); + DF_mkCons(AM_hreg, argvecPtr); + AM_hreg = newhtop; +} + +/* Push an application on the current heap top. */ +void HNL_pushApp(DF_TermPtr funcPtr, DF_TermPtr argvecPtr, int arity) +{ + MemPtr newhtop = AM_hreg + DF_TM_APP_SIZE; + AM_heapError(newhtop); + DF_mkApp(AM_hreg, arity, funcPtr, argvecPtr); + AM_hreg = newhtop; +} + +/* Push suspension [|skPtr, ol, nl, e|] on the current heap top. */ +void HNL_pushSusp(DF_TermPtr skPtr, int ol, int nl, DF_EnvPtr e) +{ + MemPtr newhtop = AM_hreg + DF_TM_SUSP_SIZE; //new heap top + AM_heapError(newhtop); + DF_mkSusp(AM_hreg, ol, nl, skPtr, e); + AM_hreg = newhtop; +} + +/* Push suspension [|skPtr, ol, nl, e|] on a given location, the pointer to + that location is increamented as side-effect */ +void HNL_pushSuspOnLoc(DF_TermPtr skPtr, int ol, int nl, DF_EnvPtr e, + MemPtr *locPtr) +{ + MemPtr loc = *locPtr, newloc = loc + DF_TM_SUSP_SIZE; + AM_heapError(newloc); + DF_mkSusp(loc, ol, nl, skPtr, e); + *locPtr = newloc; +} + +/* Destructively change the cell referred to by tmPtr to a reference. + The change is trailed if necessary. */ +void HNL_updateToRef(DF_TermPtr tmPtr, DF_TermPtr target) +{ + TR_trailHTerm(tmPtr); + DF_mkRef((MemPtr)tmPtr, target); +} + +/************************************************************************/ +/* Functions for eagerly evaluating implicit renumber suspensions */ +/*----------------------------------------------------------------------*/ +/* General comments: */ +/* Renumbering suspensions [|skPtr, 0, nl, nil|] */ +/* Specifically, if skPtr is a (special) constant, de Bruijn index or a */ +/* unbound variable, the suspension is eagerly evaluated; otherwise */ +/* it is suspended. In case skPtr is another suspension, combination is */ +/* performed. */ +/************************************************************************/ + +/* Used in HNL_BVSuspAsEnv. + The renumber suspension belongs to an environment list. + A pointer to the evaluation result is returned. New suspensions are + pushed on the current heap top if necessary. +*/ +static DF_TermPtr HNL_renumberAsEnv(DF_TermPtr skPtr, int nl) +{ + DF_TermPtr rtPtr; //term pointer to be returned + restart_renumberAsEnv: + switch (DF_termTag(skPtr)){ + case DF_TM_TAG_VAR: + 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: + { rtPtr = skPtr; break; } + case DF_TM_TAG_LAM: + case DF_TM_TAG_CONS: + case DF_TM_TAG_APP: //[|skPtr, 0, nl, nil|] + { + if (nl == 0) rtPtr = skPtr; + else { + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushSusp(skPtr, 0, nl, DF_EMPTY_ENV); + } + break; + } + case DF_TM_TAG_SUSP: //[|[|t,ol,nl,e|],0,l,nil|] -> [|t,ol,nl+l,e|] + { + if (nl == 0) rtPtr = skPtr; + else { + DF_TermPtr myskPtr = DF_termDeref(DF_suspTermSkel(skPtr)); + int myol = DF_suspOL(skPtr), mynl = DF_suspNL(skPtr); + DF_EnvPtr myenv = DF_suspEnv(skPtr); + int newnl = mynl+nl; + + AM_embedError(newnl); + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushSusp(skPtr, myol, newnl, myenv); + } + break; + } + case DF_TM_TAG_BVAR: //[|#i, 0, nl, nil |] -> #(i+nl) + { + int newind = DF_bvIndex(skPtr)+nl; + + AM_embedError(newind); + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushBV(newind); + break; + } + case DF_TM_TAG_REF:{skPtr=DF_termDeref(skPtr); goto restart_renumberAsEnv; } + }//switch + return rtPtr; +} + +/* Used in HNL_BVSuspAsArg. + The renumber suspension belongs to the arguments of an application or + cons. + In case the evaluation result has an atomic size and is not a unbound + variable, it is committed on the heap location referred to by loc. + If the evaluation result is a free variable or a constant with type + associations, a reference to the result is created on the heap location + referred to by loc. + Otherwise, the evaluation result must be a suspension, and in this case, + the new suspension is created on the location referred to by (*spLocPtr), + (*spLocPtr) is increamented by a suspension size, and a reference to the + new suspension is created on the location pointed by loc. */ +static void HNL_renumberAsArg(DF_TermPtr skPtr, int nl, MemPtr loc, + MemPtr *spLocPtr) +{ + restart_renumberAsArg: + switch (DF_termTag(skPtr)){ + case DF_TM_TAG_VAR: { DF_mkRef(loc, skPtr); break; } + case DF_TM_TAG_CONST: + { + if (DF_isTConst(skPtr)) DF_mkRef(loc, skPtr); + else DF_copyAtomic(skPtr, loc); + break; + } + 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: + { DF_copyAtomic(skPtr, loc); break;} + case DF_TM_TAG_LAM: + case DF_TM_TAG_CONS: + case DF_TM_TAG_APP: //[|t, 0, nl, nil|] + { + if (nl == 0) DF_mkRef(loc, skPtr); + else { + DF_mkRef(loc, (DF_TermPtr)(*spLocPtr)); + HNL_pushSuspOnLoc(skPtr, 0, nl, DF_EMPTY_ENV, spLocPtr); + } + break; + } + case DF_TM_TAG_SUSP: //[|[|t,ol,nl,e|],0,l,nil|] -> [|t,ol,nl+l,e|] + { + if (nl == 0) DF_mkRef(loc, skPtr); + else { + DF_TermPtr myskPtr = DF_termDeref(DF_suspTermSkel(skPtr)); + int myol = DF_suspOL(skPtr), mynl = DF_suspNL(skPtr); + DF_EnvPtr myenv = DF_suspEnv(skPtr); + int newnl = mynl+nl; + + AM_embedError(newnl); + DF_mkRef(loc, (DF_TermPtr)(*spLocPtr)); + HNL_pushSuspOnLoc(myskPtr, myol, newnl, myenv, spLocPtr); + } + break; + } + case DF_TM_TAG_BVAR: //[|#i, 0, adj, nil |] -> #(i+adj) + { + int newind = DF_bvIndex(skPtr)+nl; + AM_embedError(newind); + DF_mkBV(loc, newind); + break; + } + case DF_TM_TAG_REF:{skPtr=DF_termDeref(skPtr); goto restart_renumberAsArg;} + } +} + + +/************************************************************************/ +/* Functions for eagerly evaluating implicit suspensions with */ +/* de Bruijn indices as term skeleton. */ +/*----------------------------------------------------------------------*/ +/* General comments: */ +/* suspension [|#ind, ol, nl, env|] */ +/* The suspension is eagerly evaluated till a non-suspension term or a */ +/* un-trivial suspension is resulted. */ +/************************************************************************/ + +/* Used in HNL_suspAsEnv. + The suspension belongs to an environment list. + A pointer to the evaluation result is returned. If new suspensions + need to be created, they are pushed on the current heap top. */ +static DF_TermPtr HNL_BVSuspAsEnv(int ind, int ol, int nl, DF_EnvPtr env) +{ + DF_TermPtr rtPtr; //term pointer to be returned + if (ind > ol){ //[|#i, ol, nl, env|] -> #(i-ol+nl), where i>ol + int newind = ind - ol + nl; + + AM_embedError(newind); + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushBV(newind); + } else {// ind <= ol + DF_EnvPtr envitem = DF_envListNth(env, ind); //ith in env + int nladj = nl - DF_envIndex(envitem); + + if (DF_isDummyEnv(envitem)){//[|#i,ol,nl,..@l..|]->#(nl-l), where i<=ol + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushBV(nladj); + } else { //DF_isPairEnv(envitem) + DF_TermPtr tmPtr = DF_envPairTerm(envitem); + + rtPtr = HNL_renumberAsEnv(tmPtr, nladj); + } + } // ind <= ol + return rtPtr; +} + +/* Used in HNL_suspAsArg. + The suspension belongs to the arguments of an application or cons. + The pointer loc refers to the heap location where the evaluation result + or a reference of the evaluation result is to be created, and if new + suspensions need to be created, they are created on the heap location + referred to by *spLocPtr. +*/ +static void HNL_BVSuspAsArg(DF_TermPtr bv, int ol, int nl, DF_EnvPtr env, + MemPtr loc, MemPtr *spLocPtr) +{ + int ind = DF_bvIndex(bv); //index of the bv + if (ind > ol){ //[|#i, ol, nl, env|] -> #(i-ol+nl), where i>ol + int newind = ind - ol + nl; + + AM_embedError(newind); + DF_mkBV(loc, newind); + } else {//ind <= ol + DF_EnvPtr envitem = DF_envListNth(env, ind); //ith item in env + int nladj = nl - DF_envIndex(envitem); + + if (DF_isDummyEnv(envitem)){//[|#i,ol,nl,..@l..|]->#(nl-l), where i<=ol + DF_mkBV(loc, nladj); + } else { //DF_IsPairEnv(envitem) + DF_TermPtr tmPtr = DF_envPairTerm(envitem); + HNL_renumberAsArg(tmPtr, nladj, loc, spLocPtr); + } //ind <= ol + } +} + +/************************************************************************/ +/* Functions for eagerly evaluating implicit suspensions */ +/*----------------------------------------------------------------------*/ +/* General comments: */ +/* suspension [|skPtr ol, nl, env|] */ +/* The suspension is eagerly evaluated till a non-suspension term or a */ +/* un-trivial suspension is resulted. */ +/************************************************************************/ + +/* The suspension belongs to an environment list. + A pointer to the evaluation result is returned. New suspensions are + pushed on the current heap top if necessary. */ +DF_TermPtr HNL_suspAsEnv(DF_TermPtr skPtr, int ol, int nl, DF_EnvPtr env) +{ + DF_TermPtr rtPtr; // term pointer to be returned + restart_suspAsEnv: + switch(DF_termTag(skPtr)){ //[|c, ol, nl, envlist|] -> c + case DF_TM_TAG_VAR: + 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: + { rtPtr = skPtr; break; } + case DF_TM_TAG_LAM: + case DF_TM_TAG_CONS: + case DF_TM_TAG_SUSP: + case DF_TM_TAG_APP: + { + rtPtr = (DF_TermPtr)AM_hreg; + HNL_pushSusp(skPtr, ol, nl, env); + break; + } + case DF_TM_TAG_BVAR: + { + int dbind = DF_bvIndex(skPtr); + rtPtr = HNL_BVSuspAsEnv(dbind, ol, nl, env); + break; + } + case DF_TM_TAG_REF: { skPtr = DF_termDeref(skPtr); goto restart_suspAsEnv; } + } + return rtPtr; +} + +/* Used in HNL_pushSuspOverArgs. + The suspension belongs to the arguments of an application or cons. + The pointer loc refers to the heap location where the evaluation result + or a reference of the evaluation result is to be created, and if new + suspensions need to be created, they are created on the heap location + referred to by *spLocPtr. + A flag CHANGED is used to indicate whether the evaluation result is different + from skPtr. +*/ +static void HNL_suspAsArg(DF_TermPtr skPtr, int ol, int nl, DF_EnvPtr env, + MemPtr loc, MemPtr *spLocPtr, Boolean *changed) +{ + restart_suspAsArg: + switch(DF_termTag(skPtr)){ + case DF_TM_TAG_VAR: { DF_mkRef(loc, skPtr); break; } + case DF_TM_TAG_CONST: + { + if (DF_isTConst(skPtr)) DF_mkRef(loc, skPtr); + else DF_copyAtomic(skPtr, loc); + break; + } + 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: + { + DF_copyAtomic(skPtr, loc); + break; + } + case DF_TM_TAG_LAM: + case DF_TM_TAG_CONS: + case DF_TM_TAG_SUSP: + case DF_TM_TAG_APP: + { + DF_mkRef(loc, (DF_TermPtr)(*spLocPtr)); + HNL_pushSuspOnLoc(skPtr, ol, nl, env, spLocPtr); + *changed = TRUE; + break; + } + case DF_TM_TAG_BVAR: + { + + HNL_BVSuspAsArg(skPtr, ol, nl, env, loc, spLocPtr); + *changed = TRUE; + break; + } + case DF_TM_TAG_REF: { skPtr = DF_termDeref(skPtr); goto restart_suspAsArg; } + } +} + +/************************************************************************/ +/* Functions for creating application argument vectors */ +/*----------------------------------------------------------------------*/ +/* Gerenal comments: */ +/* Two issues are considered here. */ +/* 1. When the application (cons) is embedded inside a non-empty */ +/* suspension, the suspension has to be propagated over their */ +/* arguments. In this process, trivial suspensions (those over atomic*/ +/* terms including de Bruijn indices) are eagerly evaluated. */ +/* 2. When the application has a function being another application */ +/* (indicated by AM_numArgs), the nested structures should be */ +/* un-folded. In particular, an argument vector with that of the */ +/* "top-level" application (possibly changed from propagating */ +/* suspensions), and that of the "inner" application has to be */ +/* created on the current top of heap. */ +/* Such functionality is realized by the following procedures. */ +/************************************************************************/ + +/* Copy an argument vector start from argvec onto the current top of + heap. Needed in unfolding nested applications. + Note that a reference has to be made for unbound variables as opposed + to duplication. +*/ +void HNL_copyArgs(DF_TermPtr argvec, int arity) +{ + int i; + for (i = 1; i <= arity; i++){ + if (DF_isFV(argvec)) DF_mkRef(AM_hreg, argvec); + else DF_copyAtomic(argvec, AM_hreg); + AM_hreg += DF_TM_ATOMIC_SIZE; + argvec = (DF_TermPtr)(((MemPtr)argvec)+DF_TM_ATOMIC_SIZE); + } +} + + +/* Create an argument vector for applications inside an empty environment. + If no other application is nested in this one, the old argument vector is + used. Specifically, AM_argVec is set to refer the starting address of + the old argument vector, AM_numArgs is set to its arity, and FALSE is + returned to indicate no changes occur in the vector. + Otherwise, a new vector copied from that referred to by argvec and + the other referred to by AM_argVec is created on the current top of heap. + AM_argVec and AM_numArgs are updated correspondingly, and TRUE is + returned to indicate a new vector should be used for the application. +*/ + +Boolean HNL_makeArgvecEmpEnv(DF_TermPtr argvec, int arity) +{ + if (AM_numArgs == 0) { //no nested app + AM_argVec = argvec; //reuse the old argvec + AM_numArgs = arity; + return FALSE; + } else { //unfold nested app + DF_TermPtr newArgvec = (DF_TermPtr)AM_hreg; + int newArity = arity + AM_numArgs; + MemPtr newhtop = AM_hreg + arity * DF_TM_ATOMIC_SIZE; + + AM_arityError(newArity); + AM_heapError(newhtop); + HNL_copyArgs(AM_argVec, AM_numArgs); //lay out inner argvec + HNL_copyArgs(argvec, arity); //lay out top-level argvec + + AM_argVec = newArgvec; + AM_numArgs = newArity; + return TRUE; + } +} + +/* Propagate a suspension environment given by (ol, nl, env) over the + argument vector referred to by argvec. Trivial suspensions are eagerly + evaluated in this process. Non-trivial ones are created on the location + referred to by *spLocPtr. + Further, a flag changed is used to indicate whether the propagating + result is the same as the original argument vector. +*/ +static void HNL_pushSuspOverArgs(DF_TermPtr argvec, int arity, int ol, int nl, + DF_EnvPtr env, MemPtr *spLocPtr, + Boolean *changed) +{ + int i; + MemPtr myArgvec = AM_hreg;//AM_hreg has not been moved yet + + for (i = 1; i <= arity; i++){ + HNL_suspAsArg(argvec, ol, nl, env, myArgvec, spLocPtr, changed); + myArgvec = myArgvec + DF_TM_ATOMIC_SIZE; + argvec = (DF_TermPtr)(((MemPtr)argvec)+DF_TM_ATOMIC_SIZE); + } +} + +/* Create an argument vector for applications inside a non-empty environment. + Actions are carried out in two steps: + First, nested applications are unfolded if arising. Second, the + non-empty environment is propagated over the argument vector of the (top) + application. + It is assumed that the vector will be changed in the beginning of both + processes, and a flag changed is used to indicate whether changes really + occur. The new argument vector is used and the top of heap is updated only + when the changed flag is TRUE upon termination. Otherwise, the old argument + is used. The flag changed is also returned to the caller to indicate which + vector is used. +*/ +Boolean HNL_makeArgvec(DF_TermPtr argvec, int arity, int ol, int nl, + DF_EnvPtr env) +{ + Boolean changed; //flag denoting if new argvec is made or the old is reused + MemPtr spLocPtr; //place where susps are to be created + MemPtr newArgvec = AM_hreg; + + + //unfold nested app first when necessary + if (AM_numArgs == 0){ //no nested app + //assume new arg vector has to be created because of susp propagating + spLocPtr = newArgvec + arity * DF_TM_ATOMIC_SIZE; + AM_heapError(spLocPtr); + AM_numArgs = arity; + changed = FALSE; //indicating no change is made for unfolding app + } else { //unfold nested app + int newArity = arity + AM_numArgs; + + AM_arityError(newArity); + //assume new arg vector has to be created because of susp propagating + spLocPtr = newArgvec + newArity * DF_TM_ATOMIC_SIZE; + AM_heapError(spLocPtr); + HNL_copyArgs(AM_argVec, AM_numArgs); //lay out inner argvec + AM_numArgs = newArity; + changed = TRUE; //indicating changes are made for unfolding app + } + + //push susp over the argument vector of the top-level app + HNL_pushSuspOverArgs(argvec, arity, ol, nl, env, &spLocPtr, &changed); + + if (changed) { //changes because of unfold app or propagate susp + AM_hreg = spLocPtr; + AM_argVec = (DF_TermPtr)newArgvec; + } else AM_argVec = argvec; //no change, reuse the old arg vector + return changed; +} + +/* A specialized version of HNL_makeArgvec for argument vectors on cons. + The arity of cons is fixed, and there is no need to considering "unfolding". +*/ +Boolean HNL_makeConsArgvec(DF_TermPtr argvec, int ol, int nl, DF_EnvPtr env) +{ + MemPtr spLocPtr; + MemPtr newArgvec = AM_hreg; + Boolean changed = FALSE; + + spLocPtr = newArgvec + DF_CONS_ARITY * DF_TM_ATOMIC_SIZE; + AM_heapError(spLocPtr); + HNL_pushSuspOverArgs(argvec,DF_CONS_ARITY,ol,nl,env,&spLocPtr,&changed); + + AM_numArgs = DF_CONS_ARITY; + if (changed){ + AM_hreg = spLocPtr; + AM_argVec = (DF_TermPtr)newArgvec; + } else AM_argVec = argvec; + + return changed; +} + +#endif //HNORMLOCAL_C diff --git a/src/runtime/c/teyjus/simulator/hnormlocal.h b/src/runtime/c/teyjus/simulator/hnormlocal.h new file mode 100644 index 000000000..0a123c581 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/hnormlocal.h @@ -0,0 +1,75 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* File hnormlocal.h. */ +/* This header file identifies functions that are used exclusively in the */ +/* (head) normalization routines. Thus, this file is imported only by */ +/* hnorm.c. */ +/*****************************************************************************/ + +#ifndef HNORMLOCAL_H +#define HNORMLOCAL_H + +#include "dataformats.h" + +/**********************************************************************/ +/* Register setting upon hnorm initiation or termination */ +/**********************************************************************/ +void HNL_initRegs(); // initialize relevant registers +void HNL_setRegsCons(DF_TermPtr); // when a cons head is found +void HNL_setRegsRig(DF_TermPtr); // when a (special) constant head is found +void HNL_setRegsFlex(DF_TermPtr); // when a unbound variable head is found + +/************************************************************************/ +/* Term creation and destructive modification functions */ +/************************************************************************/ +/* Push de Bruijn index #ind on the current heap top. */ +void HNL_pushBV(int ind); +/* Push abstraction lam(n, body) on the current heap top. */ +void HNL_pushLam(DF_TermPtr body, int n); +/* Push cons on the current heap top. */ +void HNL_pushCons(DF_TermPtr argvecPtr); +/* Push an application on the current heap top. */ +void HNL_pushApp(DF_TermPtr funcPtr, DF_TermPtr argvecPtr, int arity); +/* Destructively change the cell referred to by tmPtr to a reference + The change is trailed if necessary. */ +void HNL_updateToRef(DF_TermPtr tmPtr, DF_TermPtr target); + +/************************************************************************/ +/* Functions for eagerly evaluating implicit suspensions */ +/************************************************************************/ +/* The suspension belongs to an environment list. */ +DF_TermPtr HNL_suspAsEnv(DF_TermPtr skPtr, int ol, int nl, DF_EnvPtr env); + +/************************************************************************/ +/* Functions for creating application argument vectors */ +/************************************************************************/ +/* Copy an argument vector start from argvec onto the current top of heap. */ +void HNL_copyArgs(DF_TermPtr argvec, int arity); +/* Create an argument vector for applications inside an empty environment. */ +Boolean HNL_makeArgvecEmpEnv(DF_TermPtr argvec, int arity); +/* Create an argument vector for applications inside a non-empty environment. */ +Boolean HNL_makeArgvec(DF_TermPtr argvec, int arity, int ol, int nl, + DF_EnvPtr env); +/* A specialized version of HNL_makeArgvec for argument vectors on cons. */ +Boolean HNL_makeConsArgvec(DF_TermPtr argvec, int ol, int nl, DF_EnvPtr env); + +#endif //HNORMLOCAL_H diff --git a/src/runtime/c/teyjus/simulator/hopu.c b/src/runtime/c/teyjus/simulator/hopu.c new file mode 100644 index 000000000..505eed6df --- /dev/null +++ b/src/runtime/c/teyjus/simulator/hopu.c @@ -0,0 +1,1693 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File hopu.c. This file contains the main routines implementing the */ +/* interpretive part of higher-order pattern unification. */ +/* */ +/****************************************************************************/ +#ifndef HOPU_C +#define HOPU_C + +#include "hopu.h" +#include "mctypes.h" +#include "dataformats.h" +#include "hnorm.h" +#include "abstmachine.h" +#include "types.h" +#include "trail.h" +#include "../system/error.h" +#include "../system/memory.h" + +#include <stdio.h> + +/* Unify types associated with constants. */ +static void HOPU_typesUnify(DF_TypePtr tyEnv1, DF_TypePtr tyEnv2, int n) +{ + AM_pdlError(2*n); + AM_initTypesPDL(); + TY_pushPairsToPDL((MemPtr)tyEnv1, (MemPtr)tyEnv2, n); + TY_typesUnify(); +} + +/* Return the dereference of the abstraction body of the given term. */ +DF_TermPtr HOPU_lamBody(DF_TermPtr tmPtr) +{ + tmPtr = DF_termDeref(tmPtr); + while (DF_isLam(tmPtr)) tmPtr = DF_termDeref(DF_lamBody(tmPtr)); + return tmPtr; +} + +/***************************************************************************/ +/* Globalize functions needed for HOPU_patternUnidyPair */ +/***************************************************************************/ + +/* Globalize a rigid term. */ +/* If the term pointer is not one referring to a heap address, the atomic */ +/* content is then copied onto the current top of heap; the term pointer */ +/* is updated to the new heap term. */ +static DF_TermPtr HOPU_globalizeRigid(DF_TermPtr rPtr) +{ + if (AM_nHeapAddr((MemPtr)rPtr)) {//rPtr must refer to const (no type), int, + //float, str, (stream), nil, cons + MemPtr nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_copyAtomic(rPtr, AM_hreg); + rPtr = (DF_TermPtr)AM_hreg; + AM_hreg = nhreg; + } + return rPtr; +} + +/* Globalize a rigid term and make a variable binding. */ +/* If the term pointer to the rigid term is not one referring to a heap */ +/* address, its atomic content is then copied into the variable to be bound*/ +/* Otherwise, the variable is made a reference to the rigid term. */ +void HOPU_globalizeCopyRigid(DF_TermPtr rPtr, DF_TermPtr vPtr) +{ + if (AM_nHeapAddr((MemPtr)rPtr)) //rPtr must refer to rigid atomic term + DF_copyAtomic(rPtr, (MemPtr)vPtr); + else DF_mkRef((MemPtr)vPtr, rPtr); //rPtr could also be app +} + +/* Globalize a flex term. */ +/* If the term pointer is one referring to a stack address, (in which case */ +/* the flex term must be a free variable itself), the atomic content is */ +/* copied onto the current top of heap; the free variable on stack is then */ +/* bound to the new heap term, and the binding is trailed if necessary; the */ +/* term pointer is updated to the new heap term. */ +DF_TermPtr HOPU_globalizeFlex(DF_TermPtr fPtr) +{ + if (AM_stackAddr((MemPtr)fPtr)) {//fPtr must be a reference to var + MemPtr nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_copyAtomic(fPtr, AM_hreg); + TR_trailETerm(fPtr); + DF_mkRef((MemPtr)fPtr, (DF_TermPtr)AM_hreg); + fPtr = (DF_TermPtr)AM_hreg; + AM_hreg = nhreg; + } + return fPtr; +} + +/***************************************************************************/ +/* Explicit eta expansion (on a rigid term) */ +/***************************************************************************/ + +/* Eta expands a rigid term whose term pointer and decomposition are given */ +/* by arguments. The new lambda body is returned. (It is unnecessary to */ +/* create a new lambda term for the abstractions in the front of the eta */ +/* expanded form. Note that the term head and argument vector are updated */ +/* as side-effect. */ +/* Note globalization on the term head is always performed and no */ +/* specialized version of this function is provided based on the assumption*/ +/* that explicit eta-expansion is rarely needed. */ +static DF_TermPtr HOPU_etaExpand(DF_TermPtr *h, DF_TermPtr *args, int nargs, + int nabs) +{ + DF_TermPtr hPtr = *h, oldArgs = *args, rtPtr; + MemPtr suspLoc; //where susps are to be created + int newArity = nargs + nabs; + if (DF_isBV(hPtr)){ //lift index by nabs if the head is a bound variable + int ind = DF_bvIndex(hPtr) + nabs; + AM_embedError(ind); + AM_heapError(AM_hreg + DF_TM_ATOMIC_SIZE); + *h = hPtr =(DF_TermPtr)AM_hreg; //update head pointer + DF_mkBV(AM_hreg,ind); + AM_hreg += DF_TM_ATOMIC_SIZE; + } else + //always perform globalization; eta expansion is rarely needed + *h = hPtr = HOPU_globalizeRigid(hPtr); + + AM_arityError(newArity); + AM_heapError(AM_hreg + nargs * DF_TM_SUSP_SIZE + newArity*DF_TM_ATOMIC_SIZE + + DF_TM_APP_SIZE); + suspLoc = AM_hreg; + AM_hreg += nargs * DF_TM_SUSP_SIZE; //allocate space for nargs suspensions + rtPtr = (DF_TermPtr)AM_hreg; //new application + DF_mkApp(AM_hreg, newArity, hPtr, (DF_TermPtr)(AM_hreg + DF_TM_APP_SIZE)); + AM_hreg += DF_TM_APP_SIZE; + *args = (DF_TermPtr)AM_hreg; //update arg vector pointer + for (; nargs > 0; nargs--){//create suspensions over original arguments + DF_mkSusp(suspLoc, 0, nabs, DF_termDeref(oldArgs), DF_EMPTY_ENV); + DF_mkRef(AM_hreg, (DF_TermPtr)suspLoc); + suspLoc += DF_TM_SUSP_SIZE; AM_hreg += DF_TM_ATOMIC_SIZE; + oldArgs = (DF_TermPtr)(((MemPtr)oldArgs) + DF_TM_ATOMIC_SIZE); + } + for (; nabs > 0; nabs--){//create de Bruijn indices from #nabs to #1 + DF_mkBV(AM_hreg, nabs); + AM_hreg += DF_TM_ATOMIC_SIZE; + } + return rtPtr; +} + +/***************************************************************************/ +/* PATTERN RECOGNITION */ +/* */ +/* Auxiliary functions for recognizing LLambda pattens for flexible terms. */ +/***************************************************************************/ +/* Whether a bound variable occurs in the given arguments. */ +/* It is assumned that the given arguments can only contain bound variables*/ +/* and constants. */ +static Boolean HOPU_uniqueBV(int bvInd, DF_TermPtr args, int n) +{ + DF_TermPtr tPtr; + for ( ; n > 0 ; n-- ){ + tPtr = DF_termDeref(args); + if (DF_isBV(tPtr) && (bvInd == DF_bvIndex(tPtr))) return FALSE; + //otherwise different bv or constant, check the next + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } + return TRUE; +} + +/* Whether a constant occurs in the given arguments. */ +/* It is assumned that the given arguments can only contain bound variables*/ +/* and constants. */ +/* CHANGES have to be made here if the semantics of local constants are */ +/* changed with respect to polymorphism. */ +static Boolean HOPU_uniqueConst(DF_TermPtr cPtr, DF_TermPtr args, int n) +{ + DF_TermPtr tPtr; + for ( ; n > 0 ; n--){ + tPtr = DF_termDeref(args); + if (DF_isConst(tPtr) && DF_sameConsts(tPtr, cPtr)) { + if (DF_isTConst(tPtr)) { + EM_TRY { + HOPU_typesUnify(DF_constType(tPtr), DF_constType(cPtr), + AM_cstTyEnvSize(DF_constTabIndex(cPtr))); + } EM_CATCH { + if (EM_CurrentExnType == EM_FAIL) { + AM_resetTypesPDL();//remove tys from pdl for ty unif + return FALSE; + } else EM_RETHROW(); + } + } else return FALSE; + } //otherwise different constant or bv, check the next + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } //for loop + return TRUE; +} + +/* Checking whether the argments of the head normal form given by registers*/ +/* AM_argVec, AM_numArgs and AM_numAbs are those of an eta-expanded form. */ +/* Specifically, the arguments are attempted to match de Bruijn indices */ +/* #n ... #1, where n is the current value of AM_numAbs. */ +/* It is assumed that the argument vector is not empty. */ +static Boolean HOPU_isEtaExpArgs() +{ + if (AM_numArgs != AM_numAbs) return FALSE; + else { + int i = AM_numAbs; + Boolean match = TRUE; + DF_TermPtr oneArg = AM_argVec; + DF_TermPtr head = AM_head; + while (match && (i > 0)){ + HN_hnorm(oneArg); + if (AM_numArgs == 0) + match = ((AM_numArgs == 0) && DF_isBV(AM_head) && + (DF_bvIndex(AM_head) == i)); + else + match = (DF_isBV(AM_head) && (DF_bvIndex(AM_head)-AM_numAbs==i) + && HOPU_isEtaExpArgs()); + oneArg = (DF_TermPtr)(((MemPtr)oneArg + DF_TM_ATOMIC_SIZE)); + i--; + } + AM_head = head; + return match; + } +} + +/* Checking whether the arguments of a flexible term satisfy with the */ +/* LLambda pattern with respect to the universe count of its flex head. */ +/* CHANGES have to be made here if the semantics of local constants are */ +/* changed with respect to polymorphism. */ +static Boolean HOPU_isLLambda(int uc, int nargs, DF_TermPtr args) +{ + if (nargs == 0) return TRUE; + else { + int i; + DF_TermPtr myArgs = args; + for (i = 0; i < nargs; i++){ + HN_hnorm(args); + if (AM_numArgs == 0) { + if (AM_numAbs != 0) return FALSE; //abstraction + if (DF_isBV(AM_head)) { //bound variable + if (!HOPU_uniqueBV(DF_bvIndex(AM_head), myArgs, i)) + return FALSE; + } else if (DF_isConst(AM_head)) { //constant + if (!(uc < DF_constUnivCount(AM_head) && + HOPU_uniqueConst(AM_head, myArgs, i))) return FALSE; + } else return FALSE; //other sort of terms + } else { //AM_numArgs != 0 + if (DF_isBV(AM_head)) { //bound variable head + int dbInd = DF_bvIndex(AM_head) - AM_numAbs; //eta-norm + if (dbInd > 0 && HOPU_uniqueBV(dbInd, myArgs, i) && + HOPU_isEtaExpArgs()) { + TR_trailHTerm(args); + DF_mkBV((MemPtr)args, dbInd); + } else return FALSE; + } else { //!(DF_isBV(AM_head)) + if (DF_isConst(AM_head)) { //constant head + if (uc < DF_constUnivCount(AM_head) && + HOPU_uniqueConst(AM_head, myArgs, i) && + HOPU_isEtaExpArgs()) { + TR_trailHTerm(args); + if (DF_isTConst(AM_head)) + DF_mkRef((MemPtr)args, AM_head); + else DF_copyAtomic(AM_head, (MemPtr)args); + } else return FALSE; + } else return FALSE; //other sort of terms + } //!(DF_isBV(AM_head)) + } //AM_numArgs != 0 + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } //for loop + return TRUE; + } //nargs != 0 +} + +/***************************************************************************/ +/* BINDING */ +/* */ +/* Attempt to find bindings for free variables (counter part of mksubst in */ +/* the sml pattern unfication code). */ +/***************************************************************************/ +/* A flag denoting whether new structure is created during the process of */ +/* finding substitutions. */ +Boolean HOPU_copyFlagGlb = FALSE; + +/* Return a non-zero index of a bound variable appears in a list of */ +/* arguments. Note the index is the position from the right and the */ +/* embedding level is taken into account. */ +static int HOPU_bvIndex(int dbInd, DF_TermPtr args, int nargs, int lev) +{ + int ind; + dbInd -= lev; + for (ind = nargs; ind > 0; ind--){ + DF_TermPtr tPtr = DF_termDeref(args); + if (DF_isBV(tPtr) && (dbInd == DF_bvIndex(tPtr))) return (ind+lev); + //otherwise try the next + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } + return 0; //not found +} + +/* Return a non-zero index if a constant appears in a list of arguments. */ +/* Note the index is the position from the right and the embedding level */ +/* is taken into account. */ +/* CHANGES have to be made here if the semantics of local constants are */ +/* changed with respect to polymorphism. */ +static int HOPU_constIndex(DF_TermPtr cPtr, DF_TermPtr args, int nargs, int lev) +{ + int ind; + for (ind = nargs; ind > 0; ind--){ + DF_TermPtr tPtr = DF_termDeref(args); + if (DF_isConst(tPtr) && DF_sameConsts(tPtr, cPtr)) { + if (DF_isTConst(tPtr)) { + Boolean found = FALSE; + EM_TRY { + HOPU_typesUnify(DF_constType(tPtr), DF_constType(cPtr), + AM_cstTyEnvSize(DF_constTabIndex(cPtr))); + found = TRUE; + } EM_CATCH {//remove types added for ty unif from the PDL + if (EM_CurrentExnType == EM_FAIL) AM_resetTypesPDL(); + else EM_RETHROW(); + } + if (found) return (ind+lev); + } else return (ind+lev); //cPtr does not have type associated + } //otherwise try the next + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } + return 0; //not found +} + +/***************************************************************************/ +/* BINDING FOR FLEX-FLEX */ +/* */ +/* Auxiliary functions for solving flex-flex pairs. */ +/* Non-LLambda pairs are delayed onto the disagreement list. */ +/***************************************************************************/ + +/* Collect raising components for internal variable in the LLambda case */ +/* when it is known it has a higher universe index than the outside llambda*/ +/* variable. */ +/* It is assumned that the incoming argument vector has a size larger than */ +/* zero. */ +/* As a result of this process, segments of the argument vectors for both */ +/* variables are decided. That for the internal variable is created on the */ +/* current top of heap, while that for the outside variable, each */ +/* argument of which must be a de Bruijn index, is recorded into an integer*/ +/* array which is set by side-effect. */ +/* The number returned by this procedure is the length of both of the */ +/* argument vector segements. Raising occured when this number is non-zero.*/ +/* CHANGES have to be made here if the semantics of local constants are */ +/* changed with respect to polymorphism. */ +static int HOPU_raise(int varuc, DF_TermPtr args, int nargs, int emblev, + int *args11) +{ + int numRaised = 0; //number of args that have been raised + AM_heapError(AM_hreg + nargs * DF_TM_ATOMIC_SIZE);//max possible size + for (; nargs > 0; nargs--){ + DF_TermPtr tmPtr = DF_termDeref(args); + if (DF_isConst(tmPtr) && (DF_constUnivCount(tmPtr) <= varuc)){ + args11[numRaised] = nargs + emblev; //args11 + if (DF_isTConst(tmPtr)) DF_mkRef(AM_hreg, tmPtr); //args21 + else DF_copyAtomic(tmPtr, AM_hreg); + AM_hreg += DF_TM_ATOMIC_SIZE; + numRaised++; + } + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } + return numRaised; +} + + +/* Generate the indices for items not to be pruned when the internal */ +/* variable is known to have a universe index greater than that of the */ +/* external one. */ +/* It is assumned that arg vector of the internal flex term has a size */ +/* larger than zero. */ +/* As a result of this process, segments of the argument vectors for both */ +/* variables are decided. That for the internal variable is created on the */ +/* current top of heap, while that for the outside variable, each */ +/* argument of which must be a de Bruijn index, is recorded into an integer*/ +/* array which is set by side-effect. */ +/* The number returned by this procedure is the length of both of the */ +/* argument vector segements. Pruning occured when this number is smaller */ +/* than the size of the arg vector of the internal term. */ +static int HOPU_prune(DF_TermPtr args1, int nargs1, DF_TermPtr args2, + int nargs2, int emblev, int *args12) +{ + + int numNotPruned = 0; + AM_heapError(AM_hreg + nargs2 * DF_TM_ATOMIC_SIZE);//max possible size + for (; nargs2 > 0; nargs2--){ + DF_TermPtr tmPtr = DF_termDeref(args2); + if (DF_isConst(tmPtr)) { + int ind = HOPU_constIndex(tmPtr, args1, nargs1, emblev); + if (ind > 0) { + args12[numNotPruned] = ind; //args12 + DF_mkBV(AM_hreg, nargs2); //args22 + AM_hreg += DF_TM_ATOMIC_SIZE; + numNotPruned ++; + HOPU_copyFlagGlb = TRUE; + } //ind == 0 the argument is pruned + } else {//bv + int ind = DF_bvIndex(tmPtr); + if (ind > emblev) { + int newind = HOPU_bvIndex(ind, args1, nargs1, emblev); + if (newind > 0) { + args12[numNotPruned] = newind; //args12 + DF_mkBV(AM_hreg, nargs2); //args22 + AM_hreg += DF_TM_ATOMIC_SIZE; + numNotPruned ++; + if (ind != newind) HOPU_copyFlagGlb = TRUE; + } //newind == 0 the argument is pruned + } else {//ind <= lev + args12[numNotPruned] = ind; //args12 + DF_mkBV(AM_hreg, nargs2); //args22 + AM_hreg += DF_TM_ATOMIC_SIZE; + numNotPruned ++; + } + } //bv + args2 = (DF_TermPtr)(((MemPtr)args2) + DF_TM_ATOMIC_SIZE); + } //for loop + return numNotPruned; +} + +/* When the index of the internal variable is less than or equal to that */ +/* of the external one in the LLambda case, we have to raise the outside */ +/* variable over those constants in the internal list that have smaller */ +/* index and we have to prune other constants and bound variables in this */ +/* list that are not shared. */ +/* It is assumned that the arg vector of the internal flex term has a size */ +/* larger than zero. */ +/* As a result of this process, the argument vectors for both variables */ +/* are decided. That for the outside variable is created on the current */ +/* top of heap, while that for the internal variable, each argument of */ +/* which must be a de Bruijn index, is recorded into an integer array which*/ +/* is set by side-effect. */ +/* The number returned by this procedure is the length of both of the */ +/* argument vectors. Pruning occured when this number is smaller than the */ +/* size of the arg vector of the internal term. */ +/* CHANGES have to be made here if the semantics of local constants are */ +/* changed with respect to polymorphism. */ +static int HOPU_pruneAndRaise(DF_TermPtr args1, int nargs1, DF_TermPtr args2, + int nargs2, int emblev, int *args) +{ + int numNotPruned = 0; + AM_heapError(AM_hreg + nargs2 * DF_TM_ATOMIC_SIZE); //max possible size + for (; nargs2 > 0; nargs2 --){ + DF_TermPtr tmPtr = DF_termDeref(args2); + if (DF_isBV(tmPtr)){ + int ind = DF_bvIndex(tmPtr); + if (ind > emblev) { + int newind = HOPU_bvIndex(ind, args1, nargs1, emblev); + if (newind > 0) { + DF_mkBV(AM_hreg, newind); //args for outside var + AM_hreg += DF_TM_ATOMIC_SIZE; + args[numNotPruned] = nargs2; //args for internal var + numNotPruned ++; + if (ind != newind) HOPU_copyFlagGlb = TRUE; + } // newind == 0, the argument is prubed + } else { //ind <= emblev + DF_mkBV(AM_hreg, ind); //args for outside var + AM_hreg += DF_TM_ATOMIC_SIZE; + args[numNotPruned] = nargs2; //args for internal var + numNotPruned ++; + } + } else { //tmPtr is const + if (DF_constUnivCount(tmPtr) > AM_adjreg){ + int ind = HOPU_constIndex(tmPtr, args1, nargs1, emblev); + if (ind > 0) { + DF_mkBV(AM_hreg, ind); //args for outside var + AM_hreg += DF_TM_ATOMIC_SIZE; + args[numNotPruned] = nargs2; //args for internal var + numNotPruned ++; + HOPU_copyFlagGlb = TRUE; + } //else ind = 0, the argument is pruned + } else { //const uc <= AM_adjreg + if (DF_isTConst(tmPtr)) DF_mkRef(AM_hreg, tmPtr);//args out var + else DF_copyAtomic(tmPtr, AM_hreg); + AM_hreg += DF_TM_ATOMIC_SIZE; + args[numNotPruned] = nargs2; //args for internal var + numNotPruned ++; + } + } + args2 = (DF_TermPtr)(((MemPtr)args2) + DF_TM_ATOMIC_SIZE); + } //for loop + return numNotPruned; +} + +/* Generating the arguments of a pruning substitution for the case when */ +/* when trying to unify two flexible terms of the form */ +/* (F a1 ... an) = lam(k, (F b1 ... bm)) */ +/* The resulted argument vector is created on the current top of heap, and */ +/* the integer returned by this procedure is the length of the argument */ +/* vector resulted from pruning. Pruning takes place if this value is */ +/* smaller that nargs2. */ +/* It is assumed that the sum of n and k is the same as m. */ +/* CHANGES have to be made here if the semantics of local constants are */ +/* changed with respect to polymorphism. */ +static int HOPU_pruneSameVar(DF_TermPtr args1, int nargs1, DF_TermPtr args2, + int nargs2, int lev) +{ + if (nargs2 == 0) return 0; + else { + int numNotPruned = 0; + DF_TermPtr tPtr2; + AM_heapError(AM_hreg + nargs2 * DF_TM_ATOMIC_SIZE); //max possible size + nargs1 = nargs2 - nargs1; //reused nargs1 + for (; nargs2 > nargs1; nargs2 --){ + DF_TermPtr tPtr1 = DF_termDeref(args1); + tPtr2 = DF_termDeref(args2); + if (DF_isBV(tPtr1)){ + int ind = DF_bvIndex(tPtr1) + lev; + if (DF_isBV(tPtr2) && (ind == DF_bvIndex(tPtr2))){ + DF_mkBV(AM_hreg, nargs2); AM_hreg += DF_TM_ATOMIC_SIZE; + numNotPruned++; + if (nargs2 != ind) HOPU_copyFlagGlb = TRUE; + } //else this argument is pruned + } else {// tPtr1 is a constant + if (DF_isConst(tPtr2) && DF_sameConsts(tPtr1, tPtr2)){ + if (DF_isTConst(tPtr2)) { + EM_TRY { + HOPU_typesUnify(DF_constType(tPtr1),DF_constType(tPtr2), + AM_cstTyEnvSize(DF_constTabIndex(tPtr1))); + DF_mkBV(AM_hreg, nargs2); AM_hreg += DF_TM_ATOMIC_SIZE; + numNotPruned++; + HOPU_copyFlagGlb = TRUE; + } EM_CATCH {//remove tys for type unif from the PDL + if (EM_CurrentExnType == EM_FAIL) + AM_resetTypesPDL(); + else EM_RETHROW(); + } //EM_catch + } else {//no type association + DF_mkBV(AM_hreg, nargs2); AM_hreg+=DF_TM_ATOMIC_SIZE; + numNotPruned++; + HOPU_copyFlagGlb = TRUE; + } + }//else pruned + } //tPtr1 is a constant + args1 = (DF_TermPtr)(((MemPtr)args1) + DF_TM_ATOMIC_SIZE); + args2 = (DF_TermPtr)(((MemPtr)args2) + DF_TM_ATOMIC_SIZE); + } //for (; nargs2 > nargs1; nargs2--) + for (; nargs2 > 0; nargs2--){ + tPtr2 = DF_termDeref(args2); + if (DF_isBV(tPtr2) && (DF_bvIndex(tPtr2) == nargs2)){ + DF_mkBV(AM_hreg, nargs2); AM_hreg += DF_TM_ATOMIC_SIZE; + numNotPruned++; + } //else pruned + args2 = (DF_TermPtr)(((MemPtr)args2) + DF_TM_ATOMIC_SIZE); + } //for (; nargs2 > 0; nargs2--) + return numNotPruned; + } //nargs2 != 0 +} + +/* Push a new free variable with given universe count onto the current heap */ +/* top. */ +static void HOPU_pushVarToHeap(int uc) +{ + MemPtr newhtop = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(newhtop); + DF_mkVar(AM_hreg, uc); + AM_hreg = newhtop; +} + +/* Perform substitution to realize pruning and raising for an internal */ +/* variable in the LLambda situation when the variable has an index greater*/ +/* than that of the outside one */ +/* This procedure is also used to perform substitution for flex-flex pairs */ +/* with same variable heads in the LLambda situation. */ +static void HOPU_mkPandRSubst(DF_TermPtr hPtr, DF_TermPtr args, int nargs, + DF_TermPtr vPtr, int nabs) +{ + TR_trailTerm(vPtr); AM_bndFlag = ON; + if (nargs == 0) { + if (nabs == 0) DF_mkRef((MemPtr)vPtr, hPtr); + else DF_mkLam((MemPtr)vPtr, nabs, hPtr); + } else { //nargs > 0 + DF_TermPtr tPtr = (DF_TermPtr)AM_hreg; + AM_heapError(AM_hreg + DF_TM_APP_SIZE); + AM_arityError(nargs); + DF_mkApp(AM_hreg, nargs, hPtr, args); //application body + AM_hreg += DF_TM_APP_SIZE; + AM_embedError(nabs); + if (nabs == 0) DF_mkRef((MemPtr)vPtr, tPtr); + else DF_mkLam((MemPtr)vPtr, nabs, tPtr); + } +} + +/* Perform substitution to realize pruning and raising for an internal */ +/* variable in the LLambda situation when the variable has an index smaller*/ +/* than or equal to that of the outside one */ +/* The arguments of the substitution which should be de Bruijn indices */ +/* are given by an integer array. */ +static void HOPU_mkPrunedSubst(DF_TermPtr hPtr, int *args, int nargs, + DF_TermPtr vPtr, int nabs) +{ + AM_bndFlag = ON; + TR_trailTerm(vPtr); + if (nargs == 0) { + if (nabs == 0) DF_mkRef((MemPtr)vPtr, hPtr); + else DF_mkLam((MemPtr)vPtr, nabs, hPtr); + } else { //nargs > 0; + DF_TermPtr argvec = (DF_TermPtr)AM_hreg, appPtr; + int i; + AM_heapError(AM_hreg + DF_TM_APP_SIZE + nargs * DF_TM_ATOMIC_SIZE); + for (i = 0; i < nargs; i++){//commit bvs in args onto heap + DF_mkBV(AM_hreg, args[i]); + AM_hreg += DF_TM_ATOMIC_SIZE; + } + appPtr = (DF_TermPtr)AM_hreg; + DF_mkApp(AM_hreg, nargs, hPtr, argvec); + AM_hreg += DF_TM_APP_SIZE; + if (nabs == 0) DF_mkRef((MemPtr)vPtr, appPtr); + else DF_mkLam((MemPtr)vPtr, nabs, appPtr); + } +} + +/* Generating the partial structure of a substitution to realize pruning */ +/* and raising for an outside variable in the LLambda situation when the */ +/* variable has an index smaller than that of the internal one. */ +/* The arguments of the susbsitution consists of two segments of de Burijn */ +/* indices, which are given by two integer arrays respectively. */ +static DF_TermPtr HOPU_mkPandRTerm(DF_TermPtr hPtr, int args1[], int nargs1, + int args2[], int nargs2) +{ + if ((nargs1 == 0) && (nargs2 == 0)) return hPtr; + else { + DF_TermPtr args = (DF_TermPtr)AM_hreg, rtPtr; + int nargs = nargs1 + nargs2; //new arity (non-zero) + int i; + AM_arityError(nargs); + AM_heapError(AM_hreg + DF_TM_APP_SIZE + nargs * DF_TM_ATOMIC_SIZE); + for (i = 0; i < nargs1 ; i++){ //commit bvs in a11 onto heap + DF_mkBV(AM_hreg, args1[i]); + AM_hreg += DF_TM_ATOMIC_SIZE; + } + for (i = 0; i < nargs2 ; i++){ //commit bvs in a12 onto heap + DF_mkBV(AM_hreg, args2[i]); + AM_hreg += DF_TM_ATOMIC_SIZE; + } + rtPtr = (DF_TermPtr)AM_hreg; + DF_mkApp(AM_hreg, nargs, hPtr, args); + AM_hreg += DF_TM_APP_SIZE; + return rtPtr; + } +} + +/* Generating the partial structure of a substitution to realize pruning */ +/* and raising for an internal variable in the LLambda situation when the */ +/* variable has an index greater than or equal to that of the outside one. */ +static DF_TermPtr HOPU_mkPrunedTerm(DF_TermPtr hPtr, DF_TermPtr args, int nargs) +{ + if (nargs == 0) return hPtr; + else { + DF_TermPtr rtPtr = (DF_TermPtr)AM_hreg; + AM_heapError(AM_hreg + DF_TM_APP_SIZE); + DF_mkApp(AM_hreg, nargs, hPtr, args); + AM_hreg += DF_TM_APP_SIZE; + return rtPtr; + } +} + +/* Find the (partial) structure of the substitution for a flex head of a */ +/* LLambda term corresponding to an internal flex term which is known to be */ +/* LLambda. The internal free variable is bound to a proper substitution as */ +/* side-effect. +/* The arguments of this procedure are: */ +/* args1 : reference to the argument vector of the outside flex term */ +/* nargs1: number of arguments of the outside flex term */ +/* uc : universe count of the internal free variable */ +/* tPtr2 : refers to the dereference of ABSTRACTION BODY of the internal */ +/* flex term */ +/* fhPtr : refers to the head of the internal flex term */ +/* args2 : refers to the argument vector of the internal flex term */ +/* nargs2: number of arguments of the internal flex term */ +/* lev : the abstraction context of the internal flex term */ +/* Note that the outside free variable and its universe count are assumed to */ +/* be given by the global variables (registers) AM_vbbreg and AM_adjreg. */ +static DF_TermPtr HOPU_flexNestedLLambda(DF_TermPtr args1, int nargs1, int uc, + DF_TermPtr tPtr2, DF_TermPtr fhPtr, DF_TermPtr args2, + int nargs2, int lev) +{ + DF_TermPtr bnd; //(partial) binding for the outside free var + MemPtr oldhtop = AM_hreg; + DF_TermPtr heapArgs = (DF_TermPtr)AM_hreg; + if (AM_adjreg < uc){ + int *args11 = NULL, *args12 = NULL; //hold args of bnd of the outside v + int nargs11 = 0, nargs12 = 0; + if (nargs1 != 0) { + args11 = (int*)EM_malloc(nargs1 * sizeof(int)); + nargs11 = HOPU_raise(uc, args1, nargs1, lev, args11); + } + if (nargs2 != 0) { + args12 = (int*)EM_malloc(nargs2 * sizeof(int)); + nargs12 = HOPU_prune(args1, nargs1, args2, nargs2, lev, args12); + } + if ((nargs11 == 0) && (nargs12 == nargs2)) {//neither raised nor pruned + AM_hreg = oldhtop; //the internal free var remains unbound + TR_trailTerm(fhPtr); AM_bndFlag = ON; + DF_modVarUC(fhPtr, AM_adjreg); + if (HOPU_copyFlagGlb) + bnd = HOPU_mkPandRTerm(fhPtr, args11, nargs11, args12, nargs12); + else bnd = tPtr2; + } else { //raised or pruned + DF_TermPtr newVar = (DF_TermPtr)AM_hreg; + HOPU_pushVarToHeap(AM_adjreg); + HOPU_mkPandRSubst(newVar, heapArgs, nargs11+nargs12, fhPtr, nargs2); + bnd = HOPU_mkPandRTerm(newVar, args11, nargs11, args12, nargs12); + HOPU_copyFlagGlb = TRUE; + } + if (nargs1 != 0) free(args11); if (nargs2 != 0) free(args12); + } else { //AM_adjreg >= uc + int *newargs2 = NULL; + int nnewargs2 = 0; + if (nargs2 != 0) { + newargs2 = (int*)EM_malloc(nargs2 * sizeof(int)); + nnewargs2 = HOPU_pruneAndRaise(args1,nargs1,args2,nargs2,lev, + newargs2); + } + if (nnewargs2 == nargs2){//not pruned + if (HOPU_copyFlagGlb) + bnd = HOPU_mkPrunedTerm(fhPtr, heapArgs, nnewargs2); + else { AM_hreg = oldhtop; bnd = tPtr2; } + } else { //pruned + DF_TermPtr newVar = (DF_TermPtr)AM_hreg; + HOPU_pushVarToHeap(uc); + HOPU_mkPrunedSubst(newVar, newargs2, nnewargs2, fhPtr, nargs2); + bnd = HOPU_mkPrunedTerm(newVar, heapArgs, nnewargs2); + HOPU_copyFlagGlb = TRUE; + } + if (nargs2 != 0) free(newargs2); + } //AM_adjreg >= uc + return bnd; +} + +/* Checking the arguments of a flex (non-LLambda) term to see whetehr a */ +/* free variable same as that currently in the AM_vbbreg register, a free */ +/* variable with higher univ count than that currently in the AM_adjreg */ +/* register, a constant with higher univ count than that currently in */ +/* AM_adjreg, or a de Bruijn index bound by abstractions over the variable */ +/* for which a substitution is being constructed occurs. */ +/* If one of the situations occurs, exception is raised. */ +static void HOPU_flexCheck(DF_TermPtr args, int nargs, int emblev) +{ + for (; nargs > 0; nargs --){ + int nemblev; + HN_hnorm(args); + nemblev = emblev + AM_numAbs; + if (AM_rigFlag){ + if (DF_isBV(AM_head)) { + if (DF_bvIndex(AM_head) > nemblev) EM_THROW(EM_FAIL); + } else { + if (DF_isConst(AM_head)&&(DF_constUnivCount(AM_head)>AM_adjreg)) + EM_THROW(EM_FAIL); + } //otherwise succeeds + } else { //AM_rigFlag == FALSE + if ((AM_vbbreg == AM_head) || (DF_fvUnivCount(AM_head)>AM_adjreg)) + EM_THROW(EM_FAIL); + } + HOPU_flexCheck(AM_argVec, AM_numArgs, nemblev); + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } +} + +/* This version of flexCheckC is needed in the compiled form of pattern */ +/* unification. The essential difference from the other version is that the */ +/* variable being bound is already partially bound to a structure. */ +/* The difference from the other procedure is the head normalization */ +/* procedure invoked is one performs the occurs checking on partially bound */ +/* variables */ +static void HOPU_flexCheckC(DF_TermPtr args, int nargs, int emblev) +{ + for (; nargs > 0; nargs--){ + int nemblev; + HN_hnormOcc(args); + nemblev = emblev + AM_numAbs; + if (AM_rigFlag) { + if (DF_isBV(AM_head)) { + if (DF_bvIndex(AM_head) > nemblev) EM_THROW(EM_FAIL); + } else { + if (DF_isConst(AM_head)&&(DF_constUnivCount(AM_head)>AM_adjreg)) + EM_THROW(EM_FAIL); + } //otherwise succeeds + } else //AM_rigFlag == FALSE + if (DF_fvUnivCount(AM_head) > AM_adjreg) EM_THROW(EM_FAIL); + + HOPU_flexCheckC(AM_argVec, AM_numArgs, nemblev); + args = (DF_TermPtr)(((MemPtr)args)+DF_TM_ATOMIC_SIZE); + } +} + +/* Generating a term on the top of heap which is to be added into a */ +/* disagreement pair. */ +/* The term has the following structure: */ +/* (h [|a1, 0, lev, nil|] ... [|an, 0, lev, nil|] #lev ... #1) */ +/* It is assumed that nargs and lev are not equal to zero. */ +static void HOPU_mkTermNLL(DF_TermPtr h, DF_TermPtr args, int nargs, int lev) +{ + int newArity = nargs + lev; + MemPtr newArgs = AM_hreg + DF_TM_APP_SIZE; //spare app (head) size on heap + AM_arityError(newArity); + AM_heapError(AM_hreg + nargs*DF_TM_SUSP_SIZE + newArity*DF_TM_ATOMIC_SIZE + + DF_TM_APP_SIZE); + DF_mkApp(AM_hreg, newArity, h, (DF_TermPtr)newArgs); + AM_hreg += (DF_TM_APP_SIZE + newArity * DF_TM_ATOMIC_SIZE);//alloc arg vec + for (; nargs > 0; nargs--){ //[|ai, 0, lev, nil|], for i <= nargs + DF_mkRef(newArgs, (DF_TermPtr)AM_hreg); + DF_mkSusp(AM_hreg, 0, lev, DF_termDeref(args), DF_EMPTY_ENV); + newArgs += DF_TM_ATOMIC_SIZE; AM_hreg += DF_TM_SUSP_SIZE; + args = (DF_TermPtr)(((MemPtr)args) + DF_TM_ATOMIC_SIZE); + } + for (; lev > 0; lev--){ //#i, for i <= lev + DF_mkBV(newArgs, lev); + newArgs += DF_TM_ATOMIC_SIZE; + } +} + +/* Generating a partial subsitution for the free head of a LLambda term */ +/* corresponding to an internal flex term which is known to be non-LLambda.*/ +/* The partial substitution is of form: */ +/* (h #n ... #1) */ +/* It is assumed that n is not equal to zero. */ +static void HOPU_mkSubstNLL(DF_TermPtr h, int n) +{ + AM_arityError(n); + AM_heapError(AM_hreg + DF_TM_APP_SIZE + n * DF_TM_ATOMIC_SIZE); + DF_mkApp(AM_hreg, n, h, (DF_TermPtr)(AM_hreg + DF_TM_APP_SIZE)); + AM_hreg += DF_TM_APP_SIZE; + for (; n > 0; n--){ + DF_mkBV(AM_hreg, n); + AM_hreg += DF_TM_ATOMIC_SIZE; + } +} + +/* Try to solve G = ...(F a1 ... an)..., where F and G are different free */ +/* variables, and (F a1 ... an) is non-LLambda. */ +/* Either G is bound to (F a1 ... an) or an exception is raised. In the */ +/* latter case, the caller of this function is responsible to add a */ +/* disagreement pair to the live list. */ +static void HOPU_bndVarNestedFlex(DF_TermPtr fhPtr, DF_TermPtr args, int nargs, + int lev) +{ + HOPU_flexCheck(args, nargs, lev); + if (DF_fvUnivCount(fhPtr) > AM_adjreg) { + TR_trailTerm(fhPtr); + AM_bndFlag = ON; + DF_modVarUC(fhPtr, AM_adjreg); + } +} + +/* Try to find the (partial) structure of the substitution for a flex head */ +/* of a LLambda term corresponding to an internal flex term which is not */ +/* known to be LLambda. */ +/* If the internal flex term is LLambda, HOPU_flexNestedLLambda is invoked */ +/* to generate the (parital) substitution for the outside variable, and */ +/* perform proper substitutions on the internal free variable if necessary. */ +/* Otherwise, a disagreement pair is added into the live list. */ +static DF_TermPtr HOPU_flexNestedSubst(DF_TermPtr args1, int nargs1, + DF_TermPtr fhPtr, DF_TermPtr args2, + int nargs2, DF_TermPtr tmPtr, int emblev) +{ + DF_TermPtr bnd; + int varuc = DF_fvUnivCount(fhPtr); + if (HOPU_isLLambda(varuc, nargs2, args2)){ + if (fhPtr == AM_vbbreg) EM_THROW(EM_FAIL); //occurs check + bnd = HOPU_flexNestedLLambda(args1, nargs1, varuc, tmPtr, fhPtr, args2, + nargs2, emblev); + } else {// the internal flex term is not LLambda: delay (opt possible) + DF_TermPtr newVar; + DF_TermPtr newTerm; + Boolean found = FALSE; + if ((fhPtr != AM_vbbreg) && (nargs1 == 0)) { + EM_TRY{ + HOPU_bndVarNestedFlex(fhPtr, args2, nargs2, emblev); + bnd = tmPtr; + found = TRUE; + } EM_CATCH {if (EM_CurrentExnType != EM_FAIL) EM_RETHROW();} + } + if (!found) { + newVar = (DF_TermPtr)AM_hreg; + HOPU_pushVarToHeap(AM_adjreg); + HOPU_copyFlagGlb = TRUE; + if ((nargs1 == 0) && (emblev == 0)) { + bnd = newVar; + AM_addDisPair(bnd, tmPtr); + } else { + newTerm = (DF_TermPtr)AM_hreg; + HOPU_mkTermNLL(newVar, args1, nargs1, emblev); + AM_addDisPair(newTerm, tmPtr); + bnd = (DF_TermPtr)AM_hreg; + HOPU_mkSubstNLL(newVar, emblev + nargs1); + } + } + } + return bnd; +} + +/* This version of flexNestedSubst is needed in the compiled form of pattern */ +/* unification. The essential difference from the other version is that the */ +/* variable being bound is already partially bound to a structure. */ +/* The difference from the other procedure is first the head normalization */ +/* process invokded is one performs occurs checking on partially bound */ +/* variables, and second, the "top-level" flexible term is a free variable: */ +/* so there is no need to distinguish whether the other flex term is Llambda */ +/* or not: the substitution can be found by an invocation of flexCheckC */ +DF_TermPtr HOPU_flexNestedSubstC(DF_TermPtr fhPtr, DF_TermPtr args, int nargs, + DF_TermPtr tmPtr, int emblev) +{ + DF_TermPtr bnd, newVar, newTerm; + int varuc; + Boolean found = FALSE; + + EM_TRY { + HOPU_flexCheckC(args, nargs, emblev); + if (DF_fvUnivCount(fhPtr) > AM_adjreg){ + TR_trailTerm(fhPtr); + AM_bndFlag = ON; + DF_modVarUC(fhPtr, AM_adjreg); + } + bnd = tmPtr; + found = TRUE; + } EM_CATCH { if (EM_CurrentExnType != EM_FAIL) EM_RETHROW(); } + + if (!found) { + varuc = DF_fvUnivCount(fhPtr); + if (HOPU_isLLambda(varuc, nargs, args)){ + bnd = HOPU_flexNestedLLambda(NULL, 0, varuc, tmPtr, fhPtr, args, nargs, + emblev); + } else {//otherwise delay this pair onto the live list + HOPU_copyFlagGlb = TRUE; + newVar = (DF_TermPtr)AM_hreg; + HOPU_pushVarToHeap(AM_adjreg); + if (emblev == 0) { + bnd = newVar; + AM_addDisPair(bnd, tmPtr); + } else { + newTerm = (DF_TermPtr)AM_hreg; + HOPU_mkTermNLL(newVar, NULL, 0, emblev); + AM_addDisPair(newTerm, tmPtr); + bnd = (DF_TermPtr)AM_hreg; + HOPU_mkSubstNLL(newVar, emblev); + } + } + } + return bnd; +} + +/* Try to solve G = (F a1 ... an), where F and G are different free */ +/* variables, and (F a1 ... an) is non-LLambda. */ +/* Either G is bound to (F a1 ... an) or an exception is raised. In the */ +/* latter case, the caller of this function is responsible to add a */ +/* disagreement pair to the live list. */ +static void HOPU_bndVarFlex(DF_TermPtr vPtr, DF_TermPtr fPtr, DF_TermPtr fhPtr, + DF_TermPtr args, int nargs) +{ + AM_vbbreg = vPtr; AM_adjreg = DF_fvUnivCount(vPtr); + HOPU_flexCheck(args, nargs, 0); + if (DF_fvUnivCount(fhPtr) > AM_adjreg) { + TR_trailTerm(fPtr); + AM_bndFlag = ON; + DF_modVarUC(fhPtr, AM_adjreg); + } + TR_trailTerm(vPtr); + AM_bndFlag = ON; + DF_mkRef((MemPtr)vPtr, fPtr); +} + +/* Try to solve (F a1 ... an) = lam(k, (G b1 ... bm)), where F and G are */ +/* both free variables. */ +/* The arguments are: */ +/* tPtr1 : reference to the ABSTRACTION BODY of the first flex term */ +/* h1 : reference to the flex head of the first term */ +/* nargs1: number of arguments of the first flex term */ +/* args1 : reference to the argument vector of the first flex term */ +/* tPtr2 : reference to the ABSTRACTION BODY of the second flex term */ +/* h2 : reference to the flex head of the second flex term */ +/* nargs2: number of arguments of the second flex term */ +/* args2 : reference to the argument vector of the second flex term */ +/* lev : abstraction context of the second term with respect to the */ +/* first one. */ +/* */ +/* Non-Llambda pairs could be encountered during this process, and in */ +/* this situation, the pair is delayed onto the disagreement list. */ +static void HOPU_flexMkSubst(DF_TermPtr tPtr1, DF_TermPtr h1, int nargs1, + DF_TermPtr args1, DF_TermPtr tPtr2, DF_TermPtr h2, + int nargs2, DF_TermPtr args2, int lev) +{ + int uc = DF_fvUnivCount(h1); + if (HOPU_isLLambda(uc, nargs1, args1)){ //the first term is LLambda + DF_TermPtr bndBody; + if (h1 == h2) { //same variable (comparing addresses) + if (HOPU_isLLambda(uc, nargs2, args2)) {//same var common uc + MemPtr oldhtop = AM_hreg; + DF_TermPtr newArgs = (DF_TermPtr)AM_hreg; + HOPU_copyFlagGlb = FALSE; + nargs1 = HOPU_pruneSameVar(args1, nargs1, args2, nargs2, lev); + if ((nargs1 != nargs2) || HOPU_copyFlagGlb){ + DF_TermPtr newVar = (DF_TermPtr)AM_hreg; + HOPU_pushVarToHeap(uc); + HOPU_mkPandRSubst(newVar, newArgs, nargs1, h1, nargs2); + } else AM_hreg = oldhtop; //unbound + } else { //(F a1 ... an)[ll] = (lam(k, (F b1 ... bm)))[non-ll] + if (lev == 0) AM_addDisPair(tPtr1, tPtr2); + else { + MemPtr nhtop = AM_hreg + DF_TM_LAM_SIZE; + DF_TermPtr tmPtr = (DF_TermPtr)AM_hreg; + AM_heapError(AM_hreg); + DF_mkLam(AM_hreg, lev, tPtr2); + AM_hreg = nhtop; + AM_addDisPair(tPtr1, tmPtr); + } //(lev != 0) + } //tPtr2 not LLambda + } else { //different variable + int nabs; + AM_vbbreg = h1; AM_adjreg = uc; //set regs for occ + HOPU_copyFlagGlb = FALSE; + bndBody = HOPU_flexNestedSubst(args1, nargs1, h2, args2, nargs2, + tPtr2, lev); + nabs = lev + nargs1; + TR_trailTerm(h1); AM_bndFlag = ON; + if (nabs == 0) DF_mkRef((MemPtr)h1, bndBody); + else { + AM_embedError(nabs); + DF_mkLam((MemPtr)h1, nabs, bndBody); + } + } //different variable + } else { //the first term is non-LLambda + Boolean found = FALSE; + if ((nargs2 == 0) && (lev == 0) && (h1 != h2)) { // (F t1 ... tm) = G + EM_TRY{ + HOPU_bndVarFlex(h2, tPtr1, h1, args1, nargs1); + found = TRUE; + } EM_CATCH { + if (EM_CurrentExnType != EM_FAIL) EM_RETHROW(); + } + } + if (!found) { + if (lev == 0) AM_addDisPair(tPtr1, tPtr2); + else { + MemPtr nhtop = AM_hreg + DF_TM_LAM_SIZE; + DF_TermPtr tmPtr = (DF_TermPtr)AM_hreg; + AM_heapError(AM_hreg); + DF_mkLam(AM_hreg, lev, tPtr2); + AM_hreg = nhtop; + AM_addDisPair(tPtr1, tmPtr); + } //(lev != 0) + } + } //the first term is non-LLambda +} + +/* The counterpart of HOPU_flexMkSubst invoked from HOPU_patternUnifyPair. */ +/* Care is taken to avoid making a reference to a stack address in binding */ +/* and creating disagreement pairs. */ +/* It is assumed that the first term (F a1 ... an) given by its */ +/* is not embedded in any abstractions. */ +static void HOPU_flexMkSubstGlb(DF_TermPtr tPtr1, DF_TermPtr h1, int nargs1, + DF_TermPtr args1, + DF_TermPtr tPtr2, DF_TermPtr h2, int nargs2, + DF_TermPtr args2, + DF_TermPtr topPtr2, int lev) +{ + int uc = DF_fvUnivCount(h1); + if (HOPU_isLLambda(uc, nargs1, args1)) { //the first term is LLambda + DF_TermPtr bndBody; + if (h1 == h2) { //same variable (comparing addresses) + if (HOPU_isLLambda(uc, nargs2, args2)){//same var; common uc + MemPtr oldhtop = AM_hreg; + DF_TermPtr newArgs = (DF_TermPtr)AM_hreg; + HOPU_copyFlagGlb = FALSE; + nargs1 = HOPU_pruneSameVar(args1, nargs1, args2, nargs2, lev); + if ((nargs1 != nargs2) || HOPU_copyFlagGlb) { + DF_TermPtr newVar = (DF_TermPtr)AM_hreg; + HOPU_pushVarToHeap(uc); + HOPU_mkPandRSubst(newVar, newArgs, nargs1, h1, nargs2); + } else AM_hreg = oldhtop; //variable remain unbound + } else { //(F a1 ... an)[ll] = (lam(k, (F b1 ... bm)))[non-ll] + //non-LLambda term must locate on the heap + if (nargs1 == 0) tPtr1 = HOPU_globalizeFlex(tPtr1); + if (lev == 0) AM_addDisPair(tPtr1, tPtr2); + else AM_addDisPair(tPtr1, DF_termDeref(topPtr2)); + } //tPtr2 not LLambda + } else { //different variable + int nabs; + AM_vbbreg = h1; AM_adjreg = uc; //set regs for occ + HOPU_copyFlagGlb = FALSE; + bndBody = HOPU_flexNestedSubst(args1, nargs1, h2, args2, nargs2, + tPtr2, lev); + nabs = nargs1 + lev; + TR_trailTerm(h1); AM_bndFlag = ON; + if (HOPU_copyFlagGlb == FALSE) + bndBody = HOPU_globalizeFlex(bndBody); + if (nabs == 0) DF_mkRef((MemPtr)h1, bndBody); + else { + AM_embedError(nabs); + DF_mkLam((MemPtr)h1, nabs, bndBody); + } + } + } else {//the first term is non-LLambda (must locate on heap) + Boolean found = FALSE; + if ((nargs2 == 0) && (lev == 0) && (h1 != h2)) {//(F t1...tm)[nll] = G + EM_TRY { + HOPU_bndVarFlex(h2, tPtr1, h1, args1, nargs1); + found = TRUE; + } EM_CATCH { + if (EM_CurrentExnType == EM_FAIL) + tPtr2 = HOPU_globalizeFlex(tPtr2); + else EM_RETHROW(); + } + } + if (!found) { + if (lev == 0) AM_addDisPair(tPtr1, tPtr2); + else AM_addDisPair(tPtr1, DF_termDeref(topPtr2)); + } + } //the first term is non-LLambda +} + + +/***************************************************************************/ +/* BINDING FOR FLEX-RIGID */ +/* */ +/* Auxiliary functions for solving flex-rigid pairs. */ +/* Non-LLambda pairs are delayed onto the disagreement list. */ +/***************************************************************************/ +/* Try to find the (partial) binding of the head of a flex term correponding */ +/* to a rigid atom during the process of unifying the flex term with a */ +/* rigid one. The global variable HOPU_copyFlagGlb is used to indicate */ +/* whether a new term is created during this process. */ +/* Note it is assumed that rPtr refers to the dereference of a rigid atom */ +/* or cons. */ +static DF_TermPtr HOPU_getHead(DF_TermPtr rPtr, DF_TermPtr args, int nargs, + int emblev) +{ + DF_TermPtr rtPtr; + switch(DF_termTag(rPtr)){ + case DF_TM_TAG_CONST:{ + if (DF_constUnivCount(rPtr) > AM_adjreg){ + MemPtr newhtop; + int ind = HOPU_constIndex(rPtr, args, nargs, emblev); + if (ind == 0) EM_THROW(EM_FAIL); //occurs-check + AM_embedError(ind); + newhtop = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(newhtop); + HOPU_copyFlagGlb = TRUE; //new structure is created + rtPtr = (DF_TermPtr)AM_hreg; //create a db on the heap top + DF_mkBV(AM_hreg, ind); + AM_hreg = newhtop; + } else rtPtr = rPtr; //DF_constUnivCount(rPtr <= AM_adjreg) + break; + } + case DF_TM_TAG_BVAR: { + int dbInd = DF_bvIndex(rPtr); + if (dbInd > emblev){ + int ind = HOPU_bvIndex(dbInd, args, nargs, emblev); + if (ind == 0) EM_THROW(EM_FAIL); //occurs-check + AM_embedError(ind); + if (ind == dbInd) rtPtr = rPtr; //use the old db term + else { //create a db on the heap top + MemPtr newhtop = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(newhtop); + HOPU_copyFlagGlb = TRUE; //new structure is created + rtPtr = (DF_TermPtr)AM_hreg; + DF_mkBV(AM_hreg, ind); + AM_hreg = newhtop; + } + } else rtPtr = rPtr; //dbInd <= emlev + break; + } + default: { rtPtr = rPtr; break;} //other rigid head: cons,nil,int,fl,str + } //switch + return rtPtr; +} + +/* Create a new cons or app term on the current heap top. */ +static void HOPU_mkConsOrApp(DF_TermPtr tmPtr, DF_TermPtr funcPtr, + DF_TermPtr argvec, int nargs) +{ + MemPtr newhtop; + if (DF_isCons(tmPtr)) { + newhtop = AM_hreg + DF_TM_CONS_SIZE; + AM_heapError(newhtop); + DF_mkCons(AM_hreg, argvec); + } else {// application + newhtop = AM_hreg + DF_TM_APP_SIZE; + AM_heapError(newhtop); + DF_mkApp(AM_hreg, nargs, funcPtr, argvec); + } + AM_hreg = newhtop; +} + +/* Try to find the (partial) binding of the head of a flex term when */ +/* unifying it with a rigid term possible under abstractions. */ +/* The arguments are: */ +/* fargs: reference to the arguments of the flex term */ +/* fnargs: number of arguments of the flex term */ +/* rhPtr: reference to the rigid head */ +/* rPtr: reference to the ABSTRACTION BODY of the rigid term */ +/* rargs: reference to the arguments of the rigid term */ +/* rnargs: number of arguments of the rigid term */ +/* emblev: abstraction context of the rigid term */ +/* The global variable HOPU_copyFlagGlb is used to indicate whether new */ +/* term is created in this process. */ +/* Note that if the rigid term is app or cons, it is first assumed that */ +/* a new argument vector is to be created. However, after all the args in */ +/* the binding are calculated, a checking is made on whether this is */ +/* really necessary. If it is not, the old arg vector is used, and the new */ +/* one is abandoned. (Heap space for it is deallocated.) */ +/* It is assumed that the flexible head and its universe count are */ +/* in registers AM_vbbreg and AM_adjreg. */ +static DF_TermPtr HOPU_rigNestedSubst(DF_TermPtr fargs, int fnargs, + DF_TermPtr rhPtr, DF_TermPtr rPtr, + DF_TermPtr rargs, int rnargs, int emblev) +{ + rhPtr = HOPU_getHead(rhPtr, fargs, fnargs, emblev); //head of the binding + if (rnargs == 0) return rhPtr; //the rigid term is atomic + else { //the rigid term is cons or app + Boolean myCopyFlagHead = HOPU_copyFlagGlb, myCopyFlagArgs = FALSE; + int i; + MemPtr oldHreg = AM_hreg; //the old heap top + MemPtr argLoc = AM_hreg; //arg vector location + DF_TermPtr newArgs = (DF_TermPtr)AM_hreg; //new argument vector + DF_TermPtr oldArgs = rargs; //old argument vector + AM_heapError(AM_hreg + rnargs * DF_TM_ATOMIC_SIZE); + AM_hreg += rnargs * DF_TM_ATOMIC_SIZE; //allocate space for argvec + HOPU_copyFlagGlb = FALSE; + for (i = 0; i < rnargs; i++){ + DF_TermPtr bnd; + int nabs; + MemPtr tmpHreg = AM_hreg; + HN_hnorm(rargs); nabs = AM_numAbs; //dereference of hnf + if (AM_hreg != tmpHreg) {myCopyFlagArgs = TRUE; } + + if (AM_rigFlag){ + bnd = HOPU_rigNestedSubst(fargs, fnargs, AM_head, + HOPU_lamBody(rargs), AM_argVec, AM_numArgs, nabs+emblev); + } else { //AM_rigFlag = FALSE + bnd = HOPU_flexNestedSubst(fargs, fnargs, AM_head, AM_argVec, + AM_numArgs, HOPU_lamBody(rargs), nabs+emblev); + } + if (nabs == 0) DF_mkRef(argLoc, bnd); //compact atomic?? + else DF_mkLam(argLoc, nabs, bnd); + argLoc += DF_TM_ATOMIC_SIZE; //note: abs has atomic size + if (HOPU_copyFlagGlb) {myCopyFlagArgs=TRUE; HOPU_copyFlagGlb=FALSE;} + rargs = (DF_TermPtr)(((MemPtr)rargs)+DF_TM_ATOMIC_SIZE); //next arg + } //for loop + if (myCopyFlagArgs) { + DF_TermPtr tmPtr = (DF_TermPtr)AM_hreg; //new cons or app + HOPU_mkConsOrApp(rPtr, rhPtr, newArgs, rnargs); + HOPU_copyFlagGlb = TRUE; + return tmPtr; + } else { //myCopyFlagBody == FALSE + AM_hreg = oldHreg; //deallocate space for the argument vector + //note no new terms are created form any argument + if (myCopyFlagHead){ + DF_TermPtr tmPtr = (DF_TermPtr)AM_hreg; //new cons or app + HOPU_mkConsOrApp(rPtr, rhPtr, oldArgs, rnargs); + HOPU_copyFlagGlb = TRUE; + return tmPtr; + } else return rPtr; //myCopyFlagHead==FALSE, myCopyFlagArgs==FALSE + } + }//rnargs > 0 +} + +/* This version of rigNestedSubstC is needed in the compiled form of pattern */ +/* unification. The essential difference from the other version is that the */ +/* variable being bound is already partially bound to a structure. */ +/* The difference from the other procedure is first the head normalization */ +/* procedure invoked is one performs the occurs checking on partially bound */ +/* variables, and second, the incoming flexible term is in fact a free */ +/* variable. */ +DF_TermPtr HOPU_rigNestedSubstC(DF_TermPtr rhPtr, DF_TermPtr rPtr, + DF_TermPtr rargs, int rnargs, int emblev) +{ + rhPtr = HOPU_getHead(rhPtr, NULL, 0, emblev); + if (rnargs == 0) return rhPtr; + else { + Boolean myCopyFlagHead = HOPU_copyFlagGlb, myCopyFlagArgs = FALSE; + int i; + MemPtr oldHreg = AM_hreg; //the old heap top + MemPtr argLoc = AM_hreg; //arg vector location + DF_TermPtr newArgs = (DF_TermPtr)AM_hreg; //new arg vector + DF_TermPtr oldArgs = rargs; //old arg vector + AM_heapError(AM_hreg + rnargs * DF_TM_ATOMIC_SIZE); + AM_hreg += rnargs * DF_TM_ATOMIC_SIZE; //alloc space for new args + HOPU_copyFlagGlb = FALSE; + for (i = 0; i < rnargs; i++) { + DF_TermPtr bnd; + int nabs; + MemPtr tmpHreg = AM_hreg; + HN_hnormOcc(rargs); nabs = AM_numAbs; + if (tmpHreg != AM_hreg) {myCopyFlagArgs = TRUE; } + if (AM_rigFlag) + bnd = HOPU_rigNestedSubstC(AM_head, HOPU_lamBody(rargs), + AM_argVec, AM_numArgs, nabs+emblev); + else //AM_rigFlag == FALSE + bnd = HOPU_flexNestedSubstC(AM_head, AM_argVec, AM_numArgs, + HOPU_lamBody(rargs), nabs+emblev); + + if (nabs == 0) DF_mkRef(argLoc, bnd); + else DF_mkLam(argLoc, nabs, bnd); + + argLoc += DF_TM_ATOMIC_SIZE; + if (HOPU_copyFlagGlb) {myCopyFlagArgs=TRUE; HOPU_copyFlagGlb=FALSE;} + rargs = (DF_TermPtr)(((MemPtr)rargs)+DF_TM_ATOMIC_SIZE); + } //for loop + if (myCopyFlagArgs) { + DF_TermPtr tmPtr = (DF_TermPtr)AM_hreg; //new cons or app + HOPU_mkConsOrApp(rPtr, rhPtr, newArgs, rnargs); + HOPU_copyFlagGlb = TRUE; + return tmPtr; + } else { //myCopyFlagArgs == FALSE + AM_hreg = oldHreg;//deallocate space for arg vector + if (myCopyFlagHead) { + DF_TermPtr tmPtr = (DF_TermPtr)AM_hreg; + HOPU_mkConsOrApp(rPtr, rhPtr, oldArgs, rnargs); + HOPU_copyFlagGlb = TRUE; + return tmPtr; + } else return rPtr; ////myCopyFlagHead==FALSE, myCopyFlagArgs==FALSE + } + }//rnargs > 0 +} + +/* Try to solve (F a1 ... an) = lam(k, (r b1 ... bm)), where r is rigid. */ +/* The arguments are: */ +/* fPtr : reference to the ABSTRACTION BODY of the flex term */ +/* fhPtr : reference to the flex head */ +/* fnargs: number of arguments of the flex term */ +/* fargs : reference to the argument vector of the flex term */ +/* rPtr : reference to the ABSTRACTION BODY of the rigid term */ +/* rhPtr : reference to the rigid head (Note it could be cons) */ +/* rnargs: number of arguments of the rigid term */ +/* rargs : reference to the argument vector of the rigid term */ +/* */ +/* Non-Llambda pairs could be encountered during this process, and in */ +/* this situation, the pair is delayed onto the disagreement list. */ +static void HOPU_rigMkSubst(DF_TermPtr fPtr, DF_TermPtr fhPtr, int fnargs, + DF_TermPtr fargs, DF_TermPtr rPtr, DF_TermPtr rhPtr, + int rnargs, DF_TermPtr rargs, int emblev) +{ + int uc = DF_fvUnivCount(fhPtr); + if (HOPU_isLLambda(uc, fnargs, fargs)){//Llambda pattern + DF_TermPtr bndBody; //abs body of bnd of the fv + int nabs; + + AM_vbbreg = fhPtr; AM_adjreg = uc; //set regs for occurs check + HOPU_copyFlagGlb = FALSE; + bndBody = HOPU_rigNestedSubst(fargs, fnargs, rhPtr, rPtr, + rargs, rnargs, emblev); + nabs = emblev + fnargs; //# abs in the front of the binding + TR_trailTerm(fhPtr); AM_bndFlag = ON; + if (nabs == 0) DF_mkRef((MemPtr)fhPtr, bndBody); + else { + AM_embedError(nabs); + DF_mkLam((MemPtr)fhPtr, nabs, bndBody); + } + } else { //non-Llambda pattern + if (emblev == 0) AM_addDisPair(fPtr, rPtr); + else { + MemPtr nhtop = AM_hreg + DF_TM_LAM_SIZE; + DF_TermPtr tmPtr = (DF_TermPtr)AM_hreg; + AM_heapError(AM_hreg); + DF_mkLam(AM_hreg, emblev, rPtr); + AM_hreg = nhtop; + AM_addDisPair(fPtr, tmPtr); + } // (emblev != 0) + } //non-LLambda pattern +} + +/* The counter part of HOPU_rigMkSubst invoked by HOPU_patternUnifyPair. */ +/* Care is taken to avoid making a reference to a register/stack address in */ +/* binding and creating disagreement pair. */ +/* It is assumed that the pair of terms are not embedded in any abstractions*/ +/* ie. (F a1 ... an) = (r b1 ... bm) */ +/* Note both fPtr and rPtr are not dereferenced. */ +static void HOPU_rigMkSubstGlb(DF_TermPtr fPtr, DF_TermPtr fhPtr, int fnargs, + DF_TermPtr fargs, + DF_TermPtr rPtr, DF_TermPtr rhPtr, int rnargs, + DF_TermPtr rargs) +{ + int uc = DF_fvUnivCount(fhPtr); + if (HOPU_isLLambda(uc, fnargs, fargs)) { //LLambda pattern + DF_TermPtr bndBody; + AM_vbbreg = fhPtr; AM_adjreg = uc; + HOPU_copyFlagGlb = FALSE; + bndBody = HOPU_rigNestedSubst(fargs, fnargs, rhPtr, DF_termDeref(rPtr), + rargs, rnargs, 0); + TR_trailTerm(fhPtr); AM_bndFlag = ON; + if (HOPU_copyFlagGlb) {//bndBody must locate on the heap + if (fnargs == 0) DF_mkRef((MemPtr)fhPtr, bndBody); + else { + AM_embedError(fnargs); + DF_mkLam((MemPtr)fhPtr, fnargs, bndBody); + } + } else { //HOPU_copyFlagGlb == FALSE + /* //note: rPtr is the undereferenced rigid term; in this case, + // it is assumed rPtr cannot be a reference to the stack. + // This assumption should be ensured by the fact that atomic + // rigid terms on stack are alway copied into registers in + // binding. + if (fnargs == 0) DF_copyAtomic(rPtr, (MemPtr)fhPtr); */ + if (fnargs == 0) HOPU_globalizeCopyRigid(bndBody, fhPtr); + else { + bndBody = HOPU_globalizeRigid(bndBody); + AM_embedError(fnargs); + DF_mkLam((MemPtr)fhPtr, fnargs, bndBody); + } + } //HOPU_copyFlagGlb == FALSE + } else //non_LLambda flex (must locate on the heap) + AM_addDisPair(DF_termDeref(fPtr), + HOPU_globalizeRigid(DF_termDeref(rPtr))); +} + +/***************************************************************************/ +/* TERM SIMPLIFICATION (RIGID-RIGID) */ +/* */ +/* Auxiliary functions for solving rigid-rigid pairs. */ +/***************************************************************************/ + +/* Matching heads of two rigid terms. Eta-expansion is considered when */ +/* necessary. It is assumed that the heads have been dereferenced. */ +static void HOPU_matchHeads(DF_TermPtr hPtr1, DF_TermPtr hPtr2, int nabs) +{ + switch(DF_termTag(hPtr1)){ + case DF_TM_TAG_CONST:{ + if (!(DF_isConst(hPtr2) && (DF_sameConsts(hPtr1, hPtr2)))) + EM_THROW(EM_FAIL); + if (DF_isTConst(hPtr1)){ //(first-order) unify type environments + HOPU_typesUnify(DF_constType(hPtr1), DF_constType(hPtr2), + AM_cstTyEnvSize(DF_constTabIndex(hPtr1))); + } + break; + } + case DF_TM_TAG_BVAR: { + if (!DF_isBV(hPtr2)) EM_THROW(EM_FAIL); + else { + int ind = DF_bvIndex(hPtr2) + nabs; //lifting for eta-expansion + AM_embedError(ind); + if (DF_bvIndex(hPtr1) != ind) EM_THROW(EM_FAIL); + } + break; + } + case DF_TM_TAG_NIL: { if (!DF_isNil(hPtr2)) EM_THROW(EM_FAIL); break;} + case DF_TM_TAG_INT: { + if (!(DF_isInt(hPtr2) && (DF_intValue(hPtr2) == DF_intValue(hPtr1)))) + EM_THROW(EM_FAIL); + break; + } + case DF_TM_TAG_FLOAT:{ + if (!(DF_isFloat(hPtr2)&&(DF_floatValue(hPtr2)==DF_floatValue(hPtr1)))) + EM_THROW(EM_FAIL); + break; + } + case DF_TM_TAG_STR: { + if (!(DF_isStr(hPtr2) && (DF_sameStrs(hPtr1, hPtr2)))) + EM_THROW(EM_FAIL); + break; + } + case DF_TM_TAG_CONS: { + if (!(DF_isCons(hPtr2))) EM_THROW(EM_FAIL); + break; + } + } //switch +} + +/* Set up PDL by sub problems resulted from rigid-rigid pairs upon */ +/* successful matching of their heads. Eta-expansion is performed on-a-fly */ +/* when necessary. */ +void HOPU_setPDL(MemPtr args1, MemPtr args2, int nargs, int nabs) +{ + if (nabs == 0){ //no need for eta-expansion + AM_pdlError(nargs * 2); + for (; nargs > 0; nargs --){ + AM_pushPDL(args1); args1 += DF_TM_ATOMIC_SIZE; + AM_pushPDL(args2); args2 += DF_TM_ATOMIC_SIZE; + } + } else { //nabs > 0 (eta-expansion) + AM_pdlError((nargs + nabs) * 2); + AM_heapError(AM_hreg + nargs*DF_TM_SUSP_SIZE + nabs*DF_TM_ATOMIC_SIZE); + for (; nargs > 0; nargs --){ //[|ai, 0, nabs, nil|] + AM_pushPDL(args1); AM_pushPDL(AM_hreg); + DF_mkSusp(AM_hreg, 0, nabs, DF_termDeref((DF_TermPtr)args2), + DF_EMPTY_ENV); + AM_hreg += DF_TM_SUSP_SIZE; + args1 += DF_TM_ATOMIC_SIZE; args2 += DF_TM_ATOMIC_SIZE; + } + for (; nabs > 0; nabs --){ // bv(i) + AM_pushPDL(args1); AM_pushPDL(AM_hreg); + DF_mkBV(AM_hreg, nabs); + args1 += DF_TM_ATOMIC_SIZE; AM_hreg += DF_TM_ATOMIC_SIZE; + } + } +} + +/***************************************************************************/ +/* HIGHER_ORDER PATTERN UNIFICATION */ +/* */ +/* The main routines of this file. */ +/***************************************************************************/ +/* Perform higher-order pattern unification over the pairs delayed on the */ +/* PDL stack. The PDL stack is empty upon successful termination of this */ +/* procedure. */ +void HOPU_patternUnifyPDL() +{ + DF_TermPtr tPtr1, tPtr2, //pointers to terms to be unified + hPtr, //pointer to head of hnf + args; //arg vec of hnf + Flag rig, cons; //rigid flag and cons flags + int nabs, nargs; //binder length and # of arguments of hnf + while (AM_nemptyPDL()){ + //retrieve the pair of terms on the current top of PDL + tPtr1 = (DF_TermPtr)AM_popPDL(); tPtr2 = (DF_TermPtr)AM_popPDL(); + HN_hnorm(tPtr1); //hnorm tPtr1 + hPtr = AM_head; args = AM_argVec; nabs = AM_numAbs; nargs = AM_numArgs; + rig = AM_rigFlag; //bookkeeping relevant info of hnf of tPtr1 + HN_hnorm(tPtr2); //hnorm tPtr2 + if (rig){ + if (AM_rigFlag){// rigid - rigid + if (nabs > AM_numAbs) { + nabs = nabs - AM_numAbs; //reuse nabs + HOPU_matchHeads(hPtr, AM_head, nabs); + HOPU_setPDL((MemPtr)args,(MemPtr)AM_argVec,AM_numArgs,nabs); + } else { //nabs <= AM_numAbs + nabs = AM_numAbs - nabs; //reuse nabs + HOPU_matchHeads(AM_head, hPtr, nabs); + HOPU_setPDL((MemPtr)AM_argVec, (MemPtr)args, nargs, nabs); + } + } else { // rigid - flex + DF_TermPtr rigBody = HOPU_lamBody(tPtr1); + DF_TermPtr flexBody = HOPU_lamBody(tPtr2); + if (nabs < AM_numAbs) { //eta expand rigid term first + nabs = AM_numAbs - nabs; //reuse nabs + rigBody = HOPU_etaExpand(&hPtr, &args, nargs, nabs); + HOPU_rigMkSubst(flexBody, AM_head, AM_numArgs, AM_argVec, + rigBody, hPtr, (nargs+nabs), args, 0); + } else HOPU_rigMkSubst(flexBody,AM_head, AM_numArgs, AM_argVec, + rigBody,hPtr,nargs,args,nabs-AM_numAbs); + } // rigid-flex + } else { //(rig == FALSE) + DF_TermPtr absBody1 = HOPU_lamBody(tPtr1); + DF_TermPtr absBody2 = HOPU_lamBody(tPtr2); + if (AM_rigFlag){// flex - rigid + if (AM_numAbs < nabs) { //eta expand rigid term first + nabs = nabs - AM_numAbs; //reuse nabs + absBody2 = HOPU_etaExpand(&AM_head, &AM_argVec, AM_numArgs, + nabs); + HOPU_rigMkSubst(absBody1, hPtr, nargs, args, absBody2, + AM_head, AM_numArgs+nabs, AM_argVec, 0); + }else HOPU_rigMkSubst(absBody1,hPtr,nargs,args,absBody2,AM_head, + AM_numArgs,AM_argVec,AM_numAbs-nabs); + } else { // flex - flex + if (AM_numAbs > nabs) + HOPU_flexMkSubst(absBody1, hPtr, nargs, args, absBody2, + AM_head, AM_numArgs, AM_argVec, + AM_numAbs-nabs); + else HOPU_flexMkSubst(absBody2, AM_head, AM_numArgs, AM_argVec, + absBody1,hPtr,nargs,args,nabs-AM_numAbs); + } // flex - flex + } //(rig == FALSE) + } // while (AM_nemptyPDL()) +} + +/* Interpretively pattern unify first the pairs delayed on the PDL, then */ +/* those delayed on the live list, if binding occured during the first step */ +/* or previous compiled unification process. */ +/* Upon successful termination, PDL should be empty and pairs left on the */ +/* live list should be those other than LLambda. */ +void HOPU_patternUnify() +{ + HOPU_patternUnifyPDL(); //first solve those left from compiled unification + while (AM_bndFlag && AM_nempLiveList()){ + DF_DisPairPtr dset = AM_llreg; + do { //move everything in live list to PDL + AM_pdlError(2); + AM_pushPDL((MemPtr)DF_disPairSecondTerm(dset)); + AM_pushPDL((MemPtr)DF_disPairFirstTerm(dset)); + dset = DF_disPairNext(dset); + } while (DF_isNEmpDisSet(dset)); + AM_bndFlag = OFF; + AM_llreg = DF_EMPTY_DIS_SET; + HOPU_patternUnifyPDL(); //unsolvable pairs are added to live list + } +} + +/* Interpretively pattern unify a pair of terms given as parameters. This is*/ +/* the counter part of HOPU_patterUnifyPDL that is invoked from the compiled*/ +/* part of unification. In this situation, the procedure has to be applied */ +/* to two terms as opposed to pairs delayed on the PDL stack. */ +/* */ +/* The input term pointers may dereference to register and stack addresses */ +/* Care must be taken to avoid making a reference to a register (stack) */ +/* address in binding a variable, and in making a disagreement pair. */ + +void HOPU_patternUnifyPair(DF_TermPtr tPtr1, DF_TermPtr tPtr2) +{ + DF_TermPtr h1Ptr, h2Ptr, args1, args2; + Flag rig1, rig2, cons1, cons2; + int nabs1, nabs2, nargs1, nargs2; + MemPtr oldPdlBot = AM_pdlBot; + + AM_pdlBot = AM_pdlTop; + HN_hnorm(tPtr1); h1Ptr = AM_head; args1 = AM_argVec; + nabs1 = AM_numAbs; nargs1 = AM_numArgs; rig1 = AM_rigFlag; + HN_hnorm(tPtr2); h2Ptr = AM_head; args2 = AM_argVec; + nabs2 = AM_numAbs; nargs2 = AM_numArgs; rig2 = AM_rigFlag; + + + if (rig1) { + if (rig2) { //rigid-rigid + if (nabs1 > nabs2) { + nabs1 = nabs1 - nabs2; + HOPU_matchHeads(h1Ptr, h2Ptr, nabs1); + HOPU_setPDL((MemPtr)args1, (MemPtr)args2, nargs2, nabs1); + } else {//nabs1 <= nabs2 + nabs1 = nabs2 - nabs1; + HOPU_matchHeads(h2Ptr, h1Ptr, nabs1); + HOPU_setPDL((MemPtr)args2, (MemPtr)args1, nargs1, nabs1); + } + } else { //rigid-flex + if ((nabs1 == 0) && (nabs2 == 0)) + HOPU_rigMkSubstGlb(tPtr2, h2Ptr, nargs2, args2, + tPtr1, h1Ptr, nargs1, args1); + else { + DF_TermPtr rigBody = HOPU_lamBody(tPtr1); + DF_TermPtr flexBody = HOPU_lamBody(tPtr2); + if (nabs1 < nabs2) { + nabs1 = nabs2 - nabs1; + rigBody = HOPU_etaExpand(&h1Ptr, &args1, nargs1, nabs1); + //now rigBody must locate on heap + HOPU_rigMkSubst(flexBody, h2Ptr, nargs2, args2, rigBody, + h1Ptr, nargs1+nabs1, args1, 0); + } else // (nabs1 >= nabs2) + HOPU_rigMkSubst(flexBody, h2Ptr, nargs2, args2, rigBody, + h1Ptr, nargs1, args1, nabs1-nabs2); + } // !(nabs1 == nabs2 == 0) + } //rigid-flex + } else { // rig1 = FALSE + if (rig2) { //flex-rigid + if ((nabs2 == 0) && (nabs1 == 0)) + HOPU_rigMkSubstGlb(tPtr1, h1Ptr, nargs1, args1, + tPtr2, h2Ptr, nargs2, args2); + else { //!(nabs1 == nabs2 == 0) + DF_TermPtr rigBody = HOPU_lamBody(tPtr2); + DF_TermPtr flexBody = HOPU_lamBody(tPtr1); + if (nabs2 < nabs1) { + nabs1 = nabs2 - nabs1; + rigBody = HOPU_etaExpand(&h2Ptr, &args2, nargs2, nabs1); + //now rigBody must locate on heap + HOPU_rigMkSubst(flexBody, h1Ptr, nargs1, args1, rigBody, + h2Ptr, nargs2+nabs1, args2, 0); + } else //(nabs2 >= nabs1) + HOPU_rigMkSubst(flexBody, h1Ptr, nargs1, args1, rigBody, + h2Ptr, nargs2, args2, nabs2-nabs1); + } //!(nabs1 == nabs2 == 0) + } else { //flex-flex + if (nabs1 == 0) //nabs2 >= nabs1 + HOPU_flexMkSubstGlb(DF_termDeref(tPtr1), h1Ptr, nargs1, args1, + HOPU_lamBody(tPtr2), h2Ptr, nargs2, args2, + tPtr2, nabs2); + else { //(nabs1 > 0) + if (nabs2 == 0) //nabs2 < nabs1 + HOPU_flexMkSubstGlb(DF_termDeref(tPtr2),h2Ptr,nargs2,args2, + HOPU_lamBody(tPtr1),h1Ptr,nargs1,args1, + tPtr1,nabs1); + + else { //nabs1 != 0 && nabs2 != 0 + DF_TermPtr flexBody1 = HOPU_lamBody(tPtr1); + DF_TermPtr flexBody2 = HOPU_lamBody(tPtr2); + if (nabs2 > nabs1) + HOPU_flexMkSubst(flexBody1, h1Ptr, nargs1, args1, + flexBody2, h2Ptr, nargs2, args2, + nabs2-nabs1); + else //nabs2 <= nabs1 + HOPU_flexMkSubst(flexBody2, h2Ptr, nargs2, args2, + flexBody1, h1Ptr, nargs1, args1, + nabs1-nabs2); + } //nabs1 != 0 && nabs2 != 0 + } //(nabs1 > 0) + } //flex-flex + } //rig1 = FALSE + //solve the pairs (which must locate on heap) remaining on the PDL + HOPU_patternUnifyPDL(); + AM_pdlBot = oldPdlBot; +} + +#endif //HOPU_C diff --git a/src/runtime/c/teyjus/simulator/hopu.h b/src/runtime/c/teyjus/simulator/hopu.h new file mode 100644 index 000000000..1ea26b00c --- /dev/null +++ b/src/runtime/c/teyjus/simulator/hopu.h @@ -0,0 +1,85 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* File hopu.h. This header file defines the interface components for the */ +/* code in hopu.c that implements higher-order pattern unification. */ +/* */ +/****************************************************************************/ +#ifndef HOPU_H +#define HOPU_H + +#include "mctypes.h" +#include "dataformats.h" + +/* A flag denoting whether new structure is created during the process of */ +/* finding substitutions. */ +extern Boolean HOPU_copyFlagGlb; + +/* Return the dereference of the abstraction body of the given term. */ +DF_TermPtr HOPU_lamBody(DF_TermPtr tPtr); + +/* Globalize a rigid term and make a variable binding. */ +/* If the term pointer to the rigid term is not one referring to a heap */ +/* address, its atomic content is then copied into the variable to be bound*/ +/* Otherwise, the variable is made a reference to the rigid term. */ +void HOPU_globalizeCopyRigid(DF_TermPtr rPtr, DF_TermPtr vPtr); + + +/* Globalize a flex term. */ +/* If the term pointer is one referring to a stack address, (in which case */ +/* the flex term must be a free variable itself), the atomic content is */ +/* copied onto the current top of heap; the free variable on stack is then */ +/* bound to the new heap term, and the binding is trailed if necessary; the */ +/* term pointer is updated to the new heap term. */ +DF_TermPtr HOPU_globalizeFlex(DF_TermPtr fPtr); + +/* Try to find the (partial) structure of the substitution for a flex head */ +/* of a LLambda term corresponding to an internal flex term which is not */ +/* known to be LLambda in the compiled form of pattern unification. */ +DF_TermPtr HOPU_flexNestedSubstC(DF_TermPtr fhPtr, DF_TermPtr args, int nargs, + DF_TermPtr tmPtr, int emblev); + +/* Try to find the (partial) binding of the head of a flex term when */ +/* unifying it with a rigid term possible under abstractions in the compiled*/ +/* form of pattern unification. */ +DF_TermPtr HOPU_rigNestedSubstC(DF_TermPtr rhPtr, DF_TermPtr rPtr, + DF_TermPtr args, int rnargs, int emblev); + + +/* Interpretively pattern unify first the pairs delayed on the PDL, then */ +/* those delayed on the live list, if binding occured during the first step */ +/* or previous compiled unification process. */ +/* Upon successful termination, PDL should be empty and pairs left on the */ +/* live list should be those other than LLambda. */ +void HOPU_patternUnify(); + +/* Interpretively pattern unify a pair of terms given as parameters. This is*/ +/* the counter part of HOPU_patterUnifyPDL that is invoked from the compiled*/ +/* part of unification. In this situation, the procedure has to be applied */ +/* to two terms as opposed to pairs delayed on the PDL stack. */ +/* */ +/* The input term pointers may dereference to register and stack addresses */ +/* Care must be taken to avoid making a reference to a register (stack) */ +/* address in binding a variable, and in making a disagreement pair. */ +void HOPU_patternUnifyPair(DF_TermPtr tPtr1, DF_TermPtr tPtr2); + + +#endif //HOPU_H + diff --git a/src/runtime/c/teyjus/simulator/instraccess.h b/src/runtime/c/teyjus/simulator/instraccess.h new file mode 100644 index 000000000..21d19f81e --- /dev/null +++ b/src/runtime/c/teyjus/simulator/instraccess.h @@ -0,0 +1,300 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/*************************************************************************/ +/* */ +/* File instraccess.h. Micros for access instruction arguments are */ +/* defined, which depends on the instruction format. */ +/*************************************************************************/ + +#ifndef INSTRACCESS_H +#define INSTRACCESS_H + +#include "../tables/instructions.h" //to be modified + +#define INSACC_CALL_I1(op) (*((INSTR_OneByteInt *)((op) - INSTR_CALL_I1_LEN))) + +//INSTR_CAT_X +#define INSACC_X() { AM_preg += INSTR_X_LEN; } + +//INSTR_CAT_RX +#define INSACC_RX(op) {\ + (op) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RX_R))); \ + AM_preg += INSTR_RX_LEN; \ +} + +//INSTR_CAT_EX +#define INSACC_EX(op) {\ + (op) = AM_envVar(*((INSTR_EnvInd *)(AM_preg + INSTR_EX_E))); \ + AM_preg += INSTR_EX_LEN; \ +} + +//INSTR_CAT_I1X +#define INSACC_I1X(op) {\ + (op) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1X_I1)); \ + AM_preg += INSTR_I1X_LEN; \ +} + +//INSTR_CAT_CX +#define INSACC_CX(op) {\ + (op) = *((INSTR_CstIndex *)(AM_preg + INSTR_CX_C)); \ + AM_preg += INSTR_CX_LEN; \ +} + +//INSTR_CAT_KX +#define INSACC_KX(op) {\ + (op) = *((INSTR_KstIndex *)(AM_preg + INSTR_KX_K)); \ + AM_preg += INSTR_KX_LEN; \ +} + +//INSTR_CAT_IX +#define INSACC_IX(op) {\ + (op) = *((INSTR_Int *)(AM_preg + INSTR_IX_I)); \ + AM_preg += INSTR_IX_LEN; \ +} + +//INSTR_CAT_FX +#define INSACC_FX(op) {\ + (op) = *((INSTR_Float *)(AM_preg + INSTR_FX_F)); \ + AM_preg += INSTR_FX_LEN; \ +} + +//INSTR_CAT_SX +#define INSACC_SX(op) {\ + (op) = *((INSTR_Str *)(AM_preg + INSTR_SX_S)); \ + AM_preg += INSTR_SX_LEN; \ +} + +//INSTR_CAT_MTX +#define INSACC_MTX(op) {\ + (op) = *((INSTR_ModTab *)(AM_preg + INSTR_MTX_MT)); \ + AM_preg += INSTR_MTX_LEN; \ +} + +//INSTR_CAT_RRX +#define INSACC_RRX(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RRX_R1))); \ + (op2) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RRX_R2))); \ + AM_preg += INSTR_RRX_LEN; \ +} + +//INSTR_CAT_ERX +#define INSACC_ERX(op1, op2) {\ + (op1) = AM_envVar(*((INSTR_EnvInd *)(AM_preg + INSTR_ERX_E))); \ + (op2) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_ERX_R))); \ + AM_preg += INSTR_ERX_LEN; \ +} + +//INSTR_CAT_RCX +#define INSACC_RCX(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RCX_R))); \ + (op2) = *((INSTR_CstIndex *)(AM_preg + INSTR_RCX_C)); \ + AM_preg += INSTR_RCX_LEN; \ +} + +//INSTR_CAT_RIX +#define INSACC_RIX(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RIX_R))); \ + (op2) = *((INSTR_Int *)(AM_preg + INSTR_RIX_I)); \ + AM_preg += INSTR_RIX_LEN; \ +} + +//INSTR_CAT_RFX +#define INSACC_RFX(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RFX_R))); \ + (op2) = *((INSTR_Float *)(AM_preg + INSTR_RFX_F)); \ + AM_preg += INSTR_RFX_LEN; \ +} + +//INSTR_CAT_RSX +#define INSACC_RSX(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RSX_R))); \ + (op2) = *((INSTR_Str *)(AM_preg + INSTR_RSX_S)); \ + AM_preg += INSTR_RSX_LEN; \ +} + +//INSTR_CAT_RI1X +#define INSACC_RI1X(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RI1X_R))); \ + (op2) = *((INSTR_OneByteInt *)(AM_preg + INSTR_RI1X_I1)); \ + AM_preg += INSTR_RI1X_LEN; \ +} + +//INSTR_CAT_RCEX +#define INSACC_RCEX(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RCEX_R))); \ + (op2) = AM_cenvVar(*((INSTR_ClEnvInd *)(AM_preg + INSTR_RCEX_CE))); \ + AM_preg += INSTR_RCEX_LEN; \ +} + +//INSTR_CAT_ECEX +#define INSACC_ECEX(op1, op2) {\ + (op1) = AM_envVar(*((INSTR_EnvInd *)(AM_preg + INSTR_ECEX_E))); \ + (op2) = AM_cenvVar(*((INSTR_ClEnvInd *)(AM_preg + INSTR_ECEX_CE))); \ + AM_preg += INSTR_ECEX_LEN; \ +} + +//INSTR_CAT_CLX +#define INSACC_CLX(op1, op2) {\ + (op1) = *((INSTR_CstIndex *)(AM_preg + INSTR_CLX_C)); \ + (op2) = *((INSTR_CodeLabel *)(AM_preg + INSTR_CLX_L)); \ + AM_preg += INSTR_CLX_LEN; \ +} + +//INSTR_CAT_RKX +#define INSACC_RKX(op1, op2) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RKX_R))); \ + (op2) = *((INSTR_KstIndex *)(AM_preg + INSTR_RKX_K)); \ + AM_preg += INSTR_RKX_LEN; \ +} + +//INSTR_CAT_ECX +#define INSACC_ECX(op1, op2) {\ + (op1) = AM_envVar(*((INSTR_EnvInd *)(AM_preg + INSTR_ECX_E))); \ + (op2) = *((INSTR_CstIndex *)(AM_preg + INSTR_ECX_C)); \ + AM_preg += INSTR_ECX_LEN; \ +} + +//INSTR_CAT_I1ITX +#define INSACC_I1ITX(op1, op2) {\ + (op1) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1ITX_I1)); \ + (op2) = *((INSTR_ImplTab *)(AM_preg + INSTR_I1ITX_IT)); \ + AM_preg += INSTR_I1ITX_LEN; \ +} + +//INSTR_CAT_I1LX +#define INSACC_I1LX(op1, op2) {\ + (op1) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1LX_I1)); \ + (op2) = *((INSTR_CodeLabel *)(AM_preg + INSTR_I1LX_L)); \ + AM_preg += INSTR_I1LX_LEN; \ +} + +//INSTR_CAT_SEGLX +#define INSACC_SEGLX(op1, op2) {\ + (op1) = *((INSTR_ImpSegInd *)(AM_preg + INSTR_SEGLX_SEG)); \ + (op2) = *((INSTR_CodeLabel *)(AM_preg + INSTR_SEGLX_L)); \ + AM_preg += INSTR_SEGLX_LEN; \ +} + + +//INSTR_CAT_I1NX +#define INSACC_I1NX(op1, op2) {\ + (op1) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1NX_I1)); \ + (op2) = *((INSTR_NextClauseInd *)(AM_preg + INSTR_I1NX_N)); \ + AM_preg += INSTR_I1NX_LEN; \ +} + +//INSTR_CAT_I1HTX +#define INSACC_I1HTX(op1, op2) {\ + (op1) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1HTX_I1)); \ + (op2) = *((INSTR_HashTab *)(AM_preg + INSTR_I1HTX_HT)); \ + AM_preg += INSTR_I1HTX_LEN; \ +} + +//INSTR_CAT_I1BVTX +#define INSACC_I1BVTX(op1, op2) {\ + (op1) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1BVTX_I1)); \ + (op2) = *((INSTR_BranchTab *)(AM_preg + INSTR_I1BVTX_BVT)); \ + AM_preg += INSTR_I1BVTX_LEN; \ +} + +//INSTR_CAT_CWPX +#define INSACC_CWPX(op) {\ + (op) = *((INSTR_CstIndex *)(AM_preg + INSTR_CWPX_C)); \ + AM_preg += INSTR_CWPX_LEN; \ +} + +//INSTR_CAT_I1WPX +#define INSACC_I1WPX(op) {\ + (op) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1WPX_I1)); \ + AM_preg += INSTR_I1WPX_LEN; \ +} + +//INSTR_CAT_RRI1X +#define INSACC_RRI1X(op1, op2, op3) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RRI1X_R1))); \ + (op2) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RRI1X_R2))); \ + (op3) = *((INSTR_OneByteInt *)(AM_preg + INSTR_RRI1X_I1)); \ + AM_preg += INSTR_RRI1X_LEN; \ +} + +//INSTR_CAT_RCLX +#define INSACC_RCLX(op1, op2, op3) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RCLX_R))); \ + (op2) = *((INSTR_CstIndex *)(AM_preg + INSTR_RCLX_C)); \ + (op3) = *((INSTR_CodeLabel *)(AM_preg + INSTR_RCLX_L)); \ + AM_preg += INSTR_RCLX_LEN; \ +} + +//INSTR_CAT_RCI1X +#define INSACC_RCI1X(op1, op2, op3) {\ + (op1) = AM_reg(*((INSTR_RegInd *)(AM_preg + INSTR_RCI1X_R))); \ + (op2) = *((INSTR_CstIndex *)(AM_preg + INSTR_RCI1X_C)); \ + (op3) = *((INSTR_OneByteInt *)(AM_preg + INSTR_RCI1X_I1)); \ + AM_preg += INSTR_RCI1X_LEN; \ +} + +//INSTR_CAT_SEGI1LX +#define INSACC_SEGI1LX(op1, op2, op3) {\ + (op1) = *((INSTR_ImpSegInd *)(AM_preg + INSTR_SEGI1LX_SEG)); \ + (op2) = *((INSTR_OneByteInt *)(AM_preg + INSTR_SEGI1LX_I1)); \ + (op3) = *((INSTR_CodeLabel *)(AM_preg + INSTR_SEGI1LX_L)); \ + AM_preg += INSTR_SEGI1LX_LEN; \ +} + + + +//specialized +//INSTR_CAT_LX +#define INSACC_LX() {AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LX_L));} + +//INSTR_CAT_I1LX +#define INSACC_I1LX_I1(op) {\ + (op) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1LX_I1)); \ +} + +//INSTR_CAT_I1LWPX +#define INSACC_I1LWPX_I1(op) {\ + (op) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1LWPX_I1)); \ +} + +//INSACC_CAT_I1LLX +#define INSACC_I1LLX(op1, op2) {\ + (op1) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1LLX_I1)); \ + (op2) = *((INSTR_CodeLabel *)(AM_preg + INSTR_I1LLX_L1)); \ + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_I1LLX_L2)); \ +} + +//INSACC_CAT_NLLX +#define INSACC_NLLX_N(op) {\ + (op) = *((INSTR_NextClauseInd *)(AM_preg + INSTR_NLLX_N)); \ +} + +//INSTR_CAT_I1CWPX +#define INSACC_I1CWPX_C(op) {\ + (op) = *((INSTR_CstIndex *)(AM_preg + INSTR_I1CWPX_C)); \ +} + + +//INSTR_CAT_I1I1WPX +#define INSACC_I1I1WPX(op1) {\ + (op1) = *((INSTR_OneByteInt *)(AM_preg + INSTR_I1I1WPX_I12)); \ + AM_preg += INSTR_I1I1WPX_LEN; \ +} +#endif //INSTRACCESS_H diff --git a/src/runtime/c/teyjus/simulator/io-datastructures.c b/src/runtime/c/teyjus/simulator/io-datastructures.c new file mode 100644 index 000000000..1647ee5b1 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/io-datastructures.c @@ -0,0 +1,53 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File io-datastructures.c. * + * * + ****************************************************************************/ +#include "io-datastructures.h" + +/* The io free term variable table */ +IO_FreeVarInfo IO_freeVarTab[IO_MAX_FREE_VARS]; + +/* index for the topmost cell that has been used */ +int IO_freeVarTabTop; + +/* initialize */ +void IO_initIO() +{ + IO_freeVarTabTop = 0; +} + +/* check if the free term variable table is full */ +Boolean IO_freeVarTabFull(int incSize) +{ + return (IO_freeVarTabTop+incSize >= IO_MAX_FREE_VARS); +} + +/* make an entry in the free term variable table */ +void IO_enterFreeVarTab(DF_StrDataPtr name, DF_TermPtr varLoc) +{ + int i = IO_freeVarTabTop++; + + IO_freeVarTab[i].varName = name; + IO_freeVarTab[i].rigdes = varLoc; +} + diff --git a/src/runtime/c/teyjus/simulator/io-datastructures.h b/src/runtime/c/teyjus/simulator/io-datastructures.h new file mode 100644 index 000000000..217a0f04e --- /dev/null +++ b/src/runtime/c/teyjus/simulator/io-datastructures.h @@ -0,0 +1,66 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// + +/**************************************************************************** + * * + * File io-datastructures.h. * + * * + ****************************************************************************/ + +#ifndef IODATASTRUCTURES_H +#define IODATASTRUCTURES_H + +#include "mcstring.h" +#include "dataformats.h" +#include "mctypes.h" + +/***************************************************************************** + * A data structure for maintaining information about query term variables * + * and other free variables encountered in the course of displaying answers. * + *****************************************************************************/ +/* number of entries in the table for such variables. */ +#define IO_MAX_FREE_VARS 500 + +/* Structure of each entry in the table; display name, and the rigid + designator in the form of the memory cell corresponding to the variable are + maintained. */ +typedef struct +{ + DF_StrDataPtr varName; + DF_TermPtr rigdes; +} IO_FreeVarInfo; + +/* The table itself */ +extern IO_FreeVarInfo IO_freeVarTab[IO_MAX_FREE_VARS]; + +/* index for the topmost cell that has been used */ +extern int IO_freeVarTabTop; + +/* initialize */ +void IO_initIO(); + +/* check if the free term variable table is full */ +Boolean IO_freeVarTabFull(int incSize); + +/* make an entry in the free term variable table */ +void IO_enterFreeVarTab(DF_StrDataPtr name, DF_TermPtr varLoc); + + +#endif //IODATASTRUCTURES_H diff --git a/src/runtime/c/teyjus/simulator/mcstring.c b/src/runtime/c/teyjus/simulator/mcstring.c new file mode 100644 index 000000000..aed27b5e2 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/mcstring.c @@ -0,0 +1,116 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File mcstring.c. */ +/****************************************************************************/ +#include <string.h> +#include <stdio.h> +#include <math.h> +#include "mcstring.h" +#include "mctypes.h" + +//length of a given string; the string pointer is assumed to not be NULL +int MCSTR_strLength(MCSTR_Str str) +{ + return *((int *)str); +} + +//number of words needed for a string with n characters +int MCSTR_numWords(int n) +{ + return ((int)ceil(((double)(n+1))/WORD_SIZE)) + 1; //with '\0' terminator +} + +//from machine string to c string +char* MCSTR_toCString(MCSTR_Str str) +{ + return (char*)(str + 1); +} + +//to string +void MCSTR_toString(MCSTR_Str loc, char* buf, int length) +{ + char* chloc = (char*)(loc + 1); + *((int *)loc) = length; + strcpy(chloc, buf); +} + +//compare whether two string literals are the same +Boolean MCSTR_sameStrs(MCSTR_Str str1, MCSTR_Str str2) +{ + if (strcmp((char*)(str1+1), (char*)(str2+1)) == 0) return TRUE; + else return FALSE; +} + +/* compare strings: return < 0 if str1 < str2 + return == 0 if str1 == str2 + return > 0 if str1 > str2 +*/ +int MCSTR_compareStrs(MCSTR_Str str1, MCSTR_Str str2) +{ + return strcmp((char*)(str1+1), (char*)(str2+1)); +} + +//string concatenate (the new string is created at address started from loc) +void MCSTR_concat(MCSTR_Str loc, MCSTR_Str str1, MCSTR_Str str2) +{ + char* chloc = (char*)(loc + 1); + *((int *)loc) = MCSTR_strLength(str1) + MCSTR_strLength(str2); + strcpy(chloc, (char*)(str1+1)); + strcat(chloc, (char*)(str2+1)); +} + +//substring (the new string is created at address started from loc) +void MCSTR_subString(MCSTR_Str loc, MCSTR_Str str, int startPos, int length) +{ + int i; + char* fromPtr = ((char*)(str + 1))+startPos; + char* toPtr = (char*)(loc + 1); + + *((int *)loc) = (length + 1); + while (length > 0) { + *toPtr++ = *fromPtr++; + length--; + } + *toPtr = '\0'; +} + +//chr +void MCSTR_chr(MCSTR_Str loc, int integer) +{ + char* chloc = (char*)(loc + 1); + *((int *)loc) = 1; + *chloc++ = (char)integer; + *chloc = '\0'; +} + +//ord +int MCSTR_ord(MCSTR_Str str) +{ + return (int)(*((char*)(str + 1))); +} + +//display on standard IO +void MCSTR_printStr(MCSTR_Str str) +{ + printf("%s", (char*)(str+1)); +} + diff --git a/src/runtime/c/teyjus/simulator/mcstring.h b/src/runtime/c/teyjus/simulator/mcstring.h new file mode 100644 index 000000000..f1004c8e9 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/mcstring.h @@ -0,0 +1,67 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* File mcstring.h. The virtual machine encoding of string literals is */ +/* contained in this module. Any change of such encoding format should be */ +/* isolated here. */ +/****************************************************************************/ + +#ifndef MCSTRING_H +#define MCSTRING_H + +#include "mctypes.h" + +/****************************************************************************/ +/* Currently the string is encoded as one word being the length of the */ +/* string followed by a list of characters in C string encoding (which is a */ +/* sequence of chars ended with '\0'. */ +/****************************************************************************/ +typedef char MCSTR_Char; +typedef WordPtr MCSTR_Str; + +//length of a given string; the string pointer is assumed to not be NULL +int MCSTR_strLength(MCSTR_Str str); +//number of words needed for a string with n characters +int MCSTR_numWords(int n); +//from machine string to c string +char* MCSTR_toCString(MCSTR_Str str); +//to string +void MCSTR_toString(MCSTR_Str loc, char* buf, int length); + +//compare whether two string literals are the same +Boolean MCSTR_sameStrs(MCSTR_Str str1, MCSTR_Str str2); +//compare strings +int MCSTR_compareStrs(MCSTR_Str str1, MCSTR_Str str2); +//string concatenate (the new string is created at address started from loc) +void MCSTR_concat(MCSTR_Str loc, MCSTR_Str str1, MCSTR_Str str2); +//substring (the new string is created at address started from loc) +void MCSTR_subString(MCSTR_Str loc, MCSTR_Str str, int startPos, int length); +//chr +void MCSTR_chr(MCSTR_Str loc, int integer); +//ord +int MCSTR_ord(MCSTR_Str str); + + +//display on standard IO +void MCSTR_printStr(MCSTR_Str str); + +#endif //MCSTRING_H diff --git a/src/runtime/c/teyjus/simulator/mctypes.h b/src/runtime/c/teyjus/simulator/mctypes.h new file mode 100644 index 000000000..b964599bc --- /dev/null +++ b/src/runtime/c/teyjus/simulator/mctypes.h @@ -0,0 +1,54 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* */ +/* File mctypes.h. */ +/* This file contains the definitions of the low-level */ +/* data types that are used in constructing the more complex objects that */ +/* are used in data representation and in instruction formats. This file */ +/* will likely be included by most others defining the overall system. */ +/* */ +/****************************************************************************/ +#ifndef MCTYPES_H +#define MCTYPES_H + +typedef unsigned char Byte; /* 8 bits */ +typedef unsigned short TwoBytes; /* 16 bits */ + + +typedef unsigned char Boolean; /* 8 bits: FALSE/TRUE */ +#define TRUE 1 +#define FALSE 0 + + +typedef unsigned long Word; +typedef Word *WordPtr; + +#define WORD_SIZE sizeof(Word) /* 4: 32-bits machine */ + /* 8 64-bits machine */ + +typedef Word Mem; /* generic memory type */ +typedef Mem *MemPtr; /* pointer to memory */ +typedef Byte *CSpacePtr; /* code space pointer */ +typedef Byte *BytePtr; + +#endif //MCTYPES_H diff --git a/src/runtime/c/teyjus/simulator/printterm.c b/src/runtime/c/teyjus/simulator/printterm.c new file mode 100644 index 000000000..2fbe03fd2 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/printterm.c @@ -0,0 +1,814 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File printterm.c. This file contains routines for printing out lambda * + * terms. It is assumed that these routines will be needed in two * + * situations: printing out answers to queries and displaying terms as * + * needed by invocation of builtin goals. * + * The difference between these two situations is in the display of * + * free term variables. Only when displaying answers is an attempt made to * + * present these using sensible names: in this case, either the name in the * + * query is used or a concise name is cooked up. In the other situation, * + * the address of the variable cell is used as the name. * + * * + * Certain assumptions are relevant to avoiding name clashes. For local * + * constants, the assumption is that no constant names in user * + * programs begin with <lc- and end with >. The use of this idea is * + * buried inside the routine PRINT_writeHCName. * + * Violation of this condition is *not* checked. For term variables, the * + * assumption is that bound variables do not begin with _. * + * * + ****************************************************************************/ +#include <stdlib.h> +#include <string.h> +#include "printterm.h" +#include "mctypes.h" +#include "mcstring.h" +#include "hnorm.h" +#include "dataformats.h" +#include "abstmachine.h" +#include "io-datastructures.h" +#include "builtins/builtins.h" +#include "../system/stream.h" +#include "../system/error.h" +#include "../system/operators.h" +#include "../tables/pervasives.h" + +//temp +#include <stdio.h> + +/* This variable records the number of query variables */ +int PRINT_numQueryVars; + +/* flag determining whether or not to print sensible names for free vars */ +Boolean PRINT_names = FALSE; + +static void PRINT_writeTerm(WordPtr outStream, DF_TermPtr tmPtr, + OP_FixityType infx, int inprec, OP_TermContext tc); + +/**************************************************************************** + * Auxiliary routines used in this file * + ****************************************************************************/ +static Boolean PRINT_parenNeeded(OP_FixityType opfx, int opprec, + OP_TermContext context, OP_FixityType fx, + int prec) +{ + Boolean pparen = FALSE; + if (context == OP_LEFT_TERM) { + switch (fx) { + case OP_INFIX: case OP_INFIXR: case OP_POSTFIX: + if (opprec <= prec) pparen = TRUE; break; + case OP_INFIXL: case OP_POSTFIXL: + { + switch (opfx) { + case OP_PREFIX: case OP_INFIX: case OP_INFIXL: case OP_POSTFIX: + case OP_POSTFIXL: + if (opprec < prec) pparen = TRUE; break; + default: + if (opprec <= prec) pparen = TRUE; break; + } + break; + } + } + } else if (context == OP_RIGHT_TERM) { + switch (fx) { + case OP_INFIX: case OP_INFIXL: case OP_PREFIX: + if (opprec <= prec) pparen = TRUE; break; + case OP_INFIXR: case OP_PREFIXR: + { + switch (opfx) { + case OP_INFIXL: case OP_POSTFIXL: + if (opprec <= prec) pparen = TRUE; break; + default: + if (opprec < prec) pparen = TRUE; break; + } + } + } + } + return pparen; +} + +/* making a name from the address of an unbound term variable */ +static long PRINT_makeNumberName(DF_TermPtr tmPtr) +{ return (long)tmPtr - (long)AM_heapBeg; } + + +/**************************************************************************** + * Routines for printing out keywords and punctuation symbols in the course * + * of displaying lambda terms. These have been extracted out of the other * + * routines so as to make stylistic changes at a later point easier to * + * effect. * + ****************************************************************************/ +static void PRINT_writeLParen(WordPtr outStream) +{ STREAM_printf(outStream, "("); } + +static void PRINT_writeRParen(WordPtr outStream) +{ STREAM_printf(outStream, ")"); } + +static void PRINT_writeConsSymbol(WordPtr outStream) +{ STREAM_printf(outStream, " :: "); } + +static void PRINT_writeNilSymbol(WordPtr outStream) +{ STREAM_printf(outStream, "nil"); } + +static void PRINT_writeInfixLam(WordPtr outStream) +{ STREAM_printf(outStream, "\\ "); } + +static void PRINT_writeLam(WordPtr outStream, int numabs) +{ STREAM_printf(outStream, "lam(%d, ", numabs); } + +static void PRINT_writeSpace(WordPtr outStream, int i) +{ while (i--) STREAM_printf(outStream, " "); } + +static void PRINT_writeEquals(WordPtr outStream) +{ STREAM_printf(outStream, " = "); } + +static void PRINT_writeComma(WordPtr outStream) +{ STREAM_printf(outStream, ","); } + +static void PRINT_writeDPairStart(WordPtr outStream) +{ STREAM_printf(outStream, "<"); } + +static void PRINT_writeDPairEnd(WordPtr outStream) +{ STREAM_printf(outStream, ">"); } + +/*************************************************************************** + * Writing out terms corresponding to the builtin constants. * + ***************************************************************************/ +/* Writing out an integer term to a given output stream */ +static void PRINT_writeInt(WordPtr outStream, DF_TermPtr tmPtr) +{ STREAM_printf(outStream, "%d", DF_intValue(tmPtr)); } + +/* Writing out a float term to a given output stream */ +static void PRINT_writeFloat(WordPtr outStream, DF_TermPtr tmPtr) +{ STREAM_printf(outStream, "%f", DF_floatValue(tmPtr)); } + +/* Writing out a string term to a given output stream */ +static void PRINT_writeString(WordPtr outStream, DF_TermPtr tmPtr) +{ STREAM_printf(outStream, "\"%s\"", MCSTR_toCString(DF_strValue(tmPtr))); } + +/* Writing out a stream constant to a given output stream */ +static void PRINT_writeStream(WordPtr outStream, DF_TermPtr tmPtr) +{ + WordPtr stream = DF_streamTabIndex(tmPtr); + STREAM_printf(outStream, "<stream "); + if (stream == STREAM_ILLEGAL) STREAM_printf(outStream, "-- closed>"); + else STREAM_printf(outStream, "-- \"%s\">", STREAM_getName(stream)); +} + +/**************************************************************************** + * Writing out a constant. Use the index into the runtime constant table * + * stored in the constant to get the constant name if one exists. If one * + * does not exist, i.e. if the constant is a local or hidden one, look for * + * it in a list of constants. If it is not in this list, make up a new * + * name. Eventually, the name consists of three parts: a generic name for * + * hidden constants, a part based on the runtime table index and a part * + * based on the universe index. * + ****************************************************************************/ +/* A structure for maintaining information about local constants encountered +while printing; this structure enables the assignment of a unique integer +to each runtime symbol table slot for such a constant. */ +typedef struct PRINT_ConstList_ *PRINT_ConstList; + +struct PRINT_ConstList_ +{ + int constInd; + int count; + PRINT_ConstList next; +}; + +static PRINT_ConstList PRINT_clist = NULL; +static int PRINT_lccount = 0; + +static void PRINT_cleanCList() +{ + PRINT_ConstList tmp; + + PRINT_lccount = 0; + while (PRINT_clist){ + tmp = PRINT_clist; + PRINT_clist = PRINT_clist -> next; + free(tmp); + } +} + +/* writing out a hidden (local) constant name; as side effect, a note may be + made of a new hidden (local) constant seen during this printing. */ +static void PRINT_writeHCName(WordPtr outStream, int constInd, int uc) +{ + PRINT_ConstList lclist = PRINT_clist; + while (lclist && (lclist->constInd != constInd)) lclist = lclist->next; + + if (!lclist) { + lclist = (PRINT_ConstList)EM_malloc(sizeof(struct PRINT_ConstList_)); + lclist->constInd = constInd; + lclist->count = PRINT_lccount++; + lclist->next = PRINT_clist; + PRINT_clist = lclist; + } + + STREAM_printf(outStream, "<lc-%d-%d>", lclist->count, uc); +} + +/* Writing out a constant, hidden or global. */ +static void PRINT_writeConst(WordPtr outStream, DF_TermPtr tmPtr) +{ + int constInd = DF_constTabIndex(tmPtr); + char* name = AM_cstName(constInd); + + if (name) STREAM_printf(outStream, "%s", name); + else PRINT_writeHCName(outStream, constInd, DF_constUnivCount(tmPtr)); +} + +/**************************************************************************** + * Writing out a free variable. Two situations are possible, one where a * + * symbolic name is to be produced and the other where the `address' could * + * serve as the name. In the first case, if the variable is a query * + * variable, then its name from the query is used. Otherwise a new name is * + * invented that is distinct from other free term variable names; the * + * initial segment of the name guarantees that it will be distinct from * + * that of bound variables. * + ****************************************************************************/ +/* counter used to generate free variable name */ +static int PRINT_fvcounter = 1; + +/* Create a free term variable name; this starts with _ has a standard + string prefix and then a digit sequence */ +static DF_StrDataPtr PRINT_makeFVarName() +{ + int digits = 0; + int i = PRINT_fvcounter; + int length; + char* cname; + DF_StrDataPtr fvname; + + while(i) { digits++; i = i/10; } + + length = digits + 3; + cname = (char*)EM_malloc(sizeof(char)*length); + cname[0] = '_'; + cname[1] = 'T'; + cname[length-1] = '\0'; + + i = PRINT_fvcounter; + while(i) { + cname[digits+1] = (i%10 + '0'); + i = i/10; + digits--; + } + PRINT_fvcounter++; + + fvname = (DF_StrDataPtr)EM_malloc(sizeof(Word)*(MCSTR_numWords(length) + + DF_STRDATA_HEAD_SIZE)); + DF_mkStrDataHead((MemPtr)fvname); + MCSTR_toString((MemPtr)((MemPtr)fvname + DF_STRDATA_HEAD_SIZE), + cname, length); + free(cname); + return fvname; +} + +/* Does a made up name occur in the free term variable table? Clash can +only occur with names in the user query */ +static Boolean PRINT_nameInFVTab(DF_StrDataPtr name) +{ + int i; + for (i = 0; i < PRINT_numQueryVars ; i++){ + if (MCSTR_sameStrs(DF_strDataValue(name), + DF_strDataValue(IO_freeVarTab[i].varName))) + return TRUE; + } + return FALSE; +} + +/* The main routine for printing out an unbound term variable */ +static void PRINT_writeFVar(WordPtr outStream, DF_TermPtr tmPtr) +{ + int fvind = 0; + DF_StrDataPtr fvname; + + //PRINT_names = TRUE; + if (PRINT_names) { + IO_freeVarTab[IO_freeVarTabTop].rigdes = tmPtr; + + while (tmPtr != IO_freeVarTab[fvind].rigdes) fvind++; + + if (fvind == IO_freeVarTabTop) { + /* i.e., a free variable not seen before */ + if (IO_freeVarTabTop == IO_MAX_FREE_VARS) + EM_error(BI_ERROR_TYFVAR_CAP); + + while(1) {//make a name + fvname = PRINT_makeFVarName(); + if (!PRINT_nameInFVTab(fvname)) break; + free(fvname); + } + + IO_freeVarTab[fvind].varName = fvname; + IO_freeVarTabTop++; + } + STREAM_printf(outStream, + MCSTR_toCString(DF_strDataValue(IO_freeVarTab[fvind].varName))); + } else { //PRINT_names = FALSE + STREAM_printf(outStream, "_%ld", PRINT_makeNumberName(tmPtr)); + } +} + +/**************************************************************************** + * Routines for writing out bound variables (in lambda abstraction and * + * bound variable occurrence) * + ****************************************************************************/ +/* prefix for bound variables */ +static char* PRINT_bvname = "W"; + +/* a counter for determining the suffix part of bound variables */ +static int PRINT_bvcounter = 1; + +/* A structure for maintaining information about bound variable names */ +typedef struct PRINT_BVList_ *PRINT_BVList; + +struct PRINT_BVList_ { + DF_StrDataPtr name; + PRINT_BVList next; }; + +/* the initial list of bound variable names; initialized in SIM_InitIo */ +static PRINT_BVList PRINT_bvs = NULL; + +static void PRINT_cleanBV(PRINT_BVList bv) +{ + free(bv->name); + free(bv); +} + +/* releasing the space for bound variables; needed only in case of error + exit */ +static void PRINT_cleanBVList() +{ + PRINT_BVList tbvl; + + PRINT_bvcounter = 1; + while (PRINT_bvs) { + tbvl = PRINT_bvs; PRINT_bvs = PRINT_bvs->next; + PRINT_cleanBV(tbvl); + } +} + +/**************************************************************************** + * Writing out a bound variable * + ****************************************************************************/ +static void PRINT_writeBVar(WordPtr outStream, DF_TermPtr tmPtr) +{ + int i; + int bvind = DF_bvIndex(tmPtr); + PRINT_BVList lbvs = PRINT_bvs; + + for (i = bvind; ((i != 1) && lbvs) ; i--) + lbvs = lbvs->next; + + // Is this checking and the else branch really necessary? + // Printing should start from top-level closed terms? + if (lbvs) STREAM_printf(outStream, "%s", + MCSTR_toCString(DF_strDataValue(lbvs->name))); + else STREAM_printf(outStream, "#%d", i); +} + +/**************************************************************************** + * Writing out an empty list * + ****************************************************************************/ +static void PRINT_writeNil(WordPtr outStream) +{ PRINT_writeNilSymbol(outStream); } + +/**************************************************************************** + * 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); +} + +/**************************************************************************** + * Writing out an abstraction. * + ****************************************************************************/ +/* creating a bound variable name with bound variable prefix followed by the*/ +/* current bound variable counter value. */ +static DF_StrDataPtr PRINT_makeBVarName() +{ + int digits = 0; + int i = PRINT_bvcounter; + int length; + char* cname; + DF_StrDataPtr bvname; + + while(i) { digits++; i = i/10; } + + length = digits + 2; + cname = (char*)EM_malloc(sizeof(char)*length); + strcpy(cname, PRINT_bvname); + cname[length-1] = '\0'; + + i = PRINT_bvcounter; + while(i) { + cname[digits] = (i%10 + '0'); + i = i/10; + digits--; + } + PRINT_bvcounter++; + + bvname = (DF_StrDataPtr)EM_malloc(sizeof(Word)*(MCSTR_numWords(length) + + DF_STRDATA_HEAD_SIZE)); + + DF_mkStrDataHead((MemPtr)bvname); + MCSTR_toString((MemPtr)((MemPtr)bvname + DF_STRDATA_HEAD_SIZE), + cname, length); + free(cname); + return bvname; +} + +static void PRINT_writeAbstBinders(WordPtr outStream, int nabs) +{ + DF_StrDataPtr bvname; + PRINT_BVList tmpbvs; + + while(nabs > 0) { + nabs--; + while(1) {//make a bvname not in FV table + bvname = PRINT_makeBVarName(); + if (!PRINT_nameInFVTab(bvname)) break; + free(bvname); + } + + //record the name into the head of the current bvlist + tmpbvs = (PRINT_BVList)EM_malloc(sizeof(struct PRINT_BVList_)); + tmpbvs->name = bvname; + tmpbvs->next = PRINT_bvs; + PRINT_bvs = tmpbvs; + //write out binder + STREAM_printf(outStream, "%s", MCSTR_toCString(DF_strDataValue(bvname))); + PRINT_writeInfixLam(outStream); + } +} + +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 AN APPLICATION * + * * + * Note that it is assumed that nested application structures are flattened * + * during the full normalization process. * + ****************************************************************************/ +/* Getting the fixity and precedence for the head of an application. + Assume the pointer to the term head is already dereferenced. */ +static void PRINT_getHeadInfo(DF_TermPtr hdPtr, OP_FixityType *fx, int* prec) +{ + int cstInd; + switch (DF_termTag(hdPtr)) { + case DF_TM_TAG_CONST: + cstInd = DF_constTabIndex(hdPtr); + if (AM_cstName(cstInd)) { + *fx = (OP_FixityType)AM_cstFixity(cstInd); + *prec = AM_cstPrecedence(cstInd); + } else { + *fx = OP_NONE; + *prec = 0; + } + break; + case DF_TM_TAG_VAR: + *fx = OP_NONE; + *prec = OP_MINPREC; + break; + case DF_TM_TAG_BVAR: + *fx = OP_NONE; + *prec = OP_MINPREC; + break; + } +} + +/* Writing out a term with a prefix operator as head; we use the knowledge +that the operator must be a constant here and that the pointer to it is +fully dereferenced */ +static void PRINT_writePrefixTerm(WordPtr outStream, DF_TermPtr head, + OP_FixityType opfx, int opprec, + OP_TermContext tc, OP_FixityType fx,int prec, + DF_TermPtr args) +{ + Boolean pparen = PRINT_parenNeeded(opfx, opprec, tc, fx, prec); + + if (pparen) PRINT_writeLParen(outStream); + PRINT_writeConst(outStream, head); + PRINT_writeSpace(outStream, 1); + PRINT_writeTerm(outStream, args, opfx, opprec, OP_RIGHT_TERM); + if (pparen) PRINT_writeRParen(outStream); +} + +static void PRINT_writeInfixTerm(WordPtr outStream, DF_TermPtr head, + OP_FixityType opfx, int opprec, + OP_TermContext tc, OP_FixityType fx, int prec, + DF_TermPtr args) +{ + Boolean pparen = PRINT_parenNeeded(opfx, opprec, tc, fx, prec); + if(pparen) PRINT_writeLParen(outStream); + PRINT_writeTerm(outStream, args, opfx, opprec, OP_LEFT_TERM); + PRINT_writeSpace(outStream, 1); + PRINT_writeConst(outStream, head); + PRINT_writeSpace(outStream, 1); + PRINT_writeTerm(outStream, args+1, opfx, opprec, OP_RIGHT_TERM); + if (pparen) PRINT_writeRParen(outStream); +} + +static void PRINT_writePostfixTerm(WordPtr outStream, DF_TermPtr head, + OP_FixityType opfx, int opprec, + OP_TermContext tc,OP_FixityType fx,int prec, + DF_TermPtr args) +{ + Boolean pparen = PRINT_parenNeeded(opfx, opprec, tc, fx, prec); + if(pparen) PRINT_writeLParen(outStream); + PRINT_writeTerm(outStream, args, opfx, opprec, OP_LEFT_TERM); + PRINT_writeSpace(outStream, 1); + PRINT_writeConst(outStream, head); + if (pparen) PRINT_writeRParen(outStream); +} + +/* 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); + } + 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); +} + + +/***************************************************************************** + * 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 */ +} + + +/* Printing a term to a specified output stream; names will be invented for +free variables if the boolean variable PRINT_names is set. */ +void PRINT_fPrintTerm(WordPtr outStream, DF_TermPtr tmPtr) +{ + HN_lnorm(tmPtr); + PRINT_writeTerm(outStream, tmPtr, OP_NONE, 0, OP_WHOLE_TERM); +} + +/* Printing routine for debugging */ +void PRINT_printTerm(DF_TermPtr tmPtr) +{ + PRINT_fPrintTerm(STREAM_stdout, tmPtr); + STREAM_printf(STREAM_stdout, "\n"); +} + +/* printing an answer substitution pair */ +static void PRINT_printSubsPair(WordPtr outStream, int ind) +{ + DF_TermPtr tmPtr; + char *varName = + MCSTR_toCString(DF_strDataValue(IO_freeVarTab[ind].varName)); + + /* print the variable name if it is not an anonymous variable */ + if (strcmp(varName, "_") != 0) { + STREAM_printf(outStream, varName); + + /* Print the equals sign */ + PRINT_writeEquals(outStream); + + /* Print the binding of the variable */ + tmPtr = IO_freeVarTab[ind].rigdes; + HN_lnorm(tmPtr); + PRINT_writeTerm(outStream, tmPtr, OP_NONE, 0, OP_WHOLE_TERM); + } +} + +void PRINT_showAnswerSubs() +{ + int i; + + PRINT_names = TRUE; + + for (i = 0; i < PRINT_numQueryVars; i++) { + PRINT_printSubsPair(STREAM_stdout, i); + STREAM_printf(STREAM_stdout, "\n"); + } +} + +/* Printing a disagreement pair to a specified output stream */ +static void PRINT_printDPair(WordPtr outStream, DF_DisPairPtr dpair) +{ + DF_TermPtr tmPtr; + + PRINT_writeDPairStart(outStream); + + tmPtr = DF_disPairFirstTerm(dpair); + HN_lnorm(tmPtr); + PRINT_writeTerm(outStream, tmPtr, OP_NONE, 0, OP_WHOLE_TERM); + + PRINT_writeComma(outStream); + PRINT_writeSpace(outStream, 1); + + tmPtr = DF_disPairSecondTerm(dpair); + HN_lnorm(tmPtr); + PRINT_writeTerm(outStream, tmPtr, OP_NONE, 0, OP_WHOLE_TERM); + + PRINT_writeDPairEnd(outStream); +} + +void PRINT_showDisAgreeList() +{ + DF_DisPairPtr liveList = AM_llreg; + + while (DF_isNEmpDisSet(liveList)) { + PRINT_printDPair(STREAM_stdout, liveList); + liveList = DF_disPairNext(liveList); + STREAM_printf(STREAM_stdout, "\n"); + } +} + +void PRINT_setQueryFreeVariables() +{ + PRINT_numQueryVars = IO_freeVarTabTop; +} + +/* Use this function to reset the top of the free variable table +after a read; this is logical and also needed to avoid trying +to release print name space accidentally at some other point. */ +void PRINT_resetFreeVarTab() +{ + IO_freeVarTabTop = PRINT_numQueryVars; +} + + +void PRINT_resetPrintState() +{ + /* release space for term variables created during printing */ + while (IO_freeVarTabTop > PRINT_numQueryVars){ + IO_freeVarTabTop--; + free(IO_freeVarTab[IO_freeVarTabTop].varName); + } + + /* reset counters used in names of anonymous term and type variables */ + PRINT_fvcounter = 1; + + /* free space for information created for local consts and reset counter */ + PRINT_cleanCList(); + + /* free space for information created for bound vars and reset counter */ + PRINT_cleanBVList(); +} + +Boolean PRINT_queryHasVars() +{ + int i = PRINT_numQueryVars - 1; + while (!(i < 0) && + (strcmp(MCSTR_toCString(DF_strDataValue(IO_freeVarTab[i].varName)), + "_") == 0)) + i--; + + if (i < 0) return FALSE; + else return TRUE; + +} diff --git a/src/runtime/c/teyjus/simulator/printterm.h b/src/runtime/c/teyjus/simulator/printterm.h new file mode 100644 index 000000000..d6814b5ab --- /dev/null +++ b/src/runtime/c/teyjus/simulator/printterm.h @@ -0,0 +1,62 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File printterm.h{c}. This file contains routines for printing out lambda * + * terms. It is assumed that these routines will be needed in two * + * situations: printing out answers to queries and displaying terms as * + * needed by invocation of builtin goals. * + * The difference between these two situations is in the display of * + * free term variables. Only when displaying answers is an attempt made to * + * present these using sensible names: in this case, either the name in the * + * query is used or a concise name is cooked up. In the other situation, * + * the address of the variable cell is used as the name. * + * * + * Certain assumptions are relevant to avoiding name clashes. For local * + * constants, the assumption is that no constant names in user * + * programs begin with <lc- and end with >. The use of this idea is * + * buried inside the routine PRINT_writeHCName. * + * Violation of this condition is *not* checked. For term variables, the * + * assumption is that bound variables do not begin with _. * + * * + ****************************************************************************/ + +#ifndef PRINTTERM_H +#define PRINTTERM_H + +#include "dataformats.h" +#include "mctypes.h" + +/* set this variable to FALSE if variable names are to be displayed as +`numbers' */ +extern Boolean PRINT_names; + +void PRINT_fPrintTerm(WordPtr outStream, DF_TermPtr tmPtr); +void PRINT_showAnswerSubs(); +void PRINT_showDisAgreeList(); + +void PRINT_resetFreeVarTab(); +void PRINT_setQueryFreeVariables(); +void PRINT_resetPrintState(); +Boolean PRINT_queryHasVars(); + +//for debugging (display on stdout ) +void PRINT_printTerm(DF_TermPtr tmPtr); +#endif //PRINTTERM_H diff --git a/src/runtime/c/teyjus/simulator/simdispatch.c b/src/runtime/c/teyjus/simulator/simdispatch.c new file mode 100644 index 000000000..4567bb092 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/simdispatch.c @@ -0,0 +1,160 @@ +/***************************************************************************/ +/* */ +/* File simdispatch.c. The instruction dispatch table used by the */ +/* simulator is defined here as an array of function pointers, each of */ +/* which refers to a function realizing a corresponding instruction. */ +/* These functions are defined in the file ./siminstr.c. */ +/***************************************************************************/ + +#include "../tables/instructions.h" //to be modified +#include "siminstr.h" +#include "simdispatch.h" + +SDP_InstrFunctionPtr SDP_dispatchTable[INSTR_NUM_INSTRS] = { + SINSTR_put_variable_t, + SINSTR_put_variable_p, + SINSTR_put_value_t, + SINSTR_put_value_p, + SINSTR_put_unsafe_value, + SINSTR_copy_value, + SINSTR_put_m_const, + SINSTR_put_p_const, + SINSTR_put_nil, + SINSTR_put_integer, + SINSTR_put_float, + SINSTR_put_string, + SINSTR_put_index, + SINSTR_put_app, + SINSTR_put_list, + SINSTR_put_lambda, + SINSTR_set_variable_t, + SINSTR_set_variable_te, + SINSTR_set_variable_p, + SINSTR_set_value_t, + SINSTR_set_value_p, + SINSTR_globalize_pt, + SINSTR_globalize_t, + SINSTR_set_m_const, + SINSTR_set_p_const, + SINSTR_set_nil, + SINSTR_set_integer, + SINSTR_set_float, + SINSTR_set_string, + SINSTR_set_index, + SINSTR_set_void, + SINSTR_deref, + SINSTR_set_lambda, + SINSTR_get_variable_t, + SINSTR_get_variable_p, + SINSTR_init_variable_t, + SINSTR_init_variable_p, + SINSTR_get_m_constant, + SINSTR_get_p_constant, + SINSTR_get_integer, + SINSTR_get_float, + SINSTR_get_string, + SINSTR_get_nil, + SINSTR_get_m_structure, + SINSTR_get_p_structure, + SINSTR_get_list, + SINSTR_unify_variable_t, + SINSTR_unify_variable_p, + SINSTR_unify_value_t, + SINSTR_unify_value_p, + SINSTR_unify_local_value_t, + SINSTR_unify_local_value_p, + SINSTR_unify_m_constant, + SINSTR_unify_p_constant, + SINSTR_unify_integer, + SINSTR_unify_float, + SINSTR_unify_string, + SINSTR_unify_nil, + SINSTR_unify_void, + SINSTR_put_type_variable_t, + SINSTR_put_type_variable_p, + SINSTR_put_type_value_t, + SINSTR_put_type_value_p, + SINSTR_put_type_unsafe_value, + SINSTR_put_type_const, + SINSTR_put_type_structure, + SINSTR_put_type_arrow, + SINSTR_set_type_variable_t, + SINSTR_set_type_variable_p, + SINSTR_set_type_value_t, + SINSTR_set_type_value_p, + SINSTR_set_type_local_value_t, + SINSTR_set_type_local_value_p, + SINSTR_set_type_constant, + SINSTR_get_type_variable_t, + SINSTR_get_type_variable_p, + SINSTR_init_type_variable_t, + SINSTR_init_type_variable_p, + SINSTR_get_type_value_t, + SINSTR_get_type_value_p, + SINSTR_get_type_constant, + SINSTR_get_type_structure, + SINSTR_get_type_arrow, + SINSTR_unify_type_variable_t, + SINSTR_unify_type_variable_p, + SINSTR_unify_type_value_t, + SINSTR_unify_type_value_p, + SINSTR_unify_envty_value_t, + SINSTR_unify_envty_value_p, + SINSTR_unify_type_local_value_t, + SINSTR_unify_type_local_value_p, + SINSTR_unify_envty_local_value_t, + SINSTR_unify_envty_local_value_p, + SINSTR_unify_type_constant, + SINSTR_pattern_unify_t, + SINSTR_pattern_unify_p, + SINSTR_finish_unify, + SINSTR_head_normalize_t, + SINSTR_head_normalize_p, + SINSTR_incr_universe, + SINSTR_decr_universe, + SINSTR_set_univ_tag, + SINSTR_tag_exists_t, + SINSTR_tag_exists_p, + SINSTR_tag_variable, + SINSTR_push_impl_point, + SINSTR_pop_impl_point, + SINSTR_add_imports, + SINSTR_remove_imports, + SINSTR_push_import, + SINSTR_pop_imports, + SINSTR_allocate, + SINSTR_deallocate, + SINSTR_call, + SINSTR_call_name, + SINSTR_execute, + SINSTR_execute_name, + SINSTR_proceed, + SINSTR_try_me_else, + SINSTR_retry_me_else, + SINSTR_trust_me, + SINSTR_try, + SINSTR_retry, + SINSTR_trust, + SINSTR_trust_ext, + SINSTR_try_else, + SINSTR_retry_else, + SINSTR_branch, + SINSTR_switch_on_term, + SINSTR_switch_on_constant, + SINSTR_switch_on_bvar, + SINSTR_switch_on_reg, + SINSTR_neck_cut, + SINSTR_get_level, + SINSTR_put_level, + SINSTR_cut, + SINSTR_call_builtin, + SINSTR_builtin, + SINSTR_stop, + SINSTR_halt, + SINSTR_fail, + SINSTR_create_type_variable, + SINSTR_execute_link_only, + SINSTR_call_link_only, + SINSTR_put_variable_te +}; + diff --git a/src/runtime/c/teyjus/simulator/simdispatch.h b/src/runtime/c/teyjus/simulator/simdispatch.h new file mode 100644 index 000000000..2a5f1475c --- /dev/null +++ b/src/runtime/c/teyjus/simulator/simdispatch.h @@ -0,0 +1,37 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* */ +/* File simdispatch.h. The instruction dispatch table used by the */ +/* simulator is defined here as an array of function pointers, each of */ +/* which refers to a function realizing a corresponding instruction. */ +/* These functions are defined in the file ./siminstr.c. */ +/***************************************************************************/ +#ifndef SIMDISPATCH_H +#define SIMDISPATCH_H + +//the function pointer type of instructions +typedef void (* SDP_InstrFunctionPtr)(); + +//instruction dispatch table +extern SDP_InstrFunctionPtr SDP_dispatchTable[]; + + +#endif //SIMDISPATCH_H diff --git a/src/runtime/c/teyjus/simulator/siminit.c b/src/runtime/c/teyjus/simulator/siminit.c new file mode 100644 index 000000000..b6de2acea --- /dev/null +++ b/src/runtime/c/teyjus/simulator/siminit.c @@ -0,0 +1,275 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************/ +/* */ +/* File siminit.c. */ +/**************************************************************************/ +#ifndef SIMINIT_C +#define SIMINIT_C + +#include "siminit.h" +#include "abstmachine.h" +#include "dataformats.h" +#include "io-datastructures.h" +#include "builtins/builtins.h" +#include "../tables/instructions.h" +#include "../system/error.h" +#include "../system/message.h" + +#include <stdio.h> +/***************************######******************************************** + * ERROR INFORMATION + *********************************######**************************************/ +static MSG_Msg SIM_errorMessages[SIM_NUM_ERROR_MESSAGES] = +{ + { SIM_ERROR, + 0, + "Simulator: ", + 0, 0, 0 }, + { SIM_ERROR_TOO_MANY_ABSTRACTIONS, + SIM_ERROR, + "Abstraction embedding depth has exceeded maximum of %d.", + EM_NEWLINE, EM_TOP_LEVEL, 4 }, + { SIM_ERROR_TOO_MANY_ARGUMENTS, + SIM_ERROR, + "Application arguments has exceeded maximum of %d.", + EM_NEWLINE, EM_TOP_LEVEL, 4 }, + { SIM_ERROR_TOO_MANY_UNIV_QUANTS, + SIM_ERROR, + "Too many universal quantifiers.", + EM_NEWLINE, EM_TOP_LEVEL, 3 }, + { SIM_ERROR_HEAP_TOO_BIG, + SIM_ERROR, + "Specified heap size (%uK) is larger than maximum of 256Gb.", + EM_NEWLINE, EM_ABORT, 1 }, + { SIM_ERROR_HEAP_TOO_SMALL, + SIM_ERROR, + "Specified heap size (%uK) is smaller than minimum of 10K.", + EM_NEWLINE, EM_ABORT, 1 }, + { SIM_ERROR_CANNOT_ALLOCATE_HEAP, + SIM_ERROR_CANNOT_ALLOCATE_HEAP_MESSAGE, + "", + SIM_ERROR_CANNOT_ALLOCATE_HEAP_SUGGESTION, EM_ABORT, 1 }, + { SIM_ERROR_CANNOT_ALLOCATE_HEAP_MESSAGE, + SIM_ERROR, + "Could not allocate heap of size %uK at 0x%08x using %s.", + EM_NEWLINE, EM_NO_EXN, 1 }, + { SIM_ERROR_CANNOT_ALLOCATE_HEAP_SUGGESTION, + SIM_ERROR, + "Try modifying the configuration and recompiling.", + EM_NEWLINE, EM_NO_EXN, 1 }, + { SIM_ERROR_TRAIL_OVERFL, + SIM_ERROR, + "Trail overflow.", + EM_NEWLINE, EM_TOP_LEVEL, 1 }, + { SIM_ERROR_HEAP_OVERFL, + SIM_ERROR, + "Heap overflow.", + EM_NEWLINE, EM_TOP_LEVEL, 1 }, + { SIM_ERROR_STACK_OVERFL, + SIM_ERROR, + "Stack overflow.", + EM_NEWLINE, EM_TOP_LEVEL, 1 }, + { SIM_ERROR_PDL_OVERFL, + SIM_ERROR, + "PDL overflow.", + EM_NEWLINE, EM_TOP_LEVEL, 1 } +}; + + +/*************************************************************************/ +/* SETTING UP SPECIAL CODE SEGMENTS */ +/*************************************************************************/ +static const int SINIT_initSize = 31; + +static void SINIT_initCode() +{ + MemPtr nhreg = AM_hreg + SINIT_initSize; + CSpacePtr myhreg = (CSpacePtr)AM_hreg; + + AM_heapError(nhreg); + + //builtinCode + AM_builtinCode = myhreg; + *((INSTR_OpCode*)myhreg) = builtin; //builtin ... + myhreg += INSTR_I1X_LEN; + + //eqCode + AM_eqCode = myhreg; + *((INSTR_OpCode*)myhreg) = pattern_unify_t; //pattern_unify A1, A2 + *((INSTR_RegInd*)(myhreg + INSTR_RRX_R1)) = 1; + *((INSTR_RegInd*)(myhreg + INSTR_RRX_R2)) = 2; + myhreg += INSTR_RRX_LEN; + *((INSTR_OpCode*)myhreg) = finish_unify; //finish_unify + myhreg += INSTR_X_LEN; + *((INSTR_OpCode*)myhreg) = proceed; //proceed + myhreg += INSTR_X_LEN; + + //failCode + AM_failCode = myhreg; + *((INSTR_OpCode*)myhreg) = fail; //fail + myhreg += INSTR_X_LEN; + + //andCode + *((INSTR_OneByteInt*)(myhreg + INSTR_I1LX_I1)) = 2;//"call" 2 L + myhreg += INSTR_I1LX_LEN; + AM_andCode = myhreg; + *((INSTR_OpCode*)myhreg) = put_value_p; //put_value Y1, A1 + *((INSTR_EnvInd*)(myhreg + INSTR_ERX_E)) = 1; + *((INSTR_RegInd*)(myhreg + INSTR_ERX_R)) = 1; + myhreg += INSTR_ERX_LEN; + *((INSTR_OpCode*)myhreg) = put_level; //put_level Y2 + *((INSTR_EnvInd*)(myhreg + INSTR_EX_E)) = 2; + myhreg += INSTR_EX_LEN; + *((INSTR_OpCode*)myhreg) = deallocate; //deallocate + myhreg += INSTR_X_LEN; + + //solveCode + AM_solveCode = myhreg; + *((INSTR_OpCode*)myhreg) = builtin; //builtin BI_SOLVE + *((INSTR_OneByteInt*)(myhreg + INSTR_I1X_I1)) = BI_SOLVE; + myhreg += INSTR_I1X_LEN; + + //proceed + AM_proceedCode = myhreg; //proceed + *((INSTR_OpCode*)myhreg) = proceed; + myhreg += INSTR_X_LEN; + + //orCode + AM_orCode = myhreg; + *((INSTR_OpCode*)myhreg) = trust_me; //trust_me 1 + *((INSTR_OneByteInt*)(myhreg + INSTR_I1WPX_I1)) = 1; + myhreg += INSTR_I1WPX_LEN; + *((INSTR_OpCode*)myhreg) = builtin; //builtin BI_SOLVE + *((INSTR_OneByteInt*)(myhreg + INSTR_I1X_I1)) = BI_SOLVE; + myhreg += INSTR_I1X_LEN; + + //allcode + *((INSTR_OneByteInt*)(myhreg + INSTR_I1LX_I1)) = 0; //"call" 0 L + myhreg += INSTR_I1LX_LEN; + AM_allCode = myhreg; + *((INSTR_OpCode*)myhreg) = decr_universe; //decr_universe + myhreg += INSTR_X_LEN; + *((INSTR_OpCode*)myhreg) = deallocate; //deallocate + myhreg += INSTR_X_LEN; + *((INSTR_OpCode*)myhreg) = proceed; //proceed + myhreg += INSTR_X_LEN; + + //stopCode + AM_stopCode = myhreg; + *((INSTR_OpCode*)myhreg) = stop; //stop + myhreg += INSTR_X_LEN; + + //notCode2 + AM_notCode2 = myhreg; + *((INSTR_OpCode*)myhreg) = trust_me; //trust_me 0 + *((INSTR_OneByteInt*)(myhreg + INSTR_I1WPX_I1)) = 0; + myhreg += INSTR_I1WPX_LEN; + *((INSTR_OpCode*)myhreg) = proceed; //proceed + myhreg += INSTR_X_LEN; + + //notCode1 + AM_notCode1 = myhreg; + *((INSTR_OpCode*)myhreg) = allocate; //allocate 2 + *((INSTR_OneByteInt*)(myhreg + INSTR_I1X_I1)) = 2; + myhreg += INSTR_I1X_LEN; + *((INSTR_OpCode*)myhreg) = get_level; //get_level Y1 + *((INSTR_EnvInd*)(myhreg + INSTR_EX_E)) = 1; + myhreg += INSTR_EX_LEN; + *((INSTR_OpCode*)myhreg) = call_builtin; //call_builtin 1 BI_SOLVE + *((INSTR_OneByteInt*)(myhreg + INSTR_I1I1WPX_I11)) = 1; + *((INSTR_OneByteInt*)(myhreg + INSTR_I1I1WPX_I12)) = BI_SOLVE; + myhreg += INSTR_I1I1WPX_LEN; + *((INSTR_OpCode*)myhreg) = cut; //cut 1 + *((INSTR_EnvInd*)(myhreg + INSTR_EX_E)) = 1; + myhreg += INSTR_EX_LEN; + *((INSTR_OpCode*)myhreg) = fail; //fail + myhreg += INSTR_X_LEN; + + //haltCode + AM_haltCode = myhreg; + *((INSTR_OpCode*)myhreg) = halt; //halt + myhreg += INSTR_X_LEN; + + AM_hreg = nhreg; +} + +/***************************************************************************** + * THE PUBLIC ROUTINES * + *****************************************************************************/ +void SINIT_preInit() +{ + /* errors get initialized before ANYTHING */ + MSG_addMessages(SIM_NUM_ERROR_MESSAGES, SIM_errorMessages); +} + +void SINIT_simInit() +{ + AM_hreg = AM_heapBeg; //heap + AM_hbreg = AM_heapBeg; + AM_ereg = AM_stackBeg; //stack + AM_ireg = AM_stackBeg; + AM_cireg = AM_stackBeg; + AM_initPDL(); //pdl + AM_trreg = AM_trailBeg; //trail + AM_llreg = DF_EMPTY_DIS_SET; //live list + AM_bndFlag = OFF; //bind flag + AM_ucreg = 0; //uc reg + + //make a dummy first mod point at the beginning of the stack + AM_mkDummyImptRec(AM_ireg); + + /* perform initialization for the term io system */ + IO_initIO(); + + /* and set up some built-in code */ + SINIT_initCode(); + + /* set up the base branch register to put the heap back to this point */ + AM_breg = AM_stackBeg + AM_DUMMY_IMPT_REC_SIZE; + *AM_breg = (Mem)AM_hreg; + + AM_fstCP = AM_b0reg = AM_breg; + AM_tosreg = AM_breg + 1; +} + +void SINIT_reInitSimState(Boolean inDoInitializeImports) +{ + AM_initPDL(); //pdl + AM_ereg = AM_stackBeg; //stack + AM_trreg = AM_trailBeg; //trail + AM_llreg = DF_EMPTY_DIS_SET; //live list + AM_ucreg = 0; //uc reg + AM_bndFlag = OFF; //bind flag + AM_breg = AM_fstCP; + AM_hreg = AM_cpH(); + AM_hreg = *((MemPtr *)AM_breg); + + /* initialize ireg if necessary */ + if (inDoInitializeImports) { + AM_ireg = AM_stackBeg; + AM_tosreg = AM_breg + 1; + } + + IO_initIO(); +} + + +#endif //SIMINIT_H diff --git a/src/runtime/c/teyjus/simulator/siminit.h b/src/runtime/c/teyjus/simulator/siminit.h new file mode 100644 index 000000000..0dd8fa749 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/siminit.h @@ -0,0 +1,33 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************/ +/* */ +/* File siminit.h. */ +/**************************************************************************/ +#ifndef SIMINIT_H +#define SIMINIT_H +#include "mctypes.h" + +void SINIT_preInit(); +void SINIT_simInit(); +void SINIT_reInitSimState(Boolean inDoInitializeImports); + + +#endif //SIMUINIT_H diff --git a/src/runtime/c/teyjus/simulator/siminstr.c b/src/runtime/c/teyjus/simulator/siminstr.c new file mode 100644 index 000000000..6cb78cc38 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/siminstr.c @@ -0,0 +1,1846 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* File siminstr.c. The instruction set of the virtual machine. */ +/*****************************************************************************/ +#ifndef SIMINSTR_C +#define SIMINSTR_C + +#include "siminstr.h" +#include "dataformats.h" +#include "abstmachine.h" +#include "trail.h" +#include "hnorm.h" +#include "hopu.h" +#include "types.h" +#include "instraccess.h" +#include "siminstrlocal.h" +#include "builtins/builtins.h" +#include "../system/error.h" +#include "../tables/pervasives.h" +#include "../tables/instructions.h" +#include "../loader/searchtab.h" + + +#include <stdio.h> +#include "printterm.h" +#include "../system/stream.h" + +static AM_DataTypePtr regX, regA; +static AM_DataTypePtr envY, clenvY; +static DF_TermPtr tmPtr, func; +static DF_TypePtr tyPtr; +static MemPtr nhreg, ip, ep, cp; +static MemPtr impTab; +static MemPtr table; +static MemPtr bckfd; +static MemPtr nextcl; +static int constInd, kindInd, tablInd; +static int n, m, l, uc, numAbs; +static int intValue; +static float floatValue; +static DF_StrDataPtr str; +static CSpacePtr label, cl; + +/****************************************************************************/ +/* INSTRUCTIONS FOR UNIFYING AND CREATING TERMS */ +/****************************************************************************/ + +/**************************************************************************/ +/* PUT CLASS */ +/**************************************************************************/ +void SINSTR_put_variable_t() //put_variable Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkVar(AM_hreg, AM_ucreg); + DF_mkRef((MemPtr)regX, (DF_TermPtr)AM_hreg); + *regA = *regX; + AM_hreg = nhreg; +} + +void SINSTR_put_variable_te() //put_variable_te Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkVar(AM_hreg, AM_envUC()); + DF_mkRef((MemPtr)regX, (DF_TermPtr)AM_hreg); + *regA = *regX; + AM_hreg = nhreg; +} + +void SINSTR_put_variable_p() //put_variable Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + DF_mkVar((MemPtr)envY, AM_envUC()); + DF_mkRef((MemPtr)regA, (DF_TermPtr)envY); +} + +void SINSTR_put_value_t() //put_value Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + *regA = *regX; +} + +void SINSTR_put_value_p() //put_value Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + tmPtr = DF_termDeref((DF_TermPtr)envY); + if ((!AM_stackAddr((MemPtr)tmPtr)) || DF_isFV(tmPtr)) + DF_mkRef((MemPtr)regA, tmPtr); + else *regA = *((AM_DataTypePtr)tmPtr); //cons or (mono) constants on stack +} + +void SINSTR_put_unsafe_value() //put_unsafe_value Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + + tmPtr = DF_termDeref((DF_TermPtr)envY); + switch (DF_termTag(tmPtr)) { + case DF_TM_TAG_NIL: + case DF_TM_TAG_CONS: + case DF_TM_TAG_INT: + case DF_TM_TAG_FLOAT: + case DF_TM_TAG_STR: + case DF_TM_TAG_STREAM: + {*regA = *((AM_DataTypePtr)tmPtr); break; } + case DF_TM_TAG_CONST: + { + if (DF_isTConst(tmPtr)) DF_mkRef((MemPtr)regA, tmPtr); + else *regA = *((AM_DataTypePtr)tmPtr); + break; + } + case DF_TM_TAG_VAR: + { + if (AM_inCurEnv((MemPtr)tmPtr)) { + AM_heapError(AM_hreg + DF_TM_ATOMIC_SIZE); + TR_trailETerm(tmPtr); + DF_copyAtomic(tmPtr, AM_hreg); + DF_mkRef((MemPtr)tmPtr, (DF_TermPtr)AM_hreg); + AM_hreg += DF_TM_ATOMIC_SIZE; + *regA = *((AM_DataTypePtr)tmPtr); + } else + DF_mkRef((MemPtr)regA, tmPtr); + break; + } + default: { DF_mkRef((MemPtr)regA, tmPtr); break; } + } +} + +void SINSTR_copy_value() //copy_value Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + tmPtr = DF_termDeref((DF_TermPtr)envY); + if (AM_stackAddr((MemPtr)tmPtr)) { + *regA = *((AM_DataTypePtr)tmPtr); + } else DF_mkRef((MemPtr)regA, tmPtr); +} + +void SINSTR_put_m_const() //put_m_const Ai,c -- R_C_X +{ + INSACC_RCX(regA, constInd); + DF_mkConst((MemPtr)regA, AM_cstUnivCount(constInd), constInd); +} + +void SINSTR_put_p_const() //put_p_const Ai,c -- R_C_X +{ + INSACC_RCX(regA, constInd); + nhreg = AM_hreg + DF_TM_TCONST_SIZE; + AM_heapError((MemPtr)(((DF_TypePtr)nhreg) + AM_cstTyEnvSize(constInd))); + DF_mkTConst(AM_hreg, AM_cstUnivCount(constInd), constInd,(DF_TypePtr)nhreg); + DF_mkRef((MemPtr)regA, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; +} + +void SINSTR_put_nil() //put_nil Ai -- R_X +{ + INSACC_RX(regA); + DF_mkNil((MemPtr)regA); +} + +void SINSTR_put_integer() //put_integer Ai,i -- R_I_X +{ + INSACC_RIX(regA, intValue); + DF_mkInt((MemPtr)regA, intValue); +} + +void SINSTR_put_float() //put_float Ai,f -- R_F_X +{ + INSACC_RFX(regA, floatValue); + DF_mkFloat((MemPtr)regA, floatValue); +} + +void SINSTR_put_string() //put_string Ai,str -- R_S_X +{ + INSACC_RSX(regA, str); + DF_mkStr((MemPtr)regA, str); +} + +void SINSTR_put_index() //put_index Ai,n -- R_I1_X +{ + INSACC_RI1X(regA, n); + nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkBV(AM_hreg, n); + DF_mkRef((MemPtr)regA, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; +} + +void SINSTR_put_app() //put_app Ai,Xj,n -- R_R_I1_X +{ + INSACC_RRI1X(regA, regX, n); + nhreg = (MemPtr)(((DF_TermPtr)(AM_hreg + DF_TM_APP_SIZE)) + n); + if (DF_isRef((DF_TermPtr)regX)) { + AM_heapError(nhreg); + tmPtr = DF_refTarget((DF_TermPtr)regX); + } else { //regX not a reference + nhreg += DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_copyAtomic((DF_TermPtr)regX, AM_hreg); + tmPtr = (DF_TermPtr)AM_hreg; + AM_hreg += DF_TM_ATOMIC_SIZE; + } + AM_sreg = (DF_TermPtr)(AM_hreg + DF_TM_APP_SIZE); + DF_mkApp(AM_hreg, n, tmPtr, AM_sreg); + DF_mkRef((MemPtr)regA, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; +} + +void SINSTR_put_list() //put_list Ai -- R_X +{ + INSACC_RX(regA); + nhreg = (MemPtr)(((DF_TermPtr)AM_hreg) + DF_CONS_ARITY); + AM_heapError(nhreg); + AM_sreg = (DF_TermPtr)AM_hreg; + DF_mkCons((MemPtr)regA, AM_sreg); + AM_hreg = nhreg; +} + +void SINSTR_put_lambda() //put_lambda Ai,Xj,n -- R_R_I1_X +{ + INSACC_RRI1X(regA, regX, n); + nhreg = AM_hreg + DF_TM_LAM_SIZE; + if (DF_isRef((DF_TermPtr)regX)) { + AM_heapError(nhreg); + tmPtr = DF_refTarget((DF_TermPtr)regX); + } else { + nhreg += DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_copyAtomic((DF_TermPtr)regX, AM_hreg); + tmPtr = (DF_TermPtr)AM_hreg; + AM_hreg += DF_TM_ATOMIC_SIZE; + } + DF_mkLam(AM_hreg, n, tmPtr); + DF_mkRef((MemPtr)regA, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; +} + +/*************************************************************************/ +/* SET CLASS */ +/*************************************************************************/ +void SINSTR_set_variable_t() //set_variable Xi -- R_X +{ + INSACC_RX(regX); + DF_mkVar((MemPtr)AM_sreg, AM_ucreg); + DF_mkRef((MemPtr)regX, AM_sreg); + AM_sreg++; +} + +void SINSTR_set_variable_te() //set_variable_te Xi -- R_X +{ + INSACC_RX(regX); + DF_mkVar((MemPtr)AM_sreg, AM_envUC()); + DF_mkRef((MemPtr)regX, AM_sreg); + AM_sreg++; +} + +void SINSTR_set_variable_p() //set_variable_p Yi -- E_X +{ + INSACC_EX(envY); + DF_mkVar((MemPtr)AM_sreg, AM_envUC()); + DF_mkRef((MemPtr)envY, AM_sreg); + AM_sreg++; +} + +void SINSTR_set_value_t() //set_value Xi -- R_X +{ + INSACC_RX(regX); + DF_copyAtomic((DF_TermPtr)regX, (MemPtr)AM_sreg); + AM_sreg++; +} + +void SINSTR_set_value_p() //set_value Yi -- E_X +{ + INSACC_EX(envY); + tmPtr = DF_termDeref((DF_TermPtr)envY); + if (AM_stackAddr((MemPtr)tmPtr)) { //needed?; in fact, what if a fv? + //printf("set_value_p -- stack addr\n"); + DF_copyAtomic(tmPtr, (MemPtr)AM_sreg); + } else DF_mkRef((MemPtr)AM_sreg, tmPtr); + AM_sreg++; +} + +void SINSTR_globalize_pt() //globalize_pt Yj,Xi -- E_R_X +{ + INSACC_ERX(envY, regX); + tmPtr = DF_termDeref((DF_TermPtr)envY); + if (AM_stackAddr((MemPtr)tmPtr)) { + nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_copyAtomic(tmPtr, AM_hreg); + if (DF_isFV(tmPtr)) { + TR_trailETerm(tmPtr); + DF_mkRef((MemPtr)tmPtr, (DF_TermPtr)AM_hreg); + } + DF_mkRef((MemPtr)regX, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; + } else DF_mkRef((MemPtr)regX, tmPtr); +} + +void SINSTR_globalize_t() //globalize_t Xi -- R_X +{ + INSACC_RX(regX); + tmPtr = DF_termDeref((DF_TermPtr)regX); + if (AM_nHeapAddr((MemPtr)tmPtr)){ + nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_copyAtomic(tmPtr, AM_hreg); + if (DF_isFV(tmPtr)) { + TR_trailETerm(tmPtr); + DF_mkRef((MemPtr)tmPtr, (DF_TermPtr)AM_hreg); + } + DF_mkRef((MemPtr)regX, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; + } else DF_mkRef((MemPtr)regX, tmPtr); +} + +void SINSTR_set_m_const() //set_m_const c -- C_X +{ + INSACC_CX(constInd); + DF_mkConst((MemPtr)AM_sreg, AM_cstUnivCount(constInd), constInd); + AM_sreg++; +} + +void SINSTR_set_p_const() //set_p_const c -- C_X +{ + INSACC_CX(constInd); + nhreg = AM_hreg + DF_TM_TCONST_SIZE; + AM_heapError(nhreg + AM_cstTyEnvSize(constInd) * DF_TY_ATOMIC_SIZE); + DF_mkTConst(AM_hreg,AM_cstUnivCount(constInd),constInd,(DF_TypePtr)nhreg); + DF_mkRef((MemPtr)AM_sreg, (DF_TermPtr)AM_hreg); + AM_sreg++; + AM_hreg = nhreg; +} + +void SINSTR_set_nil() //set_nil -- X +{ + INSACC_X(); + DF_mkNil((MemPtr)AM_sreg); + AM_sreg++; +} + +void SINSTR_set_integer() //set_integer i -- I_X +{ + INSACC_IX(intValue); + DF_mkInt((MemPtr)AM_sreg, intValue); + AM_sreg++; +} + +void SINSTR_set_float() //set_float f -- F_X +{ + INSACC_FX(floatValue); + DF_mkFloat((MemPtr)AM_sreg, floatValue); + AM_sreg++; +} + +void SINSTR_set_string() //set_string str -- S_X +{ + INSACC_SX(str); + DF_mkStr((MemPtr)AM_sreg, str); + AM_sreg++; +} + +void SINSTR_set_index() //set_index n -- I1_X +{ + INSACC_I1X(n); + DF_mkBV((MemPtr)AM_sreg, n); + AM_sreg++; +} + +void SINSTR_set_void() //set_void n -- I1_X +{ + INSACC_I1X(n); + while (n > 0) { + DF_mkVar((MemPtr)AM_sreg, AM_ucreg); + AM_sreg++; + n--; + } +} + +void SINSTR_deref() //deref Xi -- R_X; needed? +{ + INSACC_RX(regX); + regA = (AM_DataTypePtr)(DF_termDeref((DF_TermPtr)regX)); + *regX = *regA; //assume an atomic term? +} + +void SINSTR_set_lambda() //set_lambda Xi, n -- R_I1_X; needed? +{ + INSACC_RI1X(regX, n); + if (!DF_isRef((DF_TermPtr)regX)) { + nhreg += DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_copyAtomic((DF_TermPtr)regX, AM_hreg); + DF_mkRef((MemPtr)regX, (DF_TermPtr)AM_hreg); + AM_hreg += DF_TM_ATOMIC_SIZE; + } + DF_mkLam((MemPtr)AM_sreg, n, DF_refTarget((DF_TermPtr)regX)); + AM_sreg++; +} + +/*************************************************************************/ +/* GET CLASS */ +/*************************************************************************/ + +void SINSTR_get_variable_t() //get_variable Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + *regX = *regA; +} + +void SINSTR_get_variable_p() //get_variable Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + *envY = *regA; +} + +void SINSTR_init_variable_t() //init_variable Xn,Ym -- R_CE_X +{ + INSACC_RCEX(regA, clenvY); + DF_mkRef((MemPtr)regA, DF_termDeref((DF_TermPtr)clenvY)); +} + +void SINSTR_init_variable_p() //init_variable Yn,Ym -- E_CE_X +{ + INSACC_ECEX(envY, clenvY); + DF_mkRef((MemPtr)envY, DF_termDeref((DF_TermPtr)clenvY)); +} + +void SINSTR_get_m_constant() //get_m_constant Xi,c -- R_C_X +{ + INSACC_RCX(regX, constInd); + tmPtr = DF_termDeref((DF_TermPtr)regX); + SINSTRL_unifyConst(tmPtr, constInd); +} + +void SINSTR_get_p_constant() //get_p_constant Xi,c,L -- R_C_L_X +{ + INSACC_RCLX(regX, constInd, label); + tmPtr = DF_termDeref((DF_TermPtr)regX); + SINSTRL_unifyTConst(tmPtr, constInd, label); +} + +void SINSTR_get_integer() //get_integer Xi,i -- R_I_X +{ + INSACC_RIX(regX, intValue); + tmPtr = DF_termDeref((DF_TermPtr)regX); + SINSTRL_unifyInt(tmPtr, intValue); +} + +void SINSTR_get_float() //get_float Xi,f -- R_F_X +{ + INSACC_RFX(regX, floatValue); + tmPtr = DF_termDeref((DF_TermPtr)regX); + SINSTRL_unifyFloat(tmPtr, floatValue); +} + +void SINSTR_get_string() //get_string Xi,str --R_S_X +{ + INSACC_RSX(regX, str); + tmPtr = DF_termDeref((DF_TermPtr)regX); + SINSTRL_unifyString(tmPtr, str); +} + +void SINSTR_get_nil() //get_nil Xi -- R_X +{ + INSACC_RX(regX); + tmPtr = DF_termDeref((DF_TermPtr)regX); + SINSTRL_unifyNil(tmPtr); + +} + +void SINSTR_get_m_structure() //get_m_structure Xi,f,n--R_C_I1_X +{ + INSACC_RCI1X(regX, constInd, n); + tmPtr = DF_termDeref((DF_TermPtr)regX); + switch (DF_termTag(tmPtr)) { + case DF_TM_TAG_VAR: + { + if (DF_fvUnivCount(tmPtr) >= AM_cstUnivCount(constInd)) { + SINSTRL_bindStr(tmPtr, constInd, n); + return; + } else { + EM_THROW(EM_FAIL); + } + } + case DF_TM_TAG_APP: + { + func = DF_termDeref(DF_appFunc(tmPtr)); + if (DF_isConst(func)) { + if ((DF_constTabIndex(func)==constInd)&&(DF_appArity(tmPtr)==n)){ + AM_sreg = DF_appArgs(tmPtr); AM_writeFlag = OFF; //READ MODE + return; + } else EM_THROW(EM_FAIL); //diff const head + } //otherwise continue with the next case + } + case DF_TM_TAG_LAM: case DF_TM_TAG_SUSP: //and other APP cases + { + HN_hnorm(tmPtr); + if (AM_rigFlag) { + if (DF_isConst(AM_head) && (DF_constTabIndex(AM_head) == constInd)){ + if (AM_numArgs == (AM_numAbs + n)){ + if (AM_numAbs == 0) { + AM_sreg = AM_argVec; AM_writeFlag = OFF; //READ MODE + } else SINSTRL_delayStr(tmPtr, constInd, n); //#abs > 0 + } else EM_THROW(EM_FAIL); //numArgs != numAbs + n + } else EM_THROW(EM_FAIL); //non const rig head or diff const head + } else { //AM_rigFlag == OFF + if (AM_numArgs == 0) { + if ((AM_numAbs == 0) && + (DF_fvUnivCount(AM_head) >= AM_cstUnivCount(constInd))) + SINSTRL_bindStr(AM_head, constInd, n); + else EM_THROW(EM_FAIL); + } else SINSTRL_delayStr(tmPtr, constInd, n); + } //AM_rigFlag == OFF + return; + } + default: + {//CONS, NIL, CONST, INT, FLOAT, STR, BV, (STREAM) + EM_THROW(EM_FAIL); + } + } //switch +} + +void SINSTR_get_p_structure() //get_p_structure Xi,f,n--R_C_I1_X +{ + INSACC_RCI1X(regX, constInd, n); + tmPtr = DF_termDeref((DF_TermPtr)regX); + switch (DF_termTag(tmPtr)) { + case DF_TM_TAG_VAR: + { + if (DF_fvUnivCount(tmPtr) >= AM_cstUnivCount(constInd)) { + SINSTRL_bindTStr(tmPtr, constInd, n); + return; + } else { + EM_THROW(EM_FAIL); + } + } + case DF_TM_TAG_APP: + { + func = DF_termDeref(DF_appFunc(tmPtr)); + if (DF_isConst(func)) { + if ((DF_constTabIndex(func)==constInd)&&(DF_appArity(tmPtr)==n)){ + AM_sreg = DF_appArgs(tmPtr); AM_writeFlag = OFF; + AM_tysreg = DF_constType(func); AM_tyWriteFlag = OFF; + return; + } else EM_THROW(EM_FAIL); //diff const head + } //otherwise continue with the next case + } + case DF_TM_TAG_LAM: case DF_TM_TAG_SUSP: //and other APP cases + { + HN_hnorm(tmPtr); + if (AM_rigFlag) { + if (DF_isConst(AM_head) && (DF_constTabIndex(AM_head) == constInd)){ + if (AM_numAbs == (AM_numArgs + n)){ + if (AM_numAbs == 0) {//first order app + AM_sreg = AM_argVec; AM_writeFlag = OFF; + AM_tysreg = DF_constType(AM_head);AM_tyWriteFlag = OFF; + } else SINSTRL_delayTStr(tmPtr, constInd, n);//#abs > 0 + } else EM_THROW(EM_FAIL); //numArgs != numAbs + n + } else EM_THROW(EM_FAIL); //non const rig head or diff const head + } else { //AM_rigFlag == OFF + if (AM_numArgs == 0) { + if ((AM_numArgs == 0) && + (DF_fvUnivCount(AM_head) >= AM_cstUnivCount(constInd))) + SINSTRL_bindTStr(AM_head, constInd, n); + else EM_THROW(EM_FAIL); + } else SINSTRL_delayTStr(tmPtr, constInd, n); + } //AM_rigFlag == OFF + return; + } + default: + { //CONS, NIL, CONST, INT, FLOAT, STR, BV, (STREAM) + EM_THROW(EM_FAIL); + } + } //switch +} + +void SINSTR_get_list() //get_list Xi -- R_X +{ + INSACC_RX(regX); + tmPtr = DF_termDeref((DF_TermPtr)regX); + switch (DF_termTag(tmPtr)){ + case DF_TM_TAG_VAR:{ SINSTRL_bindCons(tmPtr); return; } + case DF_TM_TAG_CONS: {AM_sreg=DF_consArgs(tmPtr); AM_writeFlag=OFF; return; } + case DF_TM_TAG_APP: + { + if (DF_isConst(DF_termDeref(DF_appFunc(tmPtr)))) EM_THROW(EM_FAIL); + //otherwise continue with next case + } + case DF_TM_TAG_SUSP: //and other APP cases + { //Note ABS cannot arise here due to well-typedness + HN_hnorm(tmPtr); + if (AM_consFlag) { //#abs must be 0 and #args must be 2 due to type + AM_sreg = AM_argVec; AM_writeFlag = OFF; + return; + } + if (AM_rigFlag) EM_THROW(EM_FAIL); //non cons rigid term + //otherwise flex term with #abs being 0 (due to well-typedness) + if (AM_numArgs == 0) SINSTRL_bindCons(AM_head); //fv + else SINSTRL_delayCons(tmPtr); //higher-order + return; + } + default: { EM_THROW(EM_FAIL); } //NIL, CONST, BV + } //switch +} + +/*************************************************************************/ +/* UNIFY CLASS */ +/*************************************************************************/ +void SINSTR_unify_variable_t() //unify_variable_t Xi -- R_X +{ + INSACC_RX(regX); + if (AM_writeFlag) { + DF_mkVar((MemPtr)AM_sreg, AM_adjreg); + DF_mkRef((MemPtr)regX, AM_sreg); + } else { //read mode + if (DF_isFV(AM_sreg)) + DF_mkRef((MemPtr)regX, AM_sreg); + else *regX = *((AM_DataTypePtr)AM_sreg); + } + AM_sreg++; +} + +void SINSTR_unify_variable_p() //unify_variable_p Yi -- E_X +{ + INSACC_EX(envY); + if (AM_writeFlag) { + DF_mkVar((MemPtr)AM_sreg, AM_adjreg); + DF_mkRef((MemPtr)envY, AM_sreg); + } else { //read mode + if (DF_isFV(AM_sreg)) + DF_mkRef((MemPtr)envY, AM_sreg); + else *envY = *((AM_DataTypePtr)AM_sreg); + } + AM_sreg++; +} + +void SINSTR_unify_value_t() //unify_value Xi -- R_X +{ + INSACC_RX(regX); + if (AM_writeFlag) { + if (AM_ocFlag) SINSTRL_bindSreg(DF_termDeref((DF_TermPtr)regX)); + else *((AM_DataTypePtr)AM_sreg) = *regX; + + } else { + HOPU_patternUnifyPair((DF_TermPtr)regX, AM_sreg); //read mode + } + AM_sreg++; +} + +void SINSTR_unify_value_p() //unify_value Yi -- E_X +{ + INSACC_EX(envY); + if (AM_writeFlag) { + tmPtr = DF_termDeref((DF_TermPtr)envY); + if (AM_ocFlag) SINSTRL_bindSreg(tmPtr); + else {// AM_ocFlag == OFF + if (AM_stackAddr((MemPtr)tmPtr)) { //needed?; in fact, what if a fv? + //printf("unify_value_p -- stack addr\n"); + DF_copyAtomic(tmPtr, (MemPtr)AM_sreg); + } else DF_mkRef((MemPtr)AM_sreg, tmPtr); + } + } else HOPU_patternUnifyPair((DF_TermPtr)envY, AM_sreg); //read mode + AM_sreg++; +} + +void SINSTR_unify_local_value_t() //unify_local_value Xi -- R_X +{ + INSACC_RX(regX); + if (AM_writeFlag){ + tmPtr = DF_termDeref((DF_TermPtr)regX); + if (DF_isCons(tmPtr)) { + *regX = *((AM_DataTypePtr)tmPtr); //update reg Xi + if (AM_ocFlag) SINSTRL_bindSreg(tmPtr); + else DF_copyAtomic(tmPtr, (MemPtr)AM_sreg); + } else { //tmPtr not cons + if (AM_nHeapAddr((MemPtr)tmPtr)) { //then globalize and then bind + if (DF_isConst(tmPtr)) { //must be a const without type assoc + if (AM_ocFlag && (DF_constUnivCount(tmPtr) > AM_adjreg)) + EM_THROW(EM_FAIL); + DF_copyAtomic(tmPtr, (MemPtr)AM_sreg);//move the cst to heap + *regX = *((AM_DataTypePtr)tmPtr); //update reg Xi + } else { //not const + if (DF_isFV(tmPtr)) { + TR_trailETerm(tmPtr); + if (AM_ocFlag && (DF_fvUnivCount(tmPtr) > AM_adjreg)){ + DF_modVarUC(tmPtr, AM_adjreg); + AM_bndFlag = ON; + } + DF_copyAtomic(tmPtr, (MemPtr)AM_sreg);//move fv to heap + DF_mkRef((MemPtr)regX, AM_sreg); //reg Xi + DF_mkRef((MemPtr)tmPtr, AM_sreg); //env cell + } else {//INT, FLOAT, STR, (STREAM), NIL + DF_copyAtomic(tmPtr, (MemPtr)AM_sreg);//move to heap + *regX = *((AM_DataTypePtr)tmPtr); //update reg Xi + } + } //not const + } else { //tmPtr is a heap address + DF_mkRef((MemPtr)regX, tmPtr); //update reg Xi + if (AM_ocFlag) SINSTRL_bindSregH(tmPtr); + else DF_mkRef((MemPtr)AM_sreg, tmPtr); + } //tmPtr is a heap address + } //tmPtr not cons + } else HOPU_patternUnifyPair((DF_TermPtr)regX, AM_sreg); //read mode + AM_sreg++; +} + +void SINSTR_unify_local_value_p() //unify_local_value Yi -- E_X +{ + INSACC_EX(envY); + if (AM_writeFlag) { + tmPtr = DF_termDeref((DF_TermPtr)envY); + if (DF_isCons(tmPtr)) + if (AM_ocFlag) SINSTRL_bindSreg(tmPtr); + else DF_copyAtomic(tmPtr, (MemPtr)AM_sreg); + else { //tmPtr not cons + if (AM_nHeapAddr((MemPtr)tmPtr)) { //then globalize and then bind + if (DF_isConst(tmPtr)) { //must be a const without type assoc + if (AM_ocFlag && (DF_constUnivCount(tmPtr) > AM_adjreg)) + EM_THROW(EM_FAIL); + DF_copyAtomic(tmPtr, (MemPtr)AM_sreg); + } else { //not const + if (DF_isFV(tmPtr)) { + TR_trailETerm(tmPtr); + if (AM_ocFlag && (DF_fvUnivCount(tmPtr) > AM_adjreg)){ + DF_modVarUC(tmPtr, AM_adjreg); + AM_bndFlag = ON; + } + DF_copyAtomic(tmPtr, (MemPtr)AM_sreg);//move fv to heap + DF_mkRef((MemPtr)tmPtr, AM_sreg); //env cell + } else DF_copyAtomic(tmPtr, (MemPtr)AM_sreg); //I/F/STR/NIL + } //not const + } else { //tmPtr is a heap address + if (AM_ocFlag) SINSTRL_bindSregH(tmPtr); + else DF_mkRef((MemPtr)AM_sreg, tmPtr); + } //tmPtr is a heap address + } //tmPtr not cons + } else //read mode + HOPU_patternUnifyPair((DF_TermPtr)envY, AM_sreg); + AM_sreg++; +} + +void SINSTR_unify_m_constant() //unify_m_constant C -- C_X +{ + INSACC_CX(constInd); + if (AM_writeFlag) { + if (AM_ocFlag && (AM_adjreg < (uc = AM_cstUnivCount(constInd)))) + EM_THROW(EM_FAIL); + DF_mkConst((MemPtr)AM_sreg, uc, constInd); + } else { //read mode + tmPtr = DF_termDeref(AM_sreg); + SINSTRL_unifyConst(tmPtr, constInd); + } + AM_sreg++; +} + +void SINSTR_unify_p_constant() //unify_p_constant C,L -- C_L_X +{ + INSACC_CLX(constInd, label); + if (AM_writeFlag) { + if (AM_ocFlag && (AM_adjreg < (uc = AM_cstUnivCount(constInd)))) + EM_THROW(EM_FAIL); + nhreg = AM_hreg + DF_TM_TCONST_SIZE; + AM_heapError(nhreg + AM_cstTyEnvSize(constInd) * DF_TY_ATOMIC_SIZE); + DF_mkTConst(AM_hreg, uc, constInd, (DF_TypePtr)nhreg); + DF_mkRef((MemPtr)AM_sreg, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; + AM_tyWriteFlag = ON; + } else {// read mode + tmPtr = DF_termDeref(AM_sreg); + SINSTRL_unifyTConst(tmPtr, constInd, label); + } + AM_sreg++; +} + +void SINSTR_unify_integer() //unify_integer i -- I_X +{ + INSACC_IX(intValue); + if (AM_writeFlag) DF_mkInt((MemPtr)AM_sreg, intValue); + else { //read mode + tmPtr = DF_termDeref(AM_sreg); + SINSTRL_unifyInt(tmPtr, intValue); + } + AM_sreg++; +} + +void SINSTR_unify_float() //unify_float f -- F_X +{ + INSACC_FX(floatValue); + if (AM_writeFlag) DF_mkFloat((MemPtr)AM_sreg, floatValue); + else { //read mode + tmPtr = DF_termDeref(AM_sreg); + SINSTRL_unifyFloat(tmPtr, floatValue); + } + AM_sreg++; +} + +void SINSTR_unify_string() //unify_string str -- S_X +{ + INSACC_SX(str); + if (AM_writeFlag) DF_mkStr((MemPtr)AM_sreg, str); + else { //read mode + tmPtr = DF_termDeref(AM_sreg); + SINSTRL_unifyString(tmPtr, str); + } + AM_sreg++; +} + +void SINSTR_unify_nil() //unify_nil -- X +{ + INSACC_X(); + if (AM_writeFlag) DF_mkNil((MemPtr)AM_sreg); + else { // in read mode + tmPtr = DF_termDeref(AM_sreg); + SINSTRL_unifyNil(tmPtr); + } + AM_sreg++; +} + +void SINSTR_unify_void() //unify_void n -- I1_X +{ + INSACC_I1X(n); + if (AM_writeFlag) { + while (n > 0) { + DF_mkVar((MemPtr)AM_sreg, AM_adjreg); + AM_sreg++; + n--; + } + } else AM_sreg += n; +} + +/*****************************************************************************/ +/* INSTRUCTIONS FOR UNIFYING AND CREATING TYPES */ +/*****************************************************************************/ +void SINSTR_put_type_variable_t() //put_type_variable Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + nhreg = AM_hreg + DF_TY_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkFreeVarType(AM_hreg); + *regA = *regX = *((AM_DataTypePtr)AM_hreg); + AM_hreg = nhreg; +} + +void SINSTR_put_type_variable_p() //put_type_variable Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + DF_mkFreeVarType((MemPtr)envY); + *regA = *envY; +} + +void SINSTR_put_type_value_t() //put_type_value Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + *regA = *((AM_DataTypePtr)DF_typeDeref((DF_TypePtr)regX)); +} + +void SINSTR_put_type_value_p() //put_type_value Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + *regA = *((AM_DataTypePtr)DF_typeDeref((DF_TypePtr)envY)); +} + +void SINSTR_put_type_unsafe_value() //put_type_unsafe_value Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + tyPtr = DF_typeDeref((DF_TypePtr)envY); + if (DF_isRefType(tyPtr) && AM_inCurEnv((MemPtr)tyPtr)){ + nhreg = AM_hreg + DF_TY_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkFreeVarType(AM_hreg); + TR_trailType(tyPtr); + DF_mkRefType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + *regA = *((AM_DataTypePtr)tyPtr); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else *regA = *((AM_DataTypePtr)tyPtr); +} + + +void SINSTR_put_type_const() //put_type_const Ai,k -- R_K_X +{ + INSACC_RKX(regA, kindInd); + DF_mkSortType((MemPtr)regA, kindInd); +} + +void SINSTR_put_type_structure() //put_type_structure Ai,k -- R_K_X +{ + INSACC_RKX(regA, kindInd); + n = AM_kstArity(kindInd); + nhreg = AM_hreg + DF_TY_ATOMIC_SIZE; + AM_heapError(nhreg + n * DF_TY_ATOMIC_SIZE); + DF_mkStrType((MemPtr)regA, (DF_TypePtr)AM_hreg); + DF_mkStrFuncType(AM_hreg, kindInd, n); + AM_hreg = nhreg; +} + +void SINSTR_put_type_arrow() //put_type_arrow Ai -- R_X +{ + INSACC_RX(regA); + AM_heapError(AM_hreg + DF_TY_ATOMIC_SIZE * DF_TY_ARROW_ARITY); + DF_mkArrowType((MemPtr)regA, (DF_TypePtr)AM_hreg); +} + +/**********************************************************/ +/* SET CLASS */ +/**********************************************************/ +void SINSTR_set_type_variable_t() //set_type_variable Xi -- R_X +{ + INSACC_RX(regX); + DF_mkFreeVarType(AM_hreg); + *regX = *((AM_DataTypePtr)AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; +} + +void SINSTR_set_type_variable_p() //set_type_variable Yi -- E_X +{ + INSACC_EX(envY); + DF_mkFreeVarType(AM_hreg); + *envY = *((AM_DataTypePtr)AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; +} + +void SINSTR_set_type_value_t() //set_type_value Xi -- R_X +{ + INSACC_RX(regX); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; +} + +void SINSTR_set_type_value_p() //set_type_value Yi -- E_X +{ + INSACC_EX(envY); + tyPtr = DF_typeDeref((DF_TypePtr)envY); + DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; +} + +void SINSTR_set_type_local_value_t() //set_type_local_value Xi -- R_X +{ + INSACC_RX(regX); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (DF_isRefType(tyPtr) && AM_stackAddr((MemPtr)tyPtr)){//fv on stack + TR_trailType(tyPtr); + DF_mkFreeVarType(AM_hreg); + DF_mkRefType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + } else DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; +} + +void SINSTR_set_type_local_value_p() //set_type_local_value Yi -- E_X +{ + INSACC_EX(envY); + tyPtr = DF_typeDeref((DF_TypePtr)envY); + if (DF_isRefType(tyPtr) && AM_stackAddr((MemPtr)tyPtr)) {//fv on stack + TR_trailType(tyPtr); + DF_mkFreeVarType(AM_hreg); + DF_mkRefType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + } else DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; +} + +void SINSTR_set_type_constant() //set_type_constant k -- K_X +{ + INSACC_KX(kindInd); + DF_mkSortType(AM_hreg, kindInd); + AM_hreg += DF_TY_ATOMIC_SIZE; +} + +/**********************************************************/ +/* GET CLASS */ +/**********************************************************/ +void SINSTR_get_type_variable_t() //get_type_variable Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + *regX = *regA; +} + +void SINSTR_get_type_variable_p() //get_type_variable Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + *envY = *regA; +} + +void SINSTR_init_type_variable_t() //init_type_variable Xn,Ym -- R_CE_X +{ + INSACC_RCEX(regX, clenvY); + *regX = *((AM_DataTypePtr)DF_typeDeref((DF_TypePtr)clenvY)); +} + +void SINSTR_init_type_variable_p() //init_type_variable Yn,Ym -- E_CE_X +{ + INSACC_ECEX(envY, clenvY); + *envY = *((AM_DataTypePtr)DF_typeDeref((DF_TypePtr)clenvY)); +} + +void SINSTR_get_type_value_t() //get_type_value Xn,Ai -- R_R_X +{ + INSACC_RRX(regX, regA); + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)regX); + AM_pushPDL((MemPtr)regA); + TY_typesUnify(); +} + +void SINSTR_get_type_value_p() //get_type_value Yn,Ai -- E_R_X +{ + INSACC_ERX(envY, regA); + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)envY); + AM_pushPDL((MemPtr)regA); + TY_typesUnify(); +} + +void SINSTR_get_type_constant() //get_type_constant Xi,k -- R_K_X +{ + INSACC_RKX(regX, kindInd); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (DF_isRefType(tyPtr)) { + TR_trailType(tyPtr); + DF_mkSortType((MemPtr)tyPtr, kindInd); + return; + } + if (DF_isSortType(tyPtr) && (DF_typeKindTabIndex(tyPtr) == kindInd)) return; + EM_THROW(EM_FAIL); //all other cases +} + +void SINSTR_get_type_structure() //get_type_structure Xi,k -- R_K_X +{ + INSACC_RKX(regX, kindInd); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (DF_isRefType(tyPtr)) { + nhreg = AM_hreg + DF_TY_ATOMIC_SIZE; + n = AM_kstArity(kindInd); + AM_heapError(nhreg + DF_TY_ATOMIC_SIZE * n); + TR_trailType(tyPtr); + DF_mkStrType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + DF_mkStrFuncType(AM_hreg, kindInd, n); + AM_tyvbbreg = (DF_TypePtr)AM_hreg; + AM_tyWriteFlag = ON; + + AM_hreg += DF_TY_ATOMIC_SIZE; + return; + } //else not ref + if (DF_isStrType(tyPtr)) { + tyPtr = DF_typeStrFuncAndArgs(tyPtr); + if (DF_typeStrFuncInd(tyPtr) == kindInd) { + AM_tysreg = DF_typeStrArgs(tyPtr); + AM_tyWriteFlag = OFF; + return; + } + } + EM_THROW(EM_FAIL); +} + +void SINSTR_get_type_arrow() //get_type_arrow Xi -- R_X +{ + INSACC_RX(regX); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (DF_isRefType(tyPtr)) { + AM_heapError(nhreg + DF_TY_ATOMIC_SIZE * DF_TY_ARROW_ARITY); + TR_trailType(tyPtr); + DF_mkArrowType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + AM_tyvbbreg = (DF_TypePtr)AM_hreg; + AM_tyWriteFlag = ON; + return; + } //else not ref + if (DF_isArrowType(tyPtr)) { + AM_tysreg = DF_typeArrowArgs(tyPtr); + AM_tyWriteFlag = OFF; + return; + } + EM_THROW(EM_FAIL); +} + +/**********************************************************/ +/* UNIFY CLASS */ +/**********************************************************/ +void SINSTR_unify_type_variable_t() //unify_type_variable Xi -- R_X +{ + INSACC_RX(regX); + if (AM_tyWriteFlag) { + DF_mkFreeVarType(AM_hreg); + *regX = *((AM_DataTypePtr)AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //read mode + *regX = *((AM_DataTypePtr)AM_tysreg); + AM_tysreg++; + } +} + +void SINSTR_unify_type_variable_p() //unify_type_variable Yi -- E_X +{ + INSACC_EX(envY); + if (AM_tyWriteFlag) { + DF_mkFreeVarType(AM_hreg); + *envY = *((AM_DataTypePtr)AM_hreg); + AM_hreg += DF_TM_ATOMIC_SIZE; + } else { //read mode + *envY = *((AM_DataTypePtr)AM_tysreg); + AM_tysreg++; + } +} + +void SINSTR_unify_type_value_t() //unify_type_value Xi -- R_X +{ + INSACC_RX(regX); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (AM_tyWriteFlag) { + AM_pdlError(1); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + TY_typesOccC(); + DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //readmode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_type_value_p() //unify_type_value Yi -- E_X +{ + INSACC_EX(envY); + tyPtr = DF_typeDeref((DF_TypePtr)envY); + if (AM_tyWriteFlag) { + AM_pdlError(1); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + TY_typesOccC(); + DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //readmode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_envty_value_t() //unify_envty_value Xi -- R_X +{ + INSACC_RX(regX); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (AM_tyWriteFlag) { + DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //readmode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_envty_value_p() //unify_envty_value Yi -- E_X +{ + INSACC_EX(envY); + tyPtr = DF_typeDeref((DF_TypePtr)envY); + if (AM_tyWriteFlag) { + DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //readmode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_type_local_value_t() //unify_type_local_value Xi -- R_X +{ + INSACC_RX(regX); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (AM_tyWriteFlag) { + if (DF_isRefType(tyPtr)) { + if (AM_stackAddr((MemPtr)tyPtr)) { + TR_trailType(tyPtr); + DF_mkFreeVarType(AM_hreg); + DF_mkRefType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + *regX = *((AM_DataTypePtr)tyPtr); + } else DF_copyAtomicType(tyPtr, AM_hreg); //a heap address + } else { //not free var type + AM_pdlError(1); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + TY_typesOccC(); + DF_copyAtomicType(tyPtr, AM_hreg); + } + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //readmode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_type_local_value_p() //unify_type_local_value Yi -- E_X +{ + INSACC_EX(envY); + tyPtr = DF_typeDeref((DF_TypePtr)envY); + if (AM_tyWriteFlag) { + if (DF_isRefType(tyPtr)) { + if (AM_stackAddr((MemPtr)tyPtr)) { + TR_trailType(tyPtr); + DF_mkFreeVarType(AM_hreg); + DF_mkRefType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + } else DF_copyAtomicType(tyPtr, AM_hreg); + } else { //not free var type + AM_pdlError(1); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + TY_typesOccC(); + DF_copyAtomicType(tyPtr, AM_hreg); + } + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //readmode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_envty_local_value_t() //unify_envty_local_value Xi -- R_X +{ + INSACC_RX(regX); + tyPtr = DF_typeDeref((DF_TypePtr)regX); + if (AM_tyWriteFlag) { + if (DF_isRefType(tyPtr) && (AM_stackAddr((MemPtr)tyPtr))) { + TR_trailType(tyPtr); + DF_mkFreeVarType(AM_hreg); + DF_mkRefType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + *regX = *((AM_DataTypePtr)tyPtr); + } else DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //read mode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_envty_local_value_p() //unify_envty_local_value Yi -- E_X +{ + INSACC_EX(envY); + tyPtr = DF_typeDeref((DF_TypePtr)envY); + if (AM_tyWriteFlag) { + if (DF_isRefType(tyPtr) && (AM_stackAddr((MemPtr)tyPtr))) { + TR_trailType(tyPtr); + DF_mkFreeVarType(AM_hreg); + DF_mkRefType((MemPtr)tyPtr, (DF_TypePtr)AM_hreg); + } else DF_copyAtomicType(tyPtr, AM_hreg); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //read mode + AM_pdlError(2); + AM_initTypesPDL(); + AM_pushPDL((MemPtr)tyPtr); + AM_pushPDL((MemPtr)AM_tysreg); + TY_typesUnify(); + AM_tysreg++; + } +} + +void SINSTR_unify_type_constant() //unify_type_constant k -- K_X +{ + INSACC_KX(kindInd); + if (AM_tyWriteFlag) { + DF_mkSortType(AM_hreg, kindInd); + AM_hreg += DF_TY_ATOMIC_SIZE; + } else { //read mode + tyPtr = DF_typeDeref(AM_tysreg); + AM_tysreg++; + if (DF_isRefType(tyPtr)) { + TR_trailType(tyPtr); + DF_mkSortType((MemPtr)tyPtr, kindInd); + return; + } //otherwise not ref + if (DF_isSortType(tyPtr) && (DF_typeKindTabIndex(tyPtr) == kindInd)) + return; + EM_THROW(EM_FAIL); + } +} + +/* init type var for implication goal */ +void SINSTR_create_type_variable() //create_type_variable Yi -- E_X +{ + INSACC_EX(envY); + DF_mkFreeVarType((MemPtr)envY); +} + +/*****************************************************************************/ +/* HIGHER-ORDER INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_pattern_unify_t() //pattern_unify Xi,Aj -- R_R_X +{ + INSACC_RRX(regX, regA); + HOPU_patternUnifyPair((DF_TermPtr)regX, (DF_TermPtr)regA); +} + +void SINSTR_pattern_unify_p() //pattern_unify Yi,Aj -- E_R_X +{ + INSACC_ERX(envY, regA); + HOPU_patternUnifyPair((DF_TermPtr)envY, (DF_TermPtr)regA); +} + +void SINSTR_finish_unify() //finish_unify -- X +{ + INSACC_X(); + HOPU_patternUnify(); +} + +void SINSTR_head_normalize_t() //head_normalize Xi -- R_X +{ + INSACC_RX(regX); + HN_hnorm((DF_TermPtr)regX); //no need to deref (hnorm takes care of it) +} + +void SINSTR_head_normalize_p() //head_normalize Yi -- E_X +{ + INSACC_EX(envY); + HN_hnorm((DF_TermPtr)envY); //no need to deref (hnorm takes care of it) +} + +/*****************************************************************************/ +/* LOGICAL INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_incr_universe() //incr_universe -- X +{ + INSACC_X(); + AM_ucError(AM_ucreg); + AM_ucreg++; +} + +void SINSTR_decr_universe() //decr_universe -- X +{ + INSACC_X(); + AM_ucreg--; +} + +void SINSTR_set_univ_tag() //set_univ_tag Yi,c -- E_C_X +{ + INSACC_ECX(envY, constInd); + DF_mkConst((MemPtr)envY, AM_ucreg, constInd); +} + +void SINSTR_tag_exists_t() //tag_exists Xi -- R_X +{ + INSACC_RX(regX); + nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkVar(AM_hreg, AM_ucreg); + DF_mkRef((MemPtr)regX, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; +} + +void SINSTR_tag_exists_p() //tag_exists Yi -- E_X +{ + INSACC_EX(envY); + DF_mkVar((MemPtr)envY, AM_ucreg); +} + +void SINSTR_tag_variable() //tag_variable Yi -- E_X +{ + INSACC_EX(envY); + DF_mkVar((MemPtr)envY, AM_envUC()); +} + +void SINSTR_push_impl_point() //put_impl_point n,t -- I1_IT_X +{ + INSACC_I1ITX(n, impTab); + m = MEM_implLTS(impTab); + ip = AM_findtos(n) + AM_NCLT_ENTRY_SIZE * m; + AM_tosreg = ip + AM_IMP_FIX_SIZE; + AM_stackError(AM_tosreg); + AM_mkImplRec(ip, MEM_implPST(impTab, m), MEM_implPSTS(impTab), + MEM_implFC(impTab)); + if (m > 0) AM_mkImpNCLTab(ip, MEM_implLT(impTab), m); + AM_ireg = ip; +} + +void SINSTR_pop_impl_point() //pop_impl_point -- X +{ + INSACC_X(); + AM_ireg = AM_curimpPIP(); + AM_settosreg(); +} + +void SINSTR_add_imports() //add_imports n,m,L -- SEG_I1_L_X +{ + INSACC_SEGI1LX(n, m, label); + bckfd = AM_cimpBCK(n); + l = AM_impBCKNo(bckfd); + if (AM_breg > AM_impBCKMRCP(bckfd)) TR_trailImport(bckfd); + AM_setBCKNo(bckfd, l+1); + AM_setBCKMRCP(bckfd, AM_breg); + if (l > 0) AM_preg = label; + else AM_tosreg = AM_findtos(m); +} + +void SINSTR_remove_imports() //remove_imports n,L -- SEG_L_X +{ + INSACC_SEGLX(n, label); + bckfd = AM_cimpBCK(n); + l = AM_impBCKNo(bckfd); + if (AM_breg > AM_impBCKMRCP(bckfd)) TR_trailImport(bckfd); + AM_setBCKNo(bckfd, l-1); + AM_setBCKMRCP(bckfd, AM_breg); + if (l > 1) AM_preg = label; +} + +void SINSTR_push_import() //push_import t -- MT_X +{ + INSACC_MTX(impTab); + n = MEM_impNCSEG(impTab); // n = # code segs (# bc field) + m = MEM_impLTS(impTab); // m = link tab size + l = AM_NCLT_ENTRY_SIZE * m; // l = space for next clause table + ip = AM_tosreg + (AM_BCKV_ENTRY_SIZE * n) + l; + AM_tosreg = ip + AM_IMP_FIX_SIZE; + AM_stackError(AM_tosreg); + if (n > 0) AM_initBCKVector(ip, l, n); + n = MEM_impNLC(impTab); // reuse n as the number of local consts + if (n > 0) { + AM_mkImptRecWL(ip, m, MEM_impPST(impTab, m, n), MEM_impPSTS(impTab), + MEM_impFC(impTab)); + AM_ucError(AM_ucreg); + AM_ucreg++; + AM_initLocs(n, MEM_impLCT(impTab, m)); + } else AM_mkImptRecWOL(ip, m, MEM_impPST(impTab, m, n), MEM_impPSTS(impTab), + MEM_impFC(impTab)); + if (m > 0) AM_mkImpNCLTab(ip, MEM_impLT(impTab), m); + AM_ireg = ip; +} + +void SINSTR_pop_imports() //pop_imports n -- I1_X +{ + INSACC_I1X(n); + for (; n > 0; n--){ + if (AM_isCurImptWL()) AM_ucreg--; + AM_ireg = AM_curimpPIP(); + } + AM_settosreg(); +} + +/*****************************************************************************/ +/* CONTROL INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_allocate() //allocate n -- I1_X +{ + INSACC_I1X(n); + ep = AM_findtosEnv() + AM_ENV_FIX_SIZE; + AM_stackError(ep + AM_DATA_SIZE * n); + AM_ereg = AM_mkEnv(ep); +} + +void SINSTR_deallocate() //deallocate -- X +{ + INSACC_X(); + AM_cpreg = AM_envCP(); + AM_ereg = AM_envCE(); +} + +void SINSTR_call() //call n,L -- I1_L_X +{ + AM_cpreg = AM_preg + INSTR_I1LX_LEN; //next instruction + AM_cereg = AM_ereg; + AM_b0reg = AM_breg; + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_I1LX_L)); +} + +void SINSTR_call_name() //call_name n,c -- I1_C_WP_X +{ + INSACC_I1CWPX_C(constInd); + AM_findCode(constInd, &cl, &ip); + if (cl) { + AM_cpreg = (AM_preg + INSTR_I1CWPX_LEN); // next instr + AM_b0reg = AM_breg; + AM_preg = cl; + AM_cireg = ip; + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + } else EM_THROW(EM_FAIL); +} + +void SINSTR_execute() //execute label -- L_X +{ + INSACC_LX(); //AM_preg has been set to label + AM_b0reg = AM_breg; +} + +void SINSTR_execute_name() //execute_name c -- C_WP_X +{ + INSACC_CWPX(constInd); + AM_findCode(constInd, &cl, &ip); + if (cl) { + AM_b0reg = AM_breg; + AM_preg = cl; + AM_cireg = ip; + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + } else EM_THROW(EM_FAIL); +} + +void SINSTR_proceed() //proceed -- X +{ + /* We use a nonlocal procedure exit to get back to the toplevel + when a query has a result. We do this so that we don't have to + return values from instruction functions, and we don't have to + do any checks in the simulator loop. We use the exception + mechanism to acheive our nonlocal exit. */ + if (AM_noEnv()) EM_THROW(EM_QUERY_RESULT); + else { + AM_preg = AM_cpreg; + AM_cireg = AM_envCI(); + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + } +} + +/*****************************************************************************/ +/* CHOICE INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_try_me_else() //try_me_else n,lab -- I1_L_X +{ + INSACC_I1LX(n, label); + AM_tosreg = (MemPtr)((AM_DataTypePtr)(AM_findtosEnv() + AM_CP_FIX_SIZE)+n); + AM_stackError(AM_tosreg); + cp = AM_tosreg - 1; + AM_mkCP(cp, label, n); + AM_breg = cp; + AM_hbreg = AM_hreg; +} + +void SINSTR_retry_me_else() //retry_me_else n,lab -- I1_L_X +{ + INSACC_I1LX(n, label); + AM_restoreRegs(n); + AM_hbreg = AM_hreg; + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + AM_setNClCP(label); +} + +void SINSTR_trust_me() //trust_me n -- I1_WP_X +{ + INSACC_I1WPX(n); + AM_restoreRegs(n); + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + AM_breg = AM_cpB(); + AM_hbreg = AM_cpH(); + AM_settosreg(); +} + +void SINSTR_try() //try n,label -- I1_L_X +{ + INSACC_I1LX_I1(n); + AM_tosreg = (MemPtr)((AM_DataTypePtr)(AM_findtosEnv() + AM_CP_FIX_SIZE)+n); + AM_stackError(AM_tosreg); + cp = AM_tosreg - 1; + AM_mkCP(cp, (AM_preg + INSTR_I1LX_LEN), n); + AM_breg = cp; + AM_hbreg = AM_hreg; + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_I1LX_L)); +} + +void SINSTR_retry() //retry n,label -- I1_L_X +{ + INSACC_I1LX_I1(n); + AM_restoreRegs(n); + AM_hbreg = AM_hreg; + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + AM_setNClCP(AM_preg + INSTR_I1LX_LEN); + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_I1LX_L)); +} + +void SINSTR_trust() //trust n,label -- I1_L_WP_X +{ + INSACC_I1LWPX_I1(n); + AM_restoreRegs(n); + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + AM_breg = AM_cpB(); + AM_hbreg = AM_cpH(); + AM_settosreg(); + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_I1LWPX_L)); +} + +void SINSTR_trust_ext() //trust_ext n,m -- I1_N_X +{ + INSACC_I1NX(n, m); + nextcl = AM_impNCL(AM_cpCI(), m); + AM_preg = AM_impNCLCode(nextcl); + + if (AM_isFailInstr(AM_preg)) { + AM_breg = AM_cpB(); + AM_settosreg(); + EM_THROW(EM_FAIL); + } + AM_restoreRegsWoCI(n); + AM_cireg = AM_impNCLIP(nextcl); + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + AM_breg = AM_cpB(); + AM_hbreg = AM_cpH(); + AM_settosreg(); +} + +void SINSTR_try_else() //try_else n,lab1,lab2 -- I1_L_L_X +{ + INSACC_I1LLX(n, label); //AM_preg has been set + AM_tosreg = (MemPtr)((AM_DataTypePtr)(AM_findtosEnv() + AM_CP_FIX_SIZE)+n); + AM_stackError(AM_tosreg); + cp = AM_tosreg - 1; + AM_mkCP(cp, label, n); + AM_breg = cp; + AM_hbreg = AM_hreg; +} + +void SINSTR_retry_else() //retry_else n,lab1,lab2 -- I1_L_L_X +{ + INSACC_I1LLX(n, label); //AM_preg has been set + AM_restoreRegs(n); + AM_hbreg = AM_hreg; + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + AM_setNClCP(label); +} + +void SINSTR_branch() //branch lab -- L_X +{ + INSACC_LX(); //AM_preg has been set to label +} + + +/*****************************************************************************/ +/* INDEXING INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_switch_on_term() //switch_on_term lv,lc,ll,lbv --L_L_L_L_X +{ + regA = AM_reg(1); + tmPtr = DF_termDeref((DF_TermPtr)regA); + numAbs = 0; + while (DF_isLam(tmPtr)) { + numAbs += DF_lamNumAbs(tmPtr); + tmPtr = DF_termDeref(DF_lamBody(tmPtr)); + } + if (DF_isCons(tmPtr)) { + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L3)); + return; + } else { + if (DF_isApp(tmPtr)) tmPtr = DF_termDeref(DF_appFunc(tmPtr)); + if (DF_isNAtomic(tmPtr)) { + HN_hnorm(tmPtr); + numAbs += AM_numAbs; + tmPtr = AM_head; + } + switch (DF_termTag(tmPtr)) { + case DF_TM_TAG_VAR: { + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L1)); + return; + } + case DF_TM_TAG_CONST: { + tablInd = DF_constTabIndex(tmPtr); + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L2)); + return; + } + case DF_TM_TAG_INT: { + tablInd = PERV_INTC_INDEX; + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L2)); + return; + } + case DF_TM_TAG_FLOAT: { + tablInd = PERV_REALC_INDEX; + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L2)); + return; + } + case DF_TM_TAG_STR: { + tablInd = PERV_STRC_INDEX; + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L2)); + return; + } + case DF_TM_TAG_NIL: { + tablInd = PERV_NIL_INDEX; + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L2)); + return; + } + case DF_TM_TAG_STREAM:{ EM_THROW(EM_FAIL); } + case DF_TM_TAG_CONS: { + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L3)); + return; + } + case DF_TM_TAG_BVAR: + { + numAbs = numAbs - DF_bvIndex(tmPtr); + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_LLLLX_L4)); + return; + } + } + } +} + +void SINSTR_switch_on_constant() //switch_on_constant n,tab -- I1_HT_X +{ + INSACC_I1HTX(n, table); + cl = LD_SEARCHTAB_HashSrch(tablInd, n, table); + if (cl) { + AM_preg = cl; + return; + } else EM_THROW(EM_FAIL); +} + +void SINSTR_switch_on_bvar() //switch_on_bvar n,tab -- I1_BVT_X +{ + INSACC_I1BVTX(n, table); + for (m = 0; m != n; m++) + if (numAbs = MEM_branchTabIndexVal(table, m)) break; + if (m < n) AM_preg = MEM_branchTabCodePtr(table, m); + else EM_THROW(EM_FAIL); +} + +void SINSTR_switch_on_reg() //switch_on_reg n,SL1,FL2 -- N_L_L_X +{ + INSACC_NLLX_N(n); + nextcl = AM_impNCL(AM_cireg, n); + if (AM_isFailInstr(AM_impNCLCode(nextcl))){ + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_NLLX_L2));} + else { + AM_preg = *((INSTR_CodeLabel *)(AM_preg + INSTR_NLLX_L1)); + } +} + +/*****************************************************************************/ +/* CUT INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_neck_cut() //neck_cut -- X +{ + INSACC_X(); + AM_breg = AM_b0reg; + AM_hbreg = AM_cpH(); + AM_settosreg(); +} + +void SINSTR_get_level() //get_level Yn -- E_X +{ + INSACC_EX(envY); + *((MemPtr *)envY) = AM_b0reg; +} + +void SINSTR_put_level() //put_level Yn -- E_X +{ + INSACC_EX(envY); + AM_b0reg = *((MemPtr *)envY); +} + +void SINSTR_cut() //cut Yn -- E_X +{ + INSACC_EX(envY); + AM_breg = *((MemPtr *)envY); + AM_hbreg = AM_cpH(); + AM_settosreg(); +} + +/*****************************************************************************/ +/* MISCELLANEOUS INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_call_builtin() //call_builtin n -- I1_WP_X +{ + INSACC_I1I1WPX(n); + AM_cpreg = AM_preg; + BI_dispatch(n); +} + +void SINSTR_builtin() //builtin n -- I1_X +{ + INSACC_I1X(n); + if (!AM_noEnv()) { + AM_cireg = AM_envCI(); + if (AM_isImplCI()) AM_cereg = AM_cimpCE(); + } + BI_dispatch(n); +} + +void SINSTR_stop() //stop -- X +{ + EM_THROW(EM_TOP_LEVEL); +} + +void SINSTR_halt() //halt -- X +{ + EM_THROW(EM_EXIT); +} + +void SINSTR_fail() //fail -- X +{ + EM_THROW(EM_FAIL); +} + + +/**************************************************************************/ +/* linker only */ +/**************************************************************************/ +void SINSTR_execute_link_only() +{ + EM_THROW(EM_ABORT); +} + +void SINSTR_call_link_only() +{ + EM_THROW(EM_ABORT); +} + + +#endif //SIMINSTR_C diff --git a/src/runtime/c/teyjus/simulator/siminstr.h b/src/runtime/c/teyjus/simulator/siminstr.h new file mode 100644 index 000000000..d0521fb99 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/siminstr.h @@ -0,0 +1,248 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* File siminstr.h. The instruction set of the virtual machine. */ +/*****************************************************************************/ +#ifndef SIMINSTR_H +#define SIMINSTR_H + +/*****************************************************************************/ +/* INSTRUCTIONS FOR UNIFYING AND CREATING TERMS */ +/*****************************************************************************/ + +/**********************************************************/ +/* PUT CLASS */ +/**********************************************************/ +void SINSTR_put_variable_t(); +void SINSTR_put_variable_te(); +void SINSTR_put_variable_p(); +void SINSTR_put_value_t(); +void SINSTR_put_value_p(); +void SINSTR_put_unsafe_value(); +void SINSTR_copy_value(); +void SINSTR_put_m_const(); +void SINSTR_put_p_const(); +void SINSTR_put_nil(); +void SINSTR_put_integer(); +void SINSTR_put_float(); +void SINSTR_put_string(); +void SINSTR_put_index(); +void SINSTR_put_app(); +void SINSTR_put_list(); +void SINSTR_put_lambda(); + +/**********************************************************/ +/* SET CLASS */ +/**********************************************************/ +void SINSTR_set_variable_t(); +void SINSTR_set_variable_te(); +void SINSTR_set_variable_p(); +void SINSTR_set_value_t(); +void SINSTR_set_value_p(); +void SINSTR_globalize_pt(); +void SINSTR_globalize_t(); +void SINSTR_set_m_const(); +void SINSTR_set_p_const(); +void SINSTR_set_nil(); +void SINSTR_set_integer(); +void SINSTR_set_float(); +void SINSTR_set_string(); +void SINSTR_set_index(); +void SINSTR_set_void(); +//needed? +void SINSTR_deref(); +void SINSTR_set_lambda(); + +/**********************************************************/ +/* GET CLASS */ +/**********************************************************/ +void SINSTR_get_variable_t(); +void SINSTR_get_variable_p(); +void SINSTR_init_variable_t(); +void SINSTR_init_variable_p(); +void SINSTR_get_m_constant(); +void SINSTR_get_p_constant(); +void SINSTR_get_integer(); +void SINSTR_get_float(); +void SINSTR_get_string(); +void SINSTR_get_nil(); +void SINSTR_get_m_structure(); +void SINSTR_get_p_structure(); +void SINSTR_get_list(); + +/**********************************************************/ +/* UNIFY CLASS */ +/**********************************************************/ +void SINSTR_unify_variable_t(); +void SINSTR_unify_variable_p(); +void SINSTR_unify_value_t(); +void SINSTR_unify_value_p(); +void SINSTR_unify_local_value_t(); +void SINSTR_unify_local_value_p(); +void SINSTR_unify_m_constant(); +void SINSTR_unify_p_constant(); +void SINSTR_unify_nil(); +void SINSTR_unify_integer(); +void SINSTR_unify_float(); +void SINSTR_unify_string(); +void SINSTR_unify_void(); + +/*****************************************************************************/ +/* INSTRUCTIONS FOR UNIFYING AND CREATING TYPES */ +/*****************************************************************************/ + +/**********************************************************/ +/* PUT CLASS */ +/**********************************************************/ +void SINSTR_put_type_variable_t(); +void SINSTR_put_type_variable_p(); +void SINSTR_put_type_value_t(); +void SINSTR_put_type_value_p(); +void SINSTR_put_type_unsafe_value(); +void SINSTR_put_type_const(); +void SINSTR_put_type_structure(); +void SINSTR_put_type_arrow(); + +/**********************************************************/ +/* SET CLASS */ +/**********************************************************/ +void SINSTR_set_type_variable_t(); +void SINSTR_set_type_variable_p(); +void SINSTR_set_type_value_t(); +void SINSTR_set_type_value_p(); +void SINSTR_set_type_local_value_t(); +void SINSTR_set_type_local_value_p(); +void SINSTR_set_type_constant(); + +/**********************************************************/ +/* GET CLASS */ +/**********************************************************/ +void SINSTR_get_type_variable_t(); +void SINSTR_get_type_variable_p(); +void SINSTR_init_type_variable_t(); +void SINSTR_init_type_variable_p(); +void SINSTR_get_type_value_t(); +void SINSTR_get_type_value_p(); +void SINSTR_get_type_constant(); +void SINSTR_get_type_structure(); +void SINSTR_get_type_arrow(); + +/**********************************************************/ +/* UNIFY CLASS */ +/**********************************************************/ +void SINSTR_unify_type_variable_t(); +void SINSTR_unify_type_variable_p(); +void SINSTR_unify_type_value_t(); +void SINSTR_unify_type_value_p(); +void SINSTR_unify_envty_value_t(); +void SINSTR_unify_envty_value_p(); +void SINSTR_unify_type_local_value_t(); +void SINSTR_unify_type_local_value_p(); +void SINSTR_unify_envty_local_value_t(); +void SINSTR_unify_envty_local_value_p(); +void SINSTR_unify_type_constant(); + +/* init type var for implication goal */ +void SINSTR_create_type_variable(); + +/*****************************************************************************/ +/* HIGHER-ORDER INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_pattern_unify_t(); +void SINSTR_pattern_unify_p(); +void SINSTR_finish_unify(); +void SINSTR_head_normalize_t(); +void SINSTR_head_normalize_p(); + +/*****************************************************************************/ +/* LOGICAL INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_incr_universe(); +void SINSTR_decr_universe(); +void SINSTR_set_univ_tag(); +void SINSTR_tag_exists_t(); +void SINSTR_tag_exists_p(); +void SINSTR_tag_variable(); + +void SINSTR_push_impl_point(); +void SINSTR_pop_impl_point(); +void SINSTR_add_imports(); +void SINSTR_remove_imports(); +void SINSTR_push_import(); +void SINSTR_pop_imports(); + +/*****************************************************************************/ +/* CONTROL INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_allocate(); +void SINSTR_deallocate(); +void SINSTR_call(); +void SINSTR_call_name(); +void SINSTR_execute(); +void SINSTR_execute_name(); +void SINSTR_proceed(); + +/*****************************************************************************/ +/* CHOICE INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_try_me_else(); +void SINSTR_retry_me_else(); +void SINSTR_trust_me(); +void SINSTR_try(); +void SINSTR_retry(); +void SINSTR_trust(); +void SINSTR_trust_ext(); +void SINSTR_try_else(); +void SINSTR_retry_else(); +void SINSTR_branch(); + +/*****************************************************************************/ +/* INDEXING INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_switch_on_term(); +void SINSTR_switch_on_constant(); +void SINSTR_switch_on_bvar(); +void SINSTR_switch_on_reg(); + +/*****************************************************************************/ +/* CUT INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_neck_cut(); +void SINSTR_get_level(); +void SINSTR_put_level(); +void SINSTR_cut(); + +/*****************************************************************************/ +/* MISCELLANEOUS INSTRUCTIONS */ +/*****************************************************************************/ +void SINSTR_call_builtin(); +void SINSTR_builtin(); +void SINSTR_stop(); +void SINSTR_halt(); +void SINSTR_fail(); + +/**************************************************************************/ +/* linker only */ +/**************************************************************************/ +void SINSTR_execute_link_only(); +void SINSTR_call_link_only(); + +#endif //SIMINSTR_H diff --git a/src/runtime/c/teyjus/simulator/siminstrlocal.c b/src/runtime/c/teyjus/simulator/siminstrlocal.c new file mode 100644 index 000000000..3e7d70292 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/siminstrlocal.c @@ -0,0 +1,583 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* */ +/* File siminstrlocal.c. This file contains the definitions of auxiliary */ +/* functions used in siminstr.c. */ +/***************************************************************************/ + +#include "siminstrlocal.h" +#include "dataformats.h" +#include "abstmachine.h" +#include "trail.h" +#include "hnorm.h" +#include "hopu.h" +#include "../system/error.h" //to be modified + +#include <stdio.h> //to be removed + +//Bind a free variable to a constant (without type association) +//Note the BND register is set to ON +static void SINSTRL_bindConst(DF_TermPtr varPtr, int c) +{ + TR_trailTerm(varPtr); + DF_mkConst((MemPtr)varPtr, AM_cstUnivCount(c), c); + AM_bndFlag = ON; +} + +//Bind a free variable to an integer +//Note the BND register is set to ON +static void SINSTRL_bindInt(DF_TermPtr varPtr, int i) +{ + TR_trailTerm(varPtr); + DF_mkInt((MemPtr)varPtr, i); + AM_bndFlag = ON; +} + +//Bind a free variable to a float +//Note the BND register is set to ON +static void SINSTRL_bindFloat(DF_TermPtr varPtr, float f) +{ + TR_trailTerm(varPtr); + DF_mkFloat((MemPtr)varPtr, f); + AM_bndFlag = ON; +} + +//Bind a free variable to a string +//Note the BND register is set to ON +void SINSTRL_bindString(DF_TermPtr varPtr, DF_StrDataPtr str) +{ + TR_trailTerm(varPtr); + DF_mkStr((MemPtr)varPtr, str); + AM_bndFlag = ON; +} + +//Bind a free variable to a constant with type association +//Note the BND register is set to ON; the TYWIRTE mode is set to ON +static void SINSTRL_bindTConst(DF_TermPtr varPtr, int c) +{ + MemPtr nhreg = AM_hreg + DF_TM_TCONST_SIZE; + AM_heapError(nhreg + DF_TY_ATOMIC_SIZE * AM_cstTyEnvSize(c)); + DF_mkTConst(AM_hreg, AM_cstUnivCount(c), c, (DF_TypePtr)nhreg); + TR_trailTerm(varPtr); + DF_mkRef((MemPtr)varPtr, (DF_TermPtr)AM_hreg); + AM_hreg = nhreg; + AM_bndFlag = ON; + AM_tyWriteFlag = ON; +} + +//Bind a free variable to nil +//Note the BND register is set to ON +static void SINSTRL_bindNil(DF_TermPtr varPtr) +{ + TR_trailTerm(varPtr); + DF_mkNil((MemPtr)varPtr); + AM_bndFlag = ON; +} + + +//Bind a free variable to an application object with a non-type-associated +//constant head. +//Setting relevant registers for 1)entering WRITE mode 2)entering OCC mode +// 3)indicating the occurrence of binding (BND = ON). +void SINSTRL_bindStr(DF_TermPtr varPtr, int constInd, int arity) +{ + MemPtr args = AM_hreg + DF_TM_APP_SIZE; + MemPtr func = args + arity * DF_TM_ATOMIC_SIZE; + MemPtr nhreg = func + DF_TM_ATOMIC_SIZE; //new heap top + AM_heapError(nhreg); + DF_mkApp(AM_hreg, arity, (DF_TermPtr)func, (DF_TermPtr)args); //mk app + DF_mkConst(func, AM_cstUnivCount(constInd), constInd); //mk const + //enter WRITE mode + AM_sreg = (DF_TermPtr)args; AM_writeFlag = ON; + //enter OCC mode + AM_adjreg = DF_fvUnivCount(varPtr); AM_vbbreg = (DF_TermPtr)AM_hreg; + AM_ocFlag = ON; + //performing binding + TR_trailTerm(varPtr); + DF_mkRef((MemPtr)varPtr, (DF_TermPtr)AM_hreg); + AM_bndFlag = ON; + + AM_hreg = nhreg; +} + +//Bind a free variable to an application object with a type-associated +//constant head. +//Setting relevant registers for 1)entering WRITE and TYWRITE mode 2)entering +// OCC mode 3)indicating the occurrence of binding (BND = ON). +void SINSTRL_bindTStr(DF_TermPtr varPtr, int constInd, int arity) +{ + MemPtr args = AM_hreg + DF_TM_APP_SIZE; + MemPtr func = args + arity * DF_TM_ATOMIC_SIZE; + MemPtr nhreg = func + DF_TM_TCONST_SIZE; //new heap top + AM_heapError(nhreg + AM_cstTyEnvSize(constInd) + DF_TY_ATOMIC_SIZE); + DF_mkApp(AM_hreg, arity, (DF_TermPtr)func, (DF_TermPtr)args); //mk app + DF_mkTConst(func, AM_cstUnivCount(constInd), constInd, (DF_TypePtr)nhreg); + //enter WRITE and TYWRITE mode + AM_sreg = (DF_TermPtr)args; AM_writeFlag = ON; AM_tyWriteFlag = ON; + //enter OCC mode + AM_adjreg = DF_fvUnivCount(varPtr); AM_vbbreg = (DF_TermPtr)AM_hreg; + AM_ocFlag = ON; + //perform binding + TR_trailTerm(varPtr); + DF_mkRef((MemPtr)varPtr, (DF_TermPtr)AM_hreg); + AM_bndFlag = ON; + + AM_hreg = nhreg; +} + +//Bind a free variable to a list cons. +//Setting relevant registers for 1)entering WRITE mode 2)entering OCC mode +// 3)indicating the occurrence of binding (BND = ON). +void SINSTRL_bindCons(DF_TermPtr varPtr) +{ + MemPtr nhreg = AM_hreg + DF_CONS_ARITY * DF_TM_ATOMIC_SIZE; //new heap top + AM_heapError(nhreg); + //enter WRITE mode + AM_sreg = (DF_TermPtr)AM_hreg; AM_writeFlag = ON; + //enter OCC mode + AM_adjreg = DF_fvUnivCount(varPtr); AM_vbbreg = (DF_TermPtr)AM_hreg; + AM_ocFlag = ON; + //perform binding + TR_trailTerm(varPtr); + DF_mkCons((MemPtr)varPtr, AM_sreg); + AM_bndFlag = ON; + + AM_hreg = nhreg; +} + + +// Delay a pair (onto the PDL stack) with a given term as the first, and a +// constant (without type association) as the second. +// Note this function is invoked in get_m_constant() when the 'dynamic' term +// is higher-order, and so it is guaranteed that tPtr is a heap address. +static void SINSTRL_delayConst(DF_TermPtr tPtr, int c) +{ + MemPtr nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkConst(AM_hreg, AM_cstUnivCount(c), c); + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + AM_hreg = nhreg; +} + +//Delay a pair (onto the PDL stack) with a given term as the first, and a +//constant with type association the second. +//Note TYWRITE mode is set to ON. +static void SINSTRL_delayTConst(DF_TermPtr tPtr, int c) +{ + MemPtr nhreg = AM_hreg + DF_TM_TCONST_SIZE; + AM_heapError(nhreg + DF_TY_ATOMIC_SIZE * AM_cstTyEnvSize(c)); + DF_mkTConst(AM_hreg, AM_cstUnivCount(c), c, (DF_TypePtr)nhreg); + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + AM_hreg = nhreg; + AM_tyWriteFlag = ON; +} + +//Delay a pair (onto the PDL stack) with a given term and an integer +static void SINSTRL_delayInt(DF_TermPtr tPtr, int i) +{ + MemPtr nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkInt(AM_hreg, i); + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + AM_hreg = nhreg; +} + +//Delay a pair (onto the PDL stack) with a given term and a float +static void SINSTRL_delayFloat(DF_TermPtr tPtr, float f) +{ + MemPtr nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkFloat(AM_hreg, f); + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + AM_hreg = nhreg; +} + +//Delay a pair (onto the PDL stack) with a given term and a string +static void SINSTRL_delayString(DF_TermPtr tPtr, DF_StrDataPtr str) +{ + MemPtr nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkStr(AM_hreg, str); + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + AM_hreg = nhreg; +} + +//Delay a pair (onto the PDL stack) with a given term and nil list +static void SINSTRL_delayNil(DF_TermPtr tPtr) +{ + MemPtr nhreg = AM_hreg + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkNil(AM_hreg); + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + AM_hreg = nhreg; +} + +//Delay a pair (onto the PDL stack) with a given term and an application +//object with a non-type-associated constant head. +//Setting registers 1)entering WRITE mode: S and WRITE; 2)entering OCC OFF +//mode; 3) ADJ +void SINSTRL_delayStr(DF_TermPtr tPtr, int constInd, int arity) +{ + MemPtr args = AM_hreg + DF_TM_APP_SIZE; + MemPtr func = args + arity * DF_TM_ATOMIC_SIZE; + MemPtr nhreg = func + DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkApp(AM_hreg, arity, (DF_TermPtr)func, (DF_TermPtr)args); //mk app + DF_mkConst(func, AM_cstUnivCount(constInd), constInd); //mk const + //push onto PDL + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + //enter WRITE mode + AM_sreg = (DF_TermPtr)args; AM_writeFlag = ON; + //enter OCC OFF mode + AM_ocFlag = OFF; + AM_adjreg = AM_ucreg; + + AM_hreg = nhreg; +} + +//Delay a pair (onto the PDL stack) with a given term and an application +//object with a type-associated constant head. +//Setting registers 1)entering WRITE and TYWRITE mode: S, WRITE and TYWRITE; +// 2)entering OCC OFF mode; 3) ADJ +void SINSTRL_delayTStr(DF_TermPtr tPtr, int constInd, int arity) +{ + MemPtr args = AM_hreg + DF_TM_APP_SIZE; + MemPtr func = args + arity * DF_TM_ATOMIC_SIZE; + MemPtr nhreg = func + DF_TM_TCONST_SIZE; + AM_heapError(nhreg + AM_cstTyEnvSize(constInd) + DF_TY_ATOMIC_SIZE); + DF_mkApp(AM_hreg, arity, (DF_TermPtr)func, (DF_TermPtr)args); //mk app + DF_mkTConst(func, AM_cstUnivCount(constInd), constInd, (DF_TypePtr)nhreg); + //push onto PDL + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + //enter WRITE and TYWRITE mode + AM_sreg = (DF_TermPtr)args; AM_writeFlag = ON; AM_tyWriteFlag = ON; + //enter OCC OFF mode + AM_ocFlag = OFF; + AM_adjreg = AM_ucreg; + + AM_hreg = nhreg; +} + +//Delay a pair (onto the PDL stack) with a given term and a list cons +//Setting registers 1)entering WRITE mode: S and WRITE; 2)entering OCC OFF +//mode; 3) ADJ +void SINSTRL_delayCons(DF_TermPtr tPtr) +{ + MemPtr args = AM_hreg + DF_TM_ATOMIC_SIZE; + MemPtr nhreg = args + DF_CONS_ARITY * DF_TM_ATOMIC_SIZE; + AM_heapError(nhreg); + DF_mkCons(AM_hreg, (DF_TermPtr)args); + //push onto PDL + AM_pdlError(2); + AM_pushPDL((MemPtr)tPtr); + AM_pushPDL(AM_hreg); + //enter WRITE mode + AM_sreg = (DF_TermPtr)args; AM_writeFlag = ON; + //enter OCC OFF mode + AM_ocFlag = OFF; + AM_adjreg = AM_ucreg; + + AM_hreg = nhreg; +} + +/*The main action of unify_value in write mode. This code carries out the */ +/*necessary occurs checking in the binding of a variable that has already */ +/*commenced through an enclosing get_structure instruction. */ +/*Care has been taken to avoid making a reference to a register or stack */ +/*address. */ +void SINSTRL_bindSreg(DF_TermPtr tmPtr) +{ + DF_TermPtr bndBody; + int nabs; + + HN_hnormOcc(tmPtr); + nabs = AM_numAbs; + HOPU_copyFlagGlb = FALSE; + if (AM_rigFlag) { + bndBody = HOPU_rigNestedSubstC(AM_head, HOPU_lamBody(tmPtr), AM_argVec, + AM_numArgs, nabs); + if (nabs) DF_mkLam((MemPtr)AM_sreg, nabs, bndBody); //no emb error + else { + if (HOPU_copyFlagGlb) DF_mkRef((MemPtr)AM_sreg, bndBody); + else HOPU_globalizeCopyRigid(bndBody, AM_sreg); + } + } else { //AM_rigFlag = FALSE + bndBody = HOPU_flexNestedSubstC(AM_head, AM_argVec, AM_numArgs, + HOPU_lamBody(tmPtr), nabs); + if (HOPU_copyFlagGlb == FALSE) bndBody = HOPU_globalizeFlex(bndBody); + if (nabs) DF_mkLam((MemPtr)AM_sreg, nabs, bndBody); + else DF_mkRef((MemPtr)AM_sreg, bndBody); + } +} + +/*The main component of unify_local_value in write mode when it is determined */ +/*that we are dealing with a heap cell. */ +void SINSTRL_bindSregH(DF_TermPtr tmPtr) +{ + DF_TermPtr bndBody; + int nabs; + + HN_hnormOcc(tmPtr); + nabs = AM_numAbs; + HOPU_copyFlagGlb = FALSE; + if (AM_rigFlag) { + bndBody = HOPU_rigNestedSubstC(AM_head, HOPU_lamBody(tmPtr), AM_argVec, + AM_numArgs, nabs); + if (nabs) DF_mkLam((MemPtr)AM_sreg, nabs, bndBody); + else DF_mkRef((MemPtr)AM_sreg, bndBody); + } else { //AM_rigFlag = FALSE + bndBody = HOPU_flexNestedSubstC(AM_head, AM_argVec, AM_numArgs, + HOPU_lamBody(tmPtr), nabs); + if (nabs) DF_mkLam((MemPtr)AM_sreg, nabs, bndBody); + else DF_mkRef((MemPtr)AM_sreg, bndBody); + } +} + + +/*****************************************************************************/ +/* Auxiliary functions for unifying terms used in get- and unify- instrutions*/ +/*****************************************************************************/ + +//attempting to unify a dereference term with a constant without type assoc +void SINSTRL_unifyConst(DF_TermPtr tmPtr, int constInd) +{ + switch (DF_termTag(tmPtr)) { + case DF_TM_TAG_VAR: + { + if (DF_fvUnivCount(tmPtr)<AM_cstUnivCount(constInd)) EM_THROW(EM_FAIL); + SINSTRL_bindConst(tmPtr, constInd); + return; + } + case DF_TM_TAG_CONST: + { + if (constInd != DF_constTabIndex(tmPtr)) EM_THROW(EM_FAIL); + return; + } + case DF_TM_TAG_APP: + { + if (DF_isConst(DF_termDeref(DF_appFunc(tmPtr)))) EM_THROW(EM_FAIL); + } + case DF_TM_TAG_LAM: case DF_TM_TAG_SUSP: //and other APP cases + { + HN_hnorm(tmPtr); + if (AM_rigFlag) { + if (DF_isConst(AM_head) && (DF_constTabIndex(AM_head) == constInd)){ + if (AM_numAbs != AM_numArgs) EM_THROW(EM_FAIL); + if (AM_numAbs != 0) SINSTRL_delayConst(tmPtr, constInd);//h-ord + } else EM_THROW(EM_FAIL); + } else { // (AM_rigFlag == OFF) + if (AM_numArgs == 0) { + if ((AM_numAbs == 0) && + (DF_fvUnivCount(AM_head) >= AM_cstUnivCount(constInd))) + SINSTRL_bindConst(AM_head, constInd); + else EM_THROW(EM_FAIL); + } else SINSTRL_delayConst(tmPtr, constInd); //higher-order + } // (AM_rigFlag == OFF) + return; + } + default:{ EM_THROW(EM_FAIL); } //CONS, NIL, BVAR, INT, FLOAT, STR, (STREAM) + } //switch +} + +//attempting to unify a dereferenced term with an integer +void SINSTRL_unifyInt(DF_TermPtr tmPtr, int intValue) +{ + switch (DF_termTag(tmPtr)) { + case DF_TM_TAG_VAR: { SINSTRL_bindInt(tmPtr, intValue); return; } + case DF_TM_TAG_INT: + { + if (intValue != DF_intValue(tmPtr)) EM_THROW(EM_FAIL); + return; + } + case DF_TM_TAG_APP: + { //Note the functor of app cannot be an integer per well-typedness + if (DF_isConst(DF_termDeref(DF_appFunc(tmPtr)))) EM_THROW(EM_FAIL); + } + case DF_TM_TAG_SUSP: //and other APP cases + { // Note ABS cannot occur due to well-typedness + HN_hnorm(tmPtr); + if (AM_rigFlag) { + if (DF_isInt(AM_head) && (DF_intValue(AM_head) == intValue)) return; + else EM_THROW(EM_FAIL); + } else { //(AM_rigFlag == OFF) + if (AM_numArgs == 0) //note AM_numAbs must be 0 because of type + SINSTRL_bindInt(AM_head, intValue); + else SINSTRL_delayInt(tmPtr, intValue); + return; + } //(AM_rigFlag == OFF) + } + default: { EM_THROW(EM_FAIL); } //BVAR, CONST + } //switch +} + +//attempting to unify a dereferenced term with a real number +void SINSTRL_unifyFloat(DF_TermPtr tmPtr, float floatValue) +{ + switch (DF_termTag(tmPtr)){ + case DF_TM_TAG_VAR: { SINSTRL_bindFloat(tmPtr, floatValue); return; } + case DF_TM_TAG_FLOAT: + { + if (floatValue != DF_floatValue(tmPtr)) EM_THROW(EM_FAIL); + return; + } + case DF_TM_TAG_APP: + { //Note the functor of app cannot be a float per well-typedness + if (DF_isConst(DF_termDeref(DF_appFunc(tmPtr)))) EM_THROW(EM_FAIL); + } + case DF_TM_TAG_SUSP: //other APP cases + { //Note ABS cannot occur due to well-typedness + HN_hnorm(tmPtr); + if (AM_rigFlag) { + if (DF_isFloat(AM_head) && (DF_floatValue(AM_head) == floatValue)) + return; + else EM_THROW(EM_FAIL); + } else { //(AM_rigFlag == OFF) + if (AM_numArgs == 0) //note AM_numAbs must be 0 because of type + SINSTRL_bindFloat(AM_head, floatValue); + else SINSTRL_delayFloat(tmPtr, floatValue); + return; + } //(AM_rigFlag == OFF) + } + default: { EM_THROW(EM_FAIL); } //BVAR, CONST + } //switch +} + +//attempting to unify a dereferenced term with a string +void SINSTRL_unifyString(DF_TermPtr tmPtr, DF_StrDataPtr str) +{ + switch (DF_termTag(tmPtr)){ + case DF_TM_TAG_VAR: { SINSTRL_bindString(tmPtr, str); return; } + case DF_TM_TAG_STR: + { + if (!DF_sameStrData(tmPtr, str)) EM_THROW(EM_FAIL); + return; + } + case DF_TM_TAG_APP: + { //Note the functor of app cannot be a string per well-typedness + if (DF_isConst(DF_termDeref(DF_appFunc(tmPtr)))) EM_THROW(EM_FAIL); + } + case DF_TM_TAG_SUSP: //and other APP cases + { //Note ABS cannot occur due to well-typedness + HN_hnorm(tmPtr); + if (AM_rigFlag) { + if (DF_isStr(AM_head) && (DF_sameStrData(AM_head, str))) return; + else EM_THROW(EM_FAIL); + } else {//(AM_rigFlag == OFF) + if (AM_numArgs == 0) //note AM_numAbs must be 0 because of type + SINSTRL_bindString(AM_head, str); + else SINSTRL_delayString(tmPtr, str); + return; + } //(AM_rigFlag == OFF) + } + default: { EM_THROW(EM_FAIL); } //BVAR, CONST + } //switch +} + + +//attempting to unify a dereferenced term with a constant with type assoc +void SINSTRL_unifyTConst(DF_TermPtr tmPtr, int constInd, CSpacePtr label) +{ + switch (DF_termTag(tmPtr)) { + case DF_TM_TAG_VAR: + { + if (DF_fvUnivCount(tmPtr)<AM_cstUnivCount(constInd)) EM_THROW(EM_FAIL); + SINSTRL_bindTConst(tmPtr, constInd); + return; + } + case DF_TM_TAG_CONST: + { + if (constInd != DF_constTabIndex(tmPtr)) EM_THROW(EM_FAIL); + AM_preg = label; + return; + } + case DF_TM_TAG_APP: + { + if (DF_isConst(DF_termDeref(DF_appFunc(tmPtr)))) EM_THROW(EM_FAIL); + } + case DF_TM_TAG_LAM: case DF_TM_TAG_SUSP: //other APP cases + { + HN_hnorm(tmPtr); + if (AM_rigFlag) { + if (DF_isConst(AM_head) && (DF_constTabIndex(AM_head) == constInd)){ + if (AM_numAbs != AM_numArgs) EM_THROW(EM_FAIL); + if (AM_numAbs == 0) AM_preg = label; //first-order + else SINSTRL_delayTConst(tmPtr, constInd); //higher-order + } else EM_THROW(EM_FAIL); + } else { //(AM_rigFlag == OFF) + if (AM_numAbs == 0) { + if ((AM_numAbs == 0) && + (DF_fvUnivCount(AM_head) >= AM_cstUnivCount(constInd))) + SINSTRL_bindTConst(AM_head, constInd); + else EM_THROW(EM_FAIL); + } else SINSTRL_delayTConst(tmPtr, constInd); //higher-order + } //(AM_rigFlag == OFF) + return; + } + default: { EM_THROW(EM_FAIL); } //CONS, NIL, BVAR, INT, FLOAT, STR, (STREAM) + } //switch +} + +//attempting to unify a dereferenced term with a nil list +void SINSTRL_unifyNil(DF_TermPtr tmPtr) +{ + switch (DF_termTag(tmPtr)){ + case DF_TM_TAG_VAR: { SINSTRL_bindNil(tmPtr); return; } + case DF_TM_TAG_NIL: { return; } + case DF_TM_TAG_CONS: { EM_THROW(EM_FAIL);} + case DF_TM_TAG_APP: + { + if (DF_isConst(DF_termDeref(DF_appFunc(tmPtr)))) EM_THROW(EM_FAIL); + } + case DF_TM_TAG_SUSP: //and other APP cases + { //Note ABS cannot occur due to well-typedness + HN_hnorm(tmPtr); + if (AM_consFlag) EM_THROW(EM_FAIL); + if (AM_rigFlag) { + if (DF_isNil(AM_head)) return; + EM_THROW(EM_FAIL); + } else { //(AM_rigFlag == OFF) + if (AM_numArgs == 0) //note AM_numAbs must be 0 because of type + SINSTRL_bindNil(AM_head); + else SINSTRL_delayNil(tmPtr); + return; + } //(AM_rigFlag == OFF) + } + default: { EM_THROW(EM_FAIL); }//BVAR, CONST, CONS + } //switch +} + + diff --git a/src/runtime/c/teyjus/simulator/siminstrlocal.h b/src/runtime/c/teyjus/simulator/siminstrlocal.h new file mode 100644 index 000000000..e5a938261 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/siminstrlocal.h @@ -0,0 +1,99 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* */ +/* File siminstrlocal.h. This file contains the declarations of auxiliary */ +/* functions used in siminstr.c. */ +/***************************************************************************/ +#ifndef SIMINSTRL_H +#define SIMINSTRL_H + +#include "dataformats.h" + +/*****************************************************************************/ +/* Auxiliary functions for unifying terms used in get- and unify- instrutions*/ +/*****************************************************************************/ + +//attempting to unify a dereferenced term with a constant without type assoc +void SINSTRL_unifyConst(DF_TermPtr tmPtr, int constInd); + +//attempting to unify a dereferenced term with an integer +void SINSTRL_unifyInt(DF_TermPtr tmPtr, int intValue); + +//attempting to unify a dereferenced term with a real number +void SINSTRL_unifyFloat(DF_TermPtr tmPtr, float floatValue); + +//attempting to unify a dereferenced term with a string +void SINSTRL_unifyString(DF_TermPtr tmPtr, DF_StrDataPtr str); + +//attempting to unify a dereferenced term with a constant with type assoc +void SINSTRL_unifyTConst(DF_TermPtr tmPtr, int constInd, CSpacePtr label); + +//attempting to unify a dereferenced term with a nil list +void SINSTRL_unifyNil(DF_TermPtr tmPtr); + +//Bind a free variable to an application object with a non-type-associated +//constant head. +//Setting relevant registers for 1)entering WRITE mode 2)entering OCC mode +// 3)indicating the occurrence of binding (BND = ON). +void SINSTRL_bindStr(DF_TermPtr varPtr, int constInd, int arity); + +//Bind a free variable to an application object with a type-associated +//constant head. +//Setting relevant registers for 1)entering WRITE and TYWRITE mode 2)entering +// OCC mode 3)indicating the occurrence of binding (BND = ON). +void SINSTRL_bindTStr(DF_TermPtr varPtr, int constInd, int arity); + +//Bind a free variable to a list cons. +//Setting relevant registers for 1)entering WRITE mode 2)entering OCC mode +// 3)indicating the occurrence of binding (BND = ON). +void SINSTRL_bindCons(DF_TermPtr varPtr); + +//Delay a pair (onto the PDL stack) with a given term and an application +//object with a non-type-associated constant head. +//Setting registers 1)entering WRITE mode: S and WRITE; 2)entering OCC OFF +//mode; 3) ADJ +void SINSTRL_delayStr(DF_TermPtr tPtr, int constInd, int arity); + +//Delay a pair (onto the PDL stack) with a given term and an application +//object with a type-associated constant head. +//Setting registers 1)entering WRITE and TYWRITE mode: S, WRITE and TYWRITE; +// 2)entering OCC OFF mode; 3) ADJ +void SINSTRL_delayTStr(DF_TermPtr tPtr, int constInd, int arity); + +//Delay a pair (onto the PDL stack) with a given term and a list cons +//Setting registers 1)entering WRITE mode: S and WRITE; 2)entering OCC OFF +//mode; 3) ADJ +void SINSTRL_delayCons(DF_TermPtr tPtr); + + +/*The main action of unify_value in write mode. This code carries out the */ +/*necessary occurs checking in the binding of a variable that has already */ +/*commenced through an enclosing get_structure instruction. */ +/*Care has been taken to avoid making a reference to a register or stack */ +/*address. */ +void SINSTRL_bindSreg(DF_TermPtr tmPtr); + +/*The main component of unify_local_value in write mode when it is determined */ +/*that we are dealing with a heap cell. */ +void SINSTRL_bindSregH(DF_TermPtr tmPtr); + + +#endif //SIMINSTRL_H diff --git a/src/runtime/c/teyjus/simulator/simulator.c b/src/runtime/c/teyjus/simulator/simulator.c new file mode 100644 index 000000000..6d9b8645b --- /dev/null +++ b/src/runtime/c/teyjus/simulator/simulator.c @@ -0,0 +1,62 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File simulator.c. This file contains the procedure that emulates the * + * lambda Prolog abstract machine. * + ****************************************************************************/ + +#ifndef SIMULATOR_C +#define SIMULATOR_C + +#include "simdispatch.h" +#include "abstmachine.h" +#include "trail.h" +#include "../system/error.h" //to be modified +#include "../tables/instructions.h" //to be modified + +#include <stdio.h> //temp + +void SIM_simulate() +{ + restart_loop: + EM_TRY { + while(1) { + /*fprintf(stderr, "AM_preg %u opcode: %d\n", AM_preg, + *((INSTR_OpCode *)AM_preg)); */ + SDP_dispatchTable[*((INSTR_OpCode *)AM_preg)](); + } + /* it's expected that this statement not be reached: the only + way out of this while loop is by an exception */ + } EM_CATCH { + if (EM_CurrentExnType == EM_FAIL) { + if (AM_botCP()) EM_RETHROW(); + else { + TR_unwindTrail(AM_cpTR()); + AM_initPDL(); + AM_bndFlag = OFF; + AM_preg = AM_cpNCL(); + goto restart_loop; + } + } else EM_RETHROW(); + } +} + +#endif /* SIMULATOR_C */ diff --git a/src/runtime/c/teyjus/simulator/simulator.h b/src/runtime/c/teyjus/simulator/simulator.h new file mode 100644 index 000000000..5aed0b67e --- /dev/null +++ b/src/runtime/c/teyjus/simulator/simulator.h @@ -0,0 +1,32 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File simulator.h. This ``header'' file identifies the functions defined * + * in simulator.c that are exported from there. * + * * + ****************************************************************************/ + +#ifndef SIMULATOR_H +#define SIMULATOR_H + +void SIM_simulate(); + +#endif /* SIMULATOR_H */ diff --git a/src/runtime/c/teyjus/simulator/trail.c b/src/runtime/c/teyjus/simulator/trail.c new file mode 100644 index 000000000..9a758f043 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/trail.c @@ -0,0 +1,141 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File trail.c. This file defines the trail operations including */ +/* trailing and unwinding. */ +/* */ +/****************************************************************************/ + +#ifndef TRAIL_C +#define TRAIL_C + +#include "trail.h" + +static int TR_trailItemTag(TR_TrailItem *trPtr) { return (trPtr -> tag); } +static MemPtr TR_trailItemAddr(TR_TrailItem *trPtr) { return (trPtr -> addr);} + +/***************************************************************************/ +/* TRAILING FUNCTIONS */ +/***************************************************************************/ +void TR_trailTerm(DF_TermPtr addr) //trailing a term of atomic size +{ + if (((MemPtr)addr <= AM_hbreg) || + (AM_hreg < (MemPtr)addr) && ((MemPtr)addr < AM_breg)) { + AM_trailError(TR_TRAIL_TERM_SIZE); + DF_copyAtomic(addr, AM_trreg); + ((TR_TrailItem*)(AM_trreg+DF_TM_ATOMIC_SIZE))->tag = TR_TAG_TERM; + ((TR_TrailItem*)(AM_trreg+DF_TM_ATOMIC_SIZE))->addr = (MemPtr)addr; + AM_trreg += TR_TRAIL_TERM_SIZE; + } +} + +void TR_trailHTerm(DF_TermPtr addr) //trailing a heap term of atomic size +{ + if ((MemPtr)addr < AM_hbreg) { + AM_trailError(TR_TRAIL_TERM_SIZE); + DF_copyAtomic(addr, AM_trreg); + ((TR_TrailItem*)(AM_trreg+DF_TM_ATOMIC_SIZE)) -> tag = TR_TAG_TERM; + ((TR_TrailItem*)(AM_trreg+DF_TM_ATOMIC_SIZE)) -> addr = (MemPtr)addr; + AM_trreg += TR_TRAIL_TERM_SIZE; + } +} + +void TR_trailETerm(DF_TermPtr addr) //trailing a stack term +{ + if ((MemPtr)addr < AM_breg) { + AM_trailError(TR_TRAIL_TERM_SIZE); + DF_copyAtomic(addr, AM_trreg); + ((TR_TrailItem*)(AM_trreg+DF_TM_ATOMIC_SIZE)) -> tag = TR_TAG_TERM; + ((TR_TrailItem*)(AM_trreg+DF_TM_ATOMIC_SIZE)) -> addr = (MemPtr)addr; + AM_trreg += TR_TRAIL_TERM_SIZE; + } +} + + +void TR_trailType(DF_TypePtr addr) //trailing a type (free variable) +{ + if (((MemPtr)addr < AM_hbreg) || + ((AM_hreg < (MemPtr)addr) && ((MemPtr)addr < AM_breg))){ + AM_trailError(TR_TRAIL_TYPE_SIZE); + ((TR_TrailItem*)AM_trreg) -> tag = TR_TAG_TYPE; + ((TR_TrailItem*)AM_trreg) -> addr = (MemPtr)addr; + AM_trreg += TR_TRAIL_TYPE_SIZE; + } +} + +//temp +void TR_trailImport(MemPtr addr) //trailing a backchained field +{ + AM_trailError(TR_TRAIL_MOD_SIZE); + *AM_trreg = *addr; + *(AM_trreg+1) = *(addr+1); + ((TR_TrailItem*)(AM_trreg+2)) -> tag = TR_TAG_MOD; + ((TR_TrailItem*)(AM_trreg+2)) -> addr = addr; + AM_trreg += TR_TRAIL_MOD_SIZE; +} + +/****************************************************************************/ +/* UNWIND TRAIL FUNCTION */ +/****************************************************************************/ +void TR_unwindTrail(MemPtr trOld) +{ + MemPtr addr; + + while (AM_trreg > trOld){ + AM_trreg -= TR_TRAIL_ITEM_HEAD_SIZE; + addr = TR_trailItemAddr((TR_TrailItem*)AM_trreg); + switch (TR_trailItemTag((TR_TrailItem*)AM_trreg)){ + case TR_TAG_TERM: + { + AM_trreg -= DF_TM_ATOMIC_SIZE; + DF_copyAtomic((DF_TermPtr)AM_trreg, addr); + break; + } + case TR_TAG_MULTERM1: + { + AM_trreg -= DF_TM_APP_SIZE; + DF_copyApp((DF_TermPtr)AM_trreg, addr); + break; + } + case TR_TAG_MULTERM2: + { + AM_trreg -= DF_TM_SUSP_SIZE; + DF_copySusp((DF_TermPtr)AM_trreg, addr); + break; + } + case TR_TAG_TYPE: + { + DF_mkFreeVarType(addr); + break; + } + case TR_TAG_MOD: //temp + { + AM_trreg -= 2; + *addr = *AM_trreg; + *(addr+1) = *(AM_trreg + 1); + break; + } + } //switch + } //while +} + + +#endif //TRAIL_C diff --git a/src/runtime/c/teyjus/simulator/trail.h b/src/runtime/c/teyjus/simulator/trail.h new file mode 100644 index 000000000..675392b4b --- /dev/null +++ b/src/runtime/c/teyjus/simulator/trail.h @@ -0,0 +1,80 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File trail.h. This header file includes the interface functions */ +/* for trail operations. */ +/* */ +/****************************************************************************/ +#ifndef TRAIL_H +#define TRAIL_H + +#include <stdlib.h> +#include "mctypes.h" +#include "abstmachine.h" +#include "dataformats.h" + +/****************************************************************************/ +/* DATA STRUCTURE OF TRAIL ITEMS */ +/****************************************************************************/ +/* The tags of trail items */ +enum TR_TrailDataCategory +{ + TR_TAG_TERM, + TR_TAG_MULTERM1, + TR_TAG_MULTERM2, + TR_TAG_TYPE, + TR_TAG_MOD +}; + +/* The leading slot of trail items */ +typedef struct +{ + Byte tag; //trial data category tag + MemPtr addr; //the starting address of the trailed item +} TR_TrailItem; + +/* The size of the trail item head */ +#define TR_TRAIL_ITEM_HEAD_SIZE (int)ceil((double)sizeof(TR_TrailItem)/WORD_SIZE) +/* The sizes of different trail items */ +#define TR_TRAIL_TERM_SIZE TR_TRAIL_ITEM_HEAD_SIZE + DF_TM_ATOMIC_SIZE +#define TR_TRAIL_MULTERM1_SIZE TR_TRAIL_ITEM_HEAD_SIZE + DF_TM_APP_SIZE +#define TR_TRAIL_MULTERM2_SIZE TR_TRAIL_ITEM_HEAD_SIZE + DF_TM_SUSP_SIZE +#define TR_TRAIL_TYPE_SIZE TR_TRAIL_ITEM_HEAD_SIZE +//temp +#define TR_TRAIL_MOD_SIZE TR_TRAIL_ITEM_HEAD_SIZE + 2 + +/***************************************************************************/ +/* TRAILING FUNCTIONS */ +/***************************************************************************/ +void TR_trailTerm(DF_TermPtr addr); //trailing a term of atomic size +void TR_trailHTerm(DF_TermPtr addr); //trailing a heap term of atomic size +void TR_trailETerm(DF_TermPtr addr); //trailing a stack term +void TR_trailType(DF_TypePtr addr); //trailing a type (free type variable) +void TR_trailImport(MemPtr addr); //trailing a backchained field + + +/****************************************************************************/ +/* UNWIND TRAIL FUNCTION */ +/****************************************************************************/ +void TR_unwindTrail(MemPtr trOld); + +#endif //TRAIL_H + diff --git a/src/runtime/c/teyjus/simulator/types.c b/src/runtime/c/teyjus/simulator/types.c new file mode 100644 index 000000000..653ccbd9b --- /dev/null +++ b/src/runtime/c/teyjus/simulator/types.c @@ -0,0 +1,194 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File types.c. This file contains routines implementing the interpretive */ +/* part of type unification including those needed within (interpretive) */ +/* higher-order pattern unification. */ +/* */ +/****************************************************************************/ +#ifndef TYPES_C +#define TYPES_C + +#include "dataformats.h" +#include "abstmachine.h" +#include "trail.h" +#include "../system/error.h" + +/* Push n types onto PDL */ +static void TY_pushTypesToPDL(MemPtr tyPtr, int n) +{ + AM_pdlError(n); + n--; tyPtr += n * DF_TY_ATOMIC_SIZE; //start from the nth type + for (; n >= 0; n--) { AM_pushPDL(tyPtr); tyPtr -= DF_TY_ATOMIC_SIZE; } +} + +/* Push n pair of types onto PDL. */ +void TY_pushPairsToPDL(MemPtr tyPtr1, MemPtr tyPtr2, int n) +{ + AM_pdlError(2*n); + n--; tyPtr1 += n * DF_TY_ATOMIC_SIZE; tyPtr2 += n * DF_TY_ATOMIC_SIZE; + for (; n >= 0; n--){ //start from the nth pair + AM_pushPDL(tyPtr1); tyPtr1 -= DF_TY_ATOMIC_SIZE; + AM_pushPDL(tyPtr2); tyPtr2 -= DF_TY_ATOMIC_SIZE; + } +} + +/* Perform occurs check for the type variable currently referred to by + AM_tyvbbreg over the type on the current top of PDL. +*/ +static void TY_typesOcc() +{ + DF_TypePtr tyPtr; // current type structure being examined + MemPtr pdlBotTmp = AM_pdlTop - 1; //tmp PDL + while (AM_pdlTop > pdlBotTmp){ + tyPtr = DF_typeDeref((DF_TypePtr)AM_popPDL()); + switch (DF_typeTag(tyPtr)){ + case DF_TY_TAG_REF: { + if (AM_tyvbbreg == tyPtr) EM_THROW(EM_FAIL); + break; + } + case DF_TY_TAG_SORT: break; + case DF_TY_TAG_STR: { + DF_TypePtr fPtr = DF_typeStrFuncAndArgs(tyPtr); + TY_pushTypesToPDL((MemPtr)DF_typeStrArgs(fPtr), + DF_typeStrFuncArity(fPtr)); + break; + } + case DF_TY_TAG_ARROW: { + TY_pushTypesToPDL((MemPtr)DF_typeArrowArgs(tyPtr), + DF_TY_ARROW_ARITY); + break; + } + } //switch + } //while (AM_pdlTop > pdlBotTmp +} + + +/* Bind two free variables. The one with higher address is updated. */ +static void TY_bindVars(DF_TypePtr varPtr1, DF_TypePtr varPtr2) +{ + if (varPtr2 < varPtr1){ + TR_trailType(varPtr1); + DF_copyAtomicType(varPtr2, (MemPtr)varPtr1); + } else { + TR_trailType(varPtr2); + DF_copyAtomicType(varPtr1, (MemPtr)varPtr2); + } +} + +/* Bind a variable to a type. Note occurs-check is performed. */ +static void TY_bind(DF_TypePtr varPtr, DF_TypePtr tyPtr) +{ + AM_pdlError(1); + AM_pushPDL((MemPtr)tyPtr); + AM_tyvbbreg = varPtr; //type variable being bound + TY_typesOcc(); + TR_trailType(varPtr); + DF_copyAtomicType(tyPtr, (MemPtr)varPtr); +} + +/* The main routine for interpretive type unification. The assumption is + that the pair of types are referred from the top two cells in the PDL + stack. +*/ +void TY_typesUnify() +{ + DF_TypePtr tyPtr1, tyPtr2; + + while (AM_nemptyTypesPDL()){ + tyPtr2 = DF_typeDeref((DF_TypePtr)AM_popPDL()); + tyPtr1 = DF_typeDeref((DF_TypePtr)AM_popPDL()); + if (tyPtr1 != tyPtr2) { //not referring to the same mem location + if (DF_isRefType(tyPtr1)) + if (DF_isRefType(tyPtr2)) TY_bindVars(tyPtr1, tyPtr2); + else TY_bind(tyPtr1, tyPtr2); + else { //tyPtr1 is not reference + switch (DF_typeTag(tyPtr2)){ + case DF_TY_TAG_REF: { TY_bind(tyPtr2, tyPtr1); break; } + case DF_TY_TAG_SORT: { + if (!(DF_isSortType(tyPtr1) && + DF_typeKindTabIndex(tyPtr1)==DF_typeKindTabIndex(tyPtr2))) + EM_THROW(EM_FAIL); + break; + } + case DF_TY_TAG_ARROW:{ + if (!DF_isArrowType(tyPtr1)) EM_THROW(EM_FAIL); + TY_pushPairsToPDL((MemPtr)DF_typeArrowArgs(tyPtr1), + (MemPtr)DF_typeArrowArgs(tyPtr2), + DF_TY_ARROW_ARITY); + break; + } + case DF_TY_TAG_STR: { + if (DF_isStrType(tyPtr1)){ + DF_TypePtr fPtr1 = DF_typeStrFuncAndArgs(tyPtr1), + fPtr2 = DF_typeStrFuncAndArgs(tyPtr2); + if (DF_typeStrFuncInd(fPtr1) == DF_typeStrFuncInd(fPtr2)) + TY_pushPairsToPDL((MemPtr)DF_typeStrArgs(fPtr1), + (MemPtr)DF_typeStrArgs(fPtr2), + DF_typeStrFuncArity(fPtr1)); + else EM_THROW(EM_FAIL); //different function + } else EM_THROW(EM_FAIL); //tyPtr1 not str or ref + break; + } + } //switch + } //tyPtr1 not ref + } //tyPtr1 != tyPtr2 + } //while (AM_nemptyTypesPDL()) +} + + +/***************************************************************************** + * Occurs check over types. This version is used when the check has to be * + * performed within the compiled form of unification. In particular, this * + * routine would be invoked from within the unify_type_value class of * + * instructions in read mode. The peculiarity of this situation is that the * + * binding of the relevant type variable would have been started already by * + * a get_type_structure or get_type_arrow instruction, so we have to check * + * for the occurrence of the structure created as a consequence of this * + * rather than for a variable occurrence. * + *****************************************************************************/ +void TY_typesOccC() +{ + DF_TypePtr tyPtr; + while (AM_nemptyTypesPDL()){ + tyPtr = DF_typeDeref((DF_TypePtr)AM_popPDL()); + switch (DF_typeTag(tyPtr)) { + case DF_TY_TAG_REF: case DF_TY_TAG_SORT: break; + case DF_TY_TAG_STR: + { + DF_TypePtr fPtr = DF_typeStrFuncAndArgs(tyPtr); + if (AM_tyvbbreg == fPtr) EM_THROW(EM_FAIL); + TY_pushTypesToPDL((MemPtr)DF_typeStrArgs(fPtr), + DF_typeStrFuncArity(fPtr)); + break; + } + case DF_TY_TAG_ARROW: + { + DF_TypePtr args = DF_typeArrowArgs(tyPtr); + if (AM_tyvbbreg == args) EM_THROW(EM_FAIL); + TY_pushTypesToPDL((MemPtr)args, DF_TY_ARROW_ARITY); + break; + } + } //switch + } //while +} + +#endif //TYPES_C diff --git a/src/runtime/c/teyjus/simulator/types.h b/src/runtime/c/teyjus/simulator/types.h new file mode 100644 index 000000000..9cbd0e535 --- /dev/null +++ b/src/runtime/c/teyjus/simulator/types.h @@ -0,0 +1,47 @@ +////////////////////////////////////////////////////////////////////////////// +//Copyright 2008 +// Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow +////////////////////////////////////////////////////////////////////////////// +// This file is part of Teyjus. // +// // +// Teyjus is free software: you can redistribute it and/or modify // +// it under the terms of the GNU General Public License as published by // +// the Free Software Foundation, either version 3 of the License, or // +// (at your option) any later version. // +// // +// Teyjus is distributed in the hope that it will be useful, // +// but WITHOUT ANY WARRANTY; without even the implied warranty of // +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // +// GNU General Public License for more details. // +// // +// You should have received a copy of the GNU General Public License // +// along with Teyjus. If not, see <http://www.gnu.org/licenses/>. // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File types.h. This header file identifies the routines defined in */ +/* types.c that are exported from there. These routines implement */ +/* operations on types, in particular the interpretive unification on */ +/* types. These operations are typically needed in the simulator */ +/* (simulator.c) and higher-order pattern unification (houp.c). */ +/* */ +/****************************************************************************/ +#ifndef TYPES_H +#define TYPES_H + +void TY_typesUnify(); //interpretive unification on types +void TY_pushPairsToPDL(MemPtr, MemPtr, int);//push n pairs of types to PDL + +/***************************************************************************** + * Occurs check over types. This version is used when the check has to be * + * performed within the compiled form of unification. In particular, this * + * routine would be invoked from within the unify_type_value class of * + * instructions in read mode. The peculiarity of this situation is that the * + * binding of the relevant type variable would have been started already by * + * a get_type_structure or get_type_arrow instruction, so we have to check * + * for the occurrence of the structure created as a consequence of this * + * rather than for a variable occurrence. * + *****************************************************************************/ +void TY_typesOccC(); + +#endif //TYPES_H |
