summaryrefslogtreecommitdiff
path: root/src/runtime/c/teyjus/simulator
diff options
context:
space:
mode:
authorkr.angelov <kr.angelov@gmail.com>2012-07-31 15:16:04 +0000
committerkr.angelov <kr.angelov@gmail.com>2012-07-31 15:16:04 +0000
commit83b321d862472f31c0c9f7feca8360ad5bfe8a75 (patch)
tree0f0ef20ad78e25b320013c7bb160211a8612d4e9 /src/runtime/c/teyjus/simulator
parent314662dd09d5d1480007faa79258b0e93cc2aa59 (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')
-rw-r--r--src/runtime/c/teyjus/simulator/abstmachine.c617
-rw-r--r--src/runtime/c/teyjus/simulator/abstmachine.h346
-rw-r--r--src/runtime/c/teyjus/simulator/dataformats.c711
-rw-r--r--src/runtime/c/teyjus/simulator/dataformats.h417
-rw-r--r--src/runtime/c/teyjus/simulator/hnorm.c1128
-rw-r--r--src/runtime/c/teyjus/simulator/hnorm.h42
-rw-r--r--src/runtime/c/teyjus/simulator/hnormlocal.c598
-rw-r--r--src/runtime/c/teyjus/simulator/hnormlocal.h75
-rw-r--r--src/runtime/c/teyjus/simulator/hopu.c1693
-rw-r--r--src/runtime/c/teyjus/simulator/hopu.h85
-rw-r--r--src/runtime/c/teyjus/simulator/instraccess.h300
-rw-r--r--src/runtime/c/teyjus/simulator/io-datastructures.c53
-rw-r--r--src/runtime/c/teyjus/simulator/io-datastructures.h66
-rw-r--r--src/runtime/c/teyjus/simulator/mcstring.c116
-rw-r--r--src/runtime/c/teyjus/simulator/mcstring.h67
-rw-r--r--src/runtime/c/teyjus/simulator/mctypes.h54
-rw-r--r--src/runtime/c/teyjus/simulator/printterm.c814
-rw-r--r--src/runtime/c/teyjus/simulator/printterm.h62
-rw-r--r--src/runtime/c/teyjus/simulator/simdispatch.c160
-rw-r--r--src/runtime/c/teyjus/simulator/simdispatch.h37
-rw-r--r--src/runtime/c/teyjus/simulator/siminit.c275
-rw-r--r--src/runtime/c/teyjus/simulator/siminit.h33
-rw-r--r--src/runtime/c/teyjus/simulator/siminstr.c1846
-rw-r--r--src/runtime/c/teyjus/simulator/siminstr.h248
-rw-r--r--src/runtime/c/teyjus/simulator/siminstrlocal.c583
-rw-r--r--src/runtime/c/teyjus/simulator/siminstrlocal.h99
-rw-r--r--src/runtime/c/teyjus/simulator/simulator.c62
-rw-r--r--src/runtime/c/teyjus/simulator/simulator.h32
-rw-r--r--src/runtime/c/teyjus/simulator/trail.c141
-rw-r--r--src/runtime/c/teyjus/simulator/trail.h80
-rw-r--r--src/runtime/c/teyjus/simulator/types.c194
-rw-r--r--src/runtime/c/teyjus/simulator/types.h47
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