From 2844742afdf3e84ec0f75871be540ef7a1bd7893 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Tue, 31 Jul 2012 15:16:04 +0000 Subject: [PATCH] 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. --- src/runtime/c/Makefile.am | 24 +- src/runtime/c/configure.ac | 1 + src/runtime/c/teyjus/loader/searchtab.h | 44 + src/runtime/c/teyjus/simulator/abstmachine.c | 617 +++++ src/runtime/c/teyjus/simulator/abstmachine.h | 346 +++ src/runtime/c/teyjus/simulator/dataformats.c | 711 ++++++ src/runtime/c/teyjus/simulator/dataformats.h | 417 ++++ src/runtime/c/teyjus/simulator/hnorm.c | 1128 ++++++++++ src/runtime/c/teyjus/simulator/hnorm.h | 42 + src/runtime/c/teyjus/simulator/hnormlocal.c | 598 +++++ src/runtime/c/teyjus/simulator/hnormlocal.h | 75 + src/runtime/c/teyjus/simulator/hopu.c | 1693 ++++++++++++++ src/runtime/c/teyjus/simulator/hopu.h | 85 + src/runtime/c/teyjus/simulator/instraccess.h | 300 +++ .../c/teyjus/simulator/io-datastructures.c | 53 + .../c/teyjus/simulator/io-datastructures.h | 66 + src/runtime/c/teyjus/simulator/mcstring.c | 116 + src/runtime/c/teyjus/simulator/mcstring.h | 67 + src/runtime/c/teyjus/simulator/mctypes.h | 54 + src/runtime/c/teyjus/simulator/printterm.c | 814 +++++++ src/runtime/c/teyjus/simulator/printterm.h | 62 + src/runtime/c/teyjus/simulator/simdispatch.c | 160 ++ src/runtime/c/teyjus/simulator/simdispatch.h | 37 + src/runtime/c/teyjus/simulator/siminit.c | 275 +++ src/runtime/c/teyjus/simulator/siminit.h | 33 + src/runtime/c/teyjus/simulator/siminstr.c | 1846 +++++++++++++++ src/runtime/c/teyjus/simulator/siminstr.h | 248 +++ .../c/teyjus/simulator/siminstrlocal.c | 583 +++++ .../c/teyjus/simulator/siminstrlocal.h | 99 + src/runtime/c/teyjus/simulator/simulator.c | 62 + src/runtime/c/teyjus/simulator/simulator.h | 32 + src/runtime/c/teyjus/simulator/trail.c | 141 ++ src/runtime/c/teyjus/simulator/trail.h | 80 + src/runtime/c/teyjus/simulator/types.c | 194 ++ src/runtime/c/teyjus/simulator/types.h | 47 + src/runtime/c/teyjus/system/error.h | 170 ++ src/runtime/c/teyjus/system/memory.h | 222 ++ src/runtime/c/teyjus/system/message.h | 76 + src/runtime/c/teyjus/system/operators.h | 91 + src/runtime/c/teyjus/system/stream.h | 90 + src/runtime/c/teyjus/system/tjsignal.h | 41 + src/runtime/c/teyjus/tables/README | 27 + src/runtime/c/teyjus/tables/instructions.c | 292 +++ src/runtime/c/teyjus/tables/instructions.h | 480 ++++ src/runtime/c/teyjus/tables/pervasives.c | 810 +++++++ src/runtime/c/teyjus/tables/pervasives.h | 326 +++ src/runtime/c/teyjus/tables/pervinit.c | 152 ++ src/runtime/c/teyjus/tables/pervinit.h | 73 + src/runtime/c/teyjus/tables_gen/Makefile | 28 + .../tables_gen/instrformats/instrformats.l | 69 + .../tables_gen/instrformats/instrformats.y | 283 +++ .../instrformats/instrformats_32.in | 346 +++ .../instrformats/instrformats_64.in | 346 +++ .../tables_gen/instrformats/instrgen-c.c | 650 ++++++ .../tables_gen/instrformats/instrgen-c.h | 70 + .../tables_gen/instrformats/instrgen-ocaml.c | 841 +++++++ .../tables_gen/instrformats/instrgen-ocaml.h | 47 + .../c/teyjus/tables_gen/instrformats/lex.yy.c | 1977 +++++++++++++++++ .../c/teyjus/tables_gen/instrformats/y.tab.h | 104 + .../c/teyjus/tables_gen/pervasives/ccode.c | 1024 +++++++++ .../c/teyjus/tables_gen/pervasives/ccode.h | 80 + .../teyjus/tables_gen/pervasives/ocamlcode.c | 1434 ++++++++++++ .../teyjus/tables_gen/pervasives/ocamlcode.h | 152 ++ .../c/teyjus/tables_gen/pervasives/op.c | 80 + .../c/teyjus/tables_gen/pervasives/op.h | 58 + .../tables_gen/pervasives/pervasives.in | 404 ++++ .../teyjus/tables_gen/pervasives/pervasives.l | 96 + .../teyjus/tables_gen/pervasives/pervasives.y | 351 +++ .../teyjus/tables_gen/pervasives/pervgen-c.c | 454 ++++ .../teyjus/tables_gen/pervasives/pervgen-c.h | 95 + .../tables_gen/pervasives/pervgen-ocaml.c | 350 +++ .../tables_gen/pervasives/pervgen-ocaml.h | 60 + .../c/teyjus/tables_gen/pervasives/types.c | 114 + .../c/teyjus/tables_gen/pervasives/types.h | 92 + src/runtime/c/teyjus/tables_gen/util/util.c | 135 ++ src/runtime/c/teyjus/tables_gen/util/util.h | 71 + 76 files changed, 23808 insertions(+), 3 deletions(-) create mode 100644 src/runtime/c/teyjus/loader/searchtab.h create mode 100644 src/runtime/c/teyjus/simulator/abstmachine.c create mode 100644 src/runtime/c/teyjus/simulator/abstmachine.h create mode 100644 src/runtime/c/teyjus/simulator/dataformats.c create mode 100644 src/runtime/c/teyjus/simulator/dataformats.h create mode 100644 src/runtime/c/teyjus/simulator/hnorm.c create mode 100644 src/runtime/c/teyjus/simulator/hnorm.h create mode 100644 src/runtime/c/teyjus/simulator/hnormlocal.c create mode 100644 src/runtime/c/teyjus/simulator/hnormlocal.h create mode 100644 src/runtime/c/teyjus/simulator/hopu.c create mode 100644 src/runtime/c/teyjus/simulator/hopu.h create mode 100644 src/runtime/c/teyjus/simulator/instraccess.h create mode 100644 src/runtime/c/teyjus/simulator/io-datastructures.c create mode 100644 src/runtime/c/teyjus/simulator/io-datastructures.h create mode 100644 src/runtime/c/teyjus/simulator/mcstring.c create mode 100644 src/runtime/c/teyjus/simulator/mcstring.h create mode 100644 src/runtime/c/teyjus/simulator/mctypes.h create mode 100644 src/runtime/c/teyjus/simulator/printterm.c create mode 100644 src/runtime/c/teyjus/simulator/printterm.h create mode 100644 src/runtime/c/teyjus/simulator/simdispatch.c create mode 100644 src/runtime/c/teyjus/simulator/simdispatch.h create mode 100644 src/runtime/c/teyjus/simulator/siminit.c create mode 100644 src/runtime/c/teyjus/simulator/siminit.h create mode 100644 src/runtime/c/teyjus/simulator/siminstr.c create mode 100644 src/runtime/c/teyjus/simulator/siminstr.h create mode 100644 src/runtime/c/teyjus/simulator/siminstrlocal.c create mode 100644 src/runtime/c/teyjus/simulator/siminstrlocal.h create mode 100644 src/runtime/c/teyjus/simulator/simulator.c create mode 100644 src/runtime/c/teyjus/simulator/simulator.h create mode 100644 src/runtime/c/teyjus/simulator/trail.c create mode 100644 src/runtime/c/teyjus/simulator/trail.h create mode 100644 src/runtime/c/teyjus/simulator/types.c create mode 100644 src/runtime/c/teyjus/simulator/types.h create mode 100644 src/runtime/c/teyjus/system/error.h create mode 100644 src/runtime/c/teyjus/system/memory.h create mode 100644 src/runtime/c/teyjus/system/message.h create mode 100644 src/runtime/c/teyjus/system/operators.h create mode 100644 src/runtime/c/teyjus/system/stream.h create mode 100644 src/runtime/c/teyjus/system/tjsignal.h create mode 100644 src/runtime/c/teyjus/tables/README create mode 100644 src/runtime/c/teyjus/tables/instructions.c create mode 100644 src/runtime/c/teyjus/tables/instructions.h create mode 100644 src/runtime/c/teyjus/tables/pervasives.c create mode 100644 src/runtime/c/teyjus/tables/pervasives.h create mode 100644 src/runtime/c/teyjus/tables/pervinit.c create mode 100644 src/runtime/c/teyjus/tables/pervinit.h create mode 100644 src/runtime/c/teyjus/tables_gen/Makefile create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrformats.l create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrformats.y create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrformats_32.in create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrformats_64.in create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.c create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.h create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.c create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.h create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/lex.yy.c create mode 100644 src/runtime/c/teyjus/tables_gen/instrformats/y.tab.h create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/ccode.c create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/ccode.h create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.c create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.h create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/op.c create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/op.h create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/pervasives.in create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/pervasives.l create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/pervasives.y create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.c create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.h create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.c create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.h create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/types.c create mode 100644 src/runtime/c/teyjus/tables_gen/pervasives/types.h create mode 100644 src/runtime/c/teyjus/tables_gen/util/util.c create mode 100644 src/runtime/c/teyjus/tables_gen/util/util.h diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index b0cc5ddd1..f30a909ee 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -1,10 +1,10 @@ LDADD = libgu.la -lib_LTLIBRARIES = libgu.la libpgf.la +lib_LTLIBRARIES = libgu.la libpgf.la libteyjus.la pkgconfigdir = $(libdir)/pkgconfig -pkgconfig_DATA = libgu.pc libpgf.pc +pkgconfig_DATA = libgu.pc libpgf.pc libteyjus.pc configincludedir = $(libdir)/libgu/include @@ -80,6 +80,23 @@ libgu_la_SOURCES = \ gu/variant.c \ gu/yaml.c +libteyjus_la_SOURCES = \ + teyjus/simulator/abstmachine.c \ + teyjus/simulator/dataformats.c \ + teyjus/simulator/hnorm.c \ + teyjus/simulator/hnormlocal.c \ + teyjus/simulator/hopu.c \ + teyjus/simulator/io-datastructures.c \ + teyjus/simulator/mcstring.c \ + teyjus/simulator/printterm.c \ + teyjus/simulator/simdispatch.c \ + teyjus/simulator/siminit.c \ + teyjus/simulator/siminstr.c \ + teyjus/simulator/siminstrlocal.c \ + teyjus/simulator/simulator.c \ + teyjus/simulator/trail.c \ + teyjus/simulator/types.c + libpgf_la_SOURCES = \ pgf/data.c \ pgf/data.h \ @@ -95,7 +112,7 @@ libpgf_la_SOURCES = \ pgf/reader.c \ pgf/linearize.c \ pgf/printer.c - + bin_PROGRAMS = \ utils/pgf2yaml \ utils/pgf-print \ @@ -118,4 +135,5 @@ EXTRA_DIST = \ Doxyfile \ DoxygenLayout.xml \ libgu.pc.in \ + libteyjus.pc.in \ libpgf.pc.in diff --git a/src/runtime/c/configure.ac b/src/runtime/c/configure.ac index 81bc610c9..2a8f5e0ec 100644 --- a/src/runtime/c/configure.ac +++ b/src/runtime/c/configure.ac @@ -56,6 +56,7 @@ DX_INIT_DOXYGEN(libpgf) AC_CONFIG_FILES([Makefile libgu.pc libpgf.pc + libteyjus.pc ]) AC_OUTPUT diff --git a/src/runtime/c/teyjus/loader/searchtab.h b/src/runtime/c/teyjus/loader/searchtab.h new file mode 100644 index 000000000..6559443e1 --- /dev/null +++ b/src/runtime/c/teyjus/loader/searchtab.h @@ -0,0 +1,44 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// +#ifndef _SEARCHTAB_H_ +#define _SEARCHTAB_H_ + +#include "../system/memory.h" + +#define SEARCHTAB_FCF_SEQNSEARCH 0 +#define SEARCHTAB_FCF_HASHSEARCH 1 + +extern WordPtr LD_SEARCHTAB_LoadHashTab(MEM_GmtEnt* ent, int* size); + +extern WordPtr LD_SEARCHTAB_LoadSeqSTab(MEM_GmtEnt* ent, int* size); + +/** +\brief Find code function for hash tables. +\return The address of the code corresponding to the given index. Return address for values not in the table is undefined. +**/ +extern CSpacePtr LD_SEARCHTAB_HashSrch(int constInd, int STabSize, MemPtr STabAddr); + +/** +\brief Find code function for sequential search tables. +\return The address of the code corresponding to the given index. Return address for values not in the table is undefined. + **/ +extern CSpacePtr LD_SEARCHTAB_SeqnSrch(int constInd, int STabSize, MemPtr STabAddr); + +#endif //_SEARCHTAB_H_ 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 . // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* 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 +#include +#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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* 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 +#include +#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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* 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 // to be removed +#include +//#include +#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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* 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 +#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 +#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 . // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* 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 +#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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* 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 + +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/*************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * 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 . // +////////////////////////////////////////////////////////////////////////////// + +/**************************************************************************** + * * + * 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File mcstring.c. */ +/****************************************************************************/ +#include +#include +#include +#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 . // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// + +/****************************************************************************/ +/* */ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * 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 . 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 +#include +#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 + +/* 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, ""); + 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, "", 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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * 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 . 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 . // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************/ +/* */ +/* 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 +/***************************######******************************************** + * 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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* 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 +#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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* */ +/* 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 //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))) + 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))) + 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 . // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * 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 //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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* File trail.h. This header file includes the interface functions */ +/* for trail operations. */ +/* */ +/****************************************************************************/ +#ifndef TRAIL_H +#define TRAIL_H + +#include +#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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* 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 diff --git a/src/runtime/c/teyjus/system/error.h b/src/runtime/c/teyjus/system/error.h new file mode 100644 index 000000000..6fee02113 --- /dev/null +++ b/src/runtime/c/teyjus/system/error.h @@ -0,0 +1,170 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File error.h -- error-handling functions * + * * + ****************************************************************************/ + +#ifndef ERROR_H +#define ERROR_H + +#include +#include +#include +#include "tjsignal.h" +#include "../simulator/mctypes.h" //to be modified + +/**************************************************************************** + * Exception stack declarations. * + ****************************************************************************/ + +typedef enum EM_ExnType{ + EM_NO_ERR = 0, // no errors + EM_NO_EXN, // used for warnings ?? + EM_ABORT, // exit the executable immediately + EM_EXIT, // traverse the exception stack and exit + EM_TOP_LEVEL, // return to the toplevel + EM_QUERY, // abort solving the query + EM_QUERY_RESULT, // query is solved; print answer + EM_FAIL, // fail to simulator level +} EM_ExnType; + +//function call environment stack +extern SIGNAL_jmp_buf *EM_ExnHandlerStack; +extern int EM_ExnHandlerStackTop; +extern int EM_ExnHandlerStackSize; + +//exception type +extern EM_ExnType EM_CurrentExnType; + +/**************************************************************************** + * Exception-handling macros * + ****************************************************************************/ + +//try +#define EM_TRY \ +if (EM_ExnHandlerStackTop >= EM_ExnHandlerStackSize) \ +{ \ + EM_ExnHandlerStackSize = \ + (EM_ExnHandlerStackSize + 1) * 2; \ + EM_ExnHandlerStack = \ + (SIGNAL_jmp_buf *)EM_realloc((void *)EM_ExnHandlerStack, \ + EM_ExnHandlerStackSize * sizeof(SIGNAL_jmp_buf)); \ +} \ +if (SIGNAL_setjmp(EM_ExnHandlerStack[EM_ExnHandlerStackTop++]) == 0) \ +{ + +//catch +#define EM_CATCH \ + EM_ExnHandlerStackTop--; \ +} \ +else + +//throw +/* Jump to the nearest (in a dynamic sense) EM_Try block, setting + EM_CurrentExnType to TYPE. Given a constant, the conditional in + this macro will be optimized away. + + TODO: added cast to EM_CurrentExnType. */ +#define EM_THROW(type) EM_THROWVAL((type), 1) + +#define EM_THROWVAL(type, val) \ +do { \ + if ((type) == EM_ABORT) \ + exit(1); \ + else \ + { \ + EM_CurrentExnType = (EM_ExnType)(type); \ + SIGNAL_longjmp(EM_ExnHandlerStack[--EM_ExnHandlerStackTop], val); \ + } \ +} while(0) + +//rethrow +/* pass the current exception to the next handler. Use only within an + EM_Catch block. */ +#define EM_RETHROW() \ + SIGNAL_longjmp(EM_ExnHandlerStack[--EM_ExnHandlerStackTop], 1) + +/* Here's an example use of the above macros: + +... +EM_TRY +{ + foo(); + if (foobar) + EM_THROW(EM_FOOBAR); +} +EM_CATCH +{ + un_foo(); /* clean up * + if (EM_CurrentExnType == EM_FOOBAR) + printf("foobar!"); /* stop the error here * + else + EM_RETHROW(); /* let a later handler handle it * +} +*/ + +/**************************************************************************** + * Routines which will generate errors automatically. * + ****************************************************************************/ +void *EM_malloc(unsigned int); +void *EM_realloc(void *, unsigned int); +char *EM_strdup(char *); + +/**************************************************************************** + * Beginning error indices for different modules (by module abbreviation) * + ****************************************************************************/ +/* general errors */ +#define EM_NO_ERROR 0 +#define EM_FIRST_ERR_INDEX 1 +#define LINKER_FIRST_ERR_INDEX 50 +#define LOADER_FIRST_ERR_INDEX 100 +#define STREAM_FIRST_ERR_INDEX 150 +#define SIM_FIRST_ERR_INDEX 200 +#define BI_FIRST_ERR_INDEX 300 +#define RT_FIRST_ERR_INDEX 400 +#define FRONT_FIRST_ERR_INDEX 500 + +/**************************************************************************** + * General-use error messages * + ****************************************************************************/ +enum +{ + EM_OUT_OF_MEMORY = EM_FIRST_ERR_INDEX, + EM_OUT_OF_HEAP, + EM_NEWLINE, + EM_ERROR_COLON, + EM_WARNING_COLON +}; + +/**************************************************************************** + * The routine that gets called in the event of an error * + ****************************************************************************/ +void EM_error(int inIndex, ...); + + +/**************************************************************************** + * Have there been any errors since last EM_Reset()? * + ****************************************************************************/ +extern Boolean EM_anyErrors; +void EM_reset(); + +#endif //ERROR_H diff --git a/src/runtime/c/teyjus/system/memory.h b/src/runtime/c/teyjus/system/memory.h new file mode 100644 index 000000000..b35078ad8 --- /dev/null +++ b/src/runtime/c/teyjus/system/memory.h @@ -0,0 +1,222 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* */ +/* Files memory.h{c}. These files define the system memory structures and */ +/* their access functions, including the system memory, run-time symbol */ +/* tables, implication and import tables and the system module table. */ +/* */ +/****************************************************************************/ + +#ifndef MEMORY_H +#define MEMORY_H + +#include +#include +#include "../simulator/mctypes.h" //to be changed +#include "../simulator/dataformats.h" //to be changed +//#include "../config.h" + +/******************************************************************************/ +/* FIND CODE FUNCTION */ +/******************************************************************************/ +//arguments: constInd, search table size, search table addr +typedef CSpacePtr (*MEM_FindCodeFnPtr)(int, int, MemPtr); + +/******************************************************************************/ +/* SYSTEM MEMORY MANAGEMENT */ +/******************************************************************************/ +extern WordPtr MEM_memBeg; //starting addr of the system memory +extern WordPtr MEM_memEnd; //end addr of the system memory +extern WordPtr MEM_memTop; //the first usable word in the system memory +extern WordPtr MEM_memBot; //the last usable word in the system memory + +/* Asking for the system memory of a given size (in word), */ +/* and initialize relevant global variables. */ +void MEM_memInit(unsigned int size); +/* Asking the simulator (system) memory for space of a given size (in word) */ +WordPtr MEM_memExtend(unsigned int size); + +/******************************************************************************/ +/* MODULE SPACE COMPONENTS */ +/*----------------------------------------------------------------------------*/ +/* I. Run time symbol tables: kind table; type skeleton table; constant table*/ +/* II. Implication table */ +/* III.Import table */ +/******************************************************************************/ + +/*****************************************************************************/ +/* KIND SYMBOL TABLE */ +/*****************************************************************************/ +/* kind symbol table entry */ +typedef struct +{ + DF_StrDataPtr name; + TwoBytes arity; //agree with DF_StrTypeArity (simulator/dataformats.c) +} MEM_KstEnt; + +typedef MEM_KstEnt *MEM_KstPtr; + +/* max possible index of kind table */ +/* (agree with DF_KstTabInd in simulator/dataformats.c) */ +#define MEM_KST_MAX_IND USHRT_MAX + +/* size of each entry of this table (in word) */ +//Note this arithematic should in reality go into "config.h" +#define MEM_KST_ENTRY_SIZE (int)ceil((double)sizeof(MEM_KstEnt)/WORD_SIZE) + +/*****************************************************************************/ +/* TYPE SKELETON TABLE */ +/*****************************************************************************/ +/* type skeleton table entry */ +typedef DF_TypePtr MEM_TstEnt; + +typedef MEM_TstEnt *MEM_TstPtr; + +/* max possible index of type skeleton table */ +#define MEM_TST_MAX_IND USHRT_MAX + +/* size of each entry of this table (in word) */ +//Note this arithematic should in reality go into "config.h" +#define MEM_TST_ENTRY_SIZE (int)ceil((double)sizeof(MEM_TstEnt)/WORD_SIZE) + +/*****************************************************************************/ +/* CONSTANT SYMBOL TABLE */ +/*****************************************************************************/ +/* constant symbol table entry */ +typedef struct +{ + DF_StrDataPtr name; + TwoBytes typeEnvSize; + TwoBytes tskTabIndex; //index to the type skeleton table + TwoBytes neededness; //neededness info + TwoBytes univCount; + int precedence; + int fixity; +} MEM_CstEnt; + +typedef MEM_CstEnt *MEM_CstPtr; + +/* max possible index of constant symbol table */ +/* (agree with DF_CstTabInd in simulator/dataformats.c) */ +#define MEM_CST_MAX_IND USHRT_MAX + //add one entry at the current top +/* size of each entry of this table (in word) */ +//Note this arithematic should in reality go into "config.h" +#define MEM_CST_ENTRY_SIZE (int)(sizeof(MEM_CstEnt)/WORD_SIZE) + +/*****************************************************************************/ +/* ACCESSING THE IMPLICATION GOAL TABLE */ +/*****************************************************************************/ +#define MEM_IMPL_FIX_SIZE 3 +/* functions for filling in the fields of an impl table */ +/* Q: the data stored in each field in byte code: are they word or in their */ +/* specific types? */ +void MEM_implPutLTS(WordPtr tab, int lts); //# pred (def extended) +void MEM_implPutFC(WordPtr tab, MEM_FindCodeFnPtr fcPtr);//ptr to find code func +void MEM_implPutPSTS(WordPtr tab, int tabSize); //# entries link tab +void MEM_implPutLT(WordPtr tab, int ind, int cst); //link tab; ind from 0 + +/* functions for retrieving the addresses of associated tables */ +MemPtr MEM_implLT(MemPtr tab); //start add of seq. of pred (link tab) +MemPtr MEM_implPST(MemPtr tab, int lts); //start add of pred search tab + +/* functions for retrieving the fields of a impl table */ +int MEM_implLTS(MemPtr tab); //pred field (def extended) +MEM_FindCodeFnPtr MEM_implFC(MemPtr tab); //ptr to find code func +int MEM_implPSTS(MemPtr tab); //num entries in link tab +int MEM_implIthLT(MemPtr ltab, int index); /* value in ith entry of link tab + ltab is the addr of link tab; + index should start from 0 */ + +/***************************************************************************** + * ACCESSING THE IMPORTED MODULE TABLE * + *****************************************************************************/ +#define MEM_IMP_FIX_SIZE 5 +/* functions for filling in the fields of an import table */ +/* Q: the data stored in each field in byte code: are they word or in their */ +/* specific types? */ +void MEM_impPutNCSEG(WordPtr tab, int nseg); //# code segments +void MEM_impPutNLC(WordPtr tab, int nlc); //# local constants +void MEM_impPutLTS(WordPtr tab, int lts); //# pred (def extended) +void MEM_impPutFC(WordPtr tab, MEM_FindCodeFnPtr fcp); //ptr to find code func +void MEM_impPutPSTS(WordPtr tab, int tabSize); //# entries in link tab +void MEM_impPutLT(WordPtr tab, int ind, int cst); //link tab; ind from 0 +void MEM_impPutLCT(WordPtr lcTab, int ind, int cst); /*loc c tab(may null) + lcTab addr of local + ctab; ind from 0 */ + +/* functions for retrieving the addresses of associated tables */ +MemPtr MEM_impLT(MemPtr tab); //start addr of seq. of pred (link tab) +MemPtr MEM_impLCT(MemPtr tab, int lts); //start addr of local const table +MemPtr MEM_impPST(MemPtr tab, int lts, int nlc); //start addr of pred search tab + +/* functions for retrieving the fields of a impl table */ +int MEM_impNCSEG(MemPtr tab); //# code segments +int MEM_impNLC(MemPtr tab); //# local constants +int MEM_impLTS(MemPtr tab); //# of preds (def extended) +MEM_FindCodeFnPtr MEM_impFC(MemPtr tab); //ptr to find code func +int MEM_impPSTS(MemPtr tab); //# entries in link tab +int MEM_impIthLT(MemPtr lt, int ind); /* ith entry in the link table: lt addr + of link tab; ind start from 0 */ +int MEM_impIthLCT(MemPtr lct, int ind); /* ith entry in the local const table: + lct local c tab; ind start from 0 */ + + +/*****************************************************************************/ +/* ACCESSING THE BOUND VARIABLE INDEXING TABLE (BRACHING TABLE) */ +/*****************************************************************************/ +int MEM_branchTabIndexVal(MemPtr tab, int index); //the nth index value +CSpacePtr MEM_branchTabCodePtr(MemPtr tab, int index); //transfer addr + +/*****************************************************************************/ +/* SYSTEM MODULE TABLE */ +/*****************************************************************************/ +typedef struct +{ + char *modname; //(top-level) module name + CSpacePtr addtable; //addr to the add code table of the top module + MEM_KstPtr kstBase; //starting addr of kind table + MEM_TstPtr tstBase; //starting addr of type skel table + MEM_CstPtr cstBase; //starting addr of constant table + WordPtr modSpaceBeg; //starting addr of module space + WordPtr modSpaceEnd; //ending addr of module space + WordPtr codeSpaceBeg; //starting addr of module space + WordPtr codeSpaceEnd; //ending addr of module space +} MEM_GmtEnt; + +#define MEM_MAX_MODULES 255 //max number of modules (temp) + +typedef MEM_GmtEnt MEM_Gmt[MEM_MAX_MODULES]; + +extern MEM_Gmt MEM_modTable; //global module table + +MEM_GmtEnt *MEM_findInModTable(char* name); +MEM_GmtEnt *MEM_findFreeModTableEntry(); +void MEM_removeModTableEntry(char* name); + + +extern MEM_GmtEnt MEM_topModule; //top module +void MEM_topModuleInit(); + +extern MEM_GmtEnt *MEM_currentModule; //current module being used + + +#endif //MEMORY_H diff --git a/src/runtime/c/teyjus/system/message.h b/src/runtime/c/teyjus/system/message.h new file mode 100644 index 000000000..cf0fa00fd --- /dev/null +++ b/src/runtime/c/teyjus/system/message.h @@ -0,0 +1,76 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File message.h -- code to present messages to the user in Teyjus. * + * supports dynamically adding "%x"-style formatting switches, as well as * + * complete support for simply making separate builds. * + * * + ****************************************************************************/ + +#ifndef MESSAGE_H +#define MESSAGE_H + +#include +#include "../simulator/mctypes.h" + +/**************************************************************************** + * Type of a function to handle a particular formatting switch. * + ****************************************************************************/ +/* these functions should increment ioArgument as necessary. */ +typedef void (*MSG_SwitchFunction)(char *inSwitch, WordPtr inStream, + va_list *ioArgument); + + +/**************************************************************************** + * Type of a block of messages, with associated constants. * + ****************************************************************************/ +typedef struct MSG_Msg +{ + int mIndex; /* Index of this error message */ + int mPreChain; /* Index of message to print before this one */ + char *mMessage; /* The message itself */ + int mPostChain; /* Index of message to print after this one */ + + int mExnType; /* if MSG_NO_EXN, MSG_Error() will return */ + unsigned int mExitStatus; /* value to return with abort() */ +} MSG_Msg; + +typedef struct MSG_MessageBlock +{ + int mCount; /* No. of messages in this block */ + int mMinIndex, mMaxIndex; /* mMinIndex <= every index <= mMaxIndex */ + struct MSG_MessageBlock *mNext; /* Next block of messages in linked list */ + MSG_Msg *mMessages; /* Array of messages */ +} MSG_MessageBlock; + +/**************************************************************************** + * Initialization functions * + ****************************************************************************/ +void MSG_addSwitch(char inSwitch, MSG_SwitchFunction inFunction); +void MSG_addMessages(int inCount, MSG_Msg *inMessages); + +/**************************************************************************** + * The routine that gets called to print a message, returning the exception * + * type for the error message (mExnType) * + ****************************************************************************/ +int MSG_vMessage(int inIndex, va_list *ap); + +#endif /* MESSAGE_H */ diff --git a/src/runtime/c/teyjus/system/operators.h b/src/runtime/c/teyjus/system/operators.h new file mode 100644 index 000000000..9f016ef5b --- /dev/null +++ b/src/runtime/c/teyjus/system/operators.h @@ -0,0 +1,91 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// +#ifndef OPERATORS_H +#define OPERATORS_H + +//#include + +/* Fixity types */ +typedef enum +{ + OP_INFIX = 0, + OP_INFIXL = 1, + OP_INFIXR = 2, + OP_NONE = 3, + OP_PREFIX = 4, + OP_PREFIXR = 5, + OP_POSTFIX = 6, + OP_POSTFIXL = 7 +} OP_FixityType; + + +typedef enum { + OP_WHOLE_TERM, + OP_LEFT_TERM, + OP_RIGHT_TERM +} OP_TermContext; + +#define OP_MAXPREC 255 +#define OP_MINPREC 0 + +#define OP_LAM_FIXITY OP_PREFIXR +#define OP_LAM_PREC -1 + +#define OP_APP_FIXITY OP_INFIXL +#define OP_APP_PREC 257 + +//usful ? +/* +#define OP_CCOMMA_FIXITY OP_infixr +#define OP_CCOMMA_PREC -2 + + + + + +#define OP_LT_FIXITY OP_infix +#define OP_LT_PREC 130 + +#define OP_LE_FIXITY OP_infix +#define OP_LE_PREC 130 + +#define OP_GT_FIXITY OP_infix +#define OP_GT_PREC 130 + +#define OP_GE_FIXITY OP_infix +#define OP_GE_PREC 130 + +#define OP_UM_FIXITY OP_prefix +#define OP_UM_PREC 256 //? + +#define OP_PLUS_FIXITY OP_infixl +#define OP_PLUS_PREC 150 + +#define OP_MINUS_FIXITY OP_infixl +#define OP_MINUS_PREC 150 + +#define OP_TIMES_FIXITY OP_infixl +#define OP_TIMES_PREC 160 + +#define OP_COMMA_FIXITY OP_infixl +#define OP_COMMA_PREC 110 +*/ + +#endif // OPERATORS_H diff --git a/src/runtime/c/teyjus/system/stream.h b/src/runtime/c/teyjus/system/stream.h new file mode 100644 index 000000000..ec24fb474 --- /dev/null +++ b/src/runtime/c/teyjus/system/stream.h @@ -0,0 +1,90 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * system/stream.h{c} implements stream support for the C part of the LP * + * system. * + ****************************************************************************/ +#ifndef STREAM_H +#define STREAM_H + +#include +#include +#include "../simulator/mctypes.h" //to be modified + +/***************************************************************************** + * CONSTANTS * + *****************************************************************************/ + +#define STREAM_ILLEGAL 0 + +#define STREAM_READ "r" +#define STREAM_WRITE "w" +#define STREAM_APPEND "a" + +/***************************************************************************** + * EXPORTED VARIABLES * + *****************************************************************************/ +/* STREAMs corresponding to the three standard streams */ +extern WordPtr STREAM_stdin, STREAM_stdout, STREAM_stderr; + +/**************************************************************************** + * BASIC FUNCTIONS * + ****************************************************************************/ + +/* STREAM_open returns STREAM_ILLEGAL if the stream can't be opened; + if inDoCountLines is false, the line numbering calls below will not + work. */ +WordPtr STREAM_open(char *inFilename, char *inMode, int inDoUsePaths); +/* open strings as streams. Note that the STREAM system does not + distinguish to_string and from_string streams after they are + opened. Results are undefined for a write to a from_string or read + from a to_string. */ +WordPtr STREAM_fromString(char *inString, int inDoCopyString); +WordPtr STREAM_toString(); + +/* will not close the standard streams */ +void STREAM_close(WordPtr inStream); + + +/*************************************************************************** + * RAW I/O SUPPORT ROUTINES * + * each routine returns -1 to indicate an error * + ***************************************************************************/ +int STREAM_readCharacters(WordPtr inStream, int inMaxCount, char* outString, + int inDoStopOnNewline); +/* STREAM_printf and STREAM_sans_printf return the number of characters + written, -1 in case of error. STREAM_printf takes a format + STREAM_sans_printf interprets the input as a string to be printed */ +int STREAM_printf(WordPtr inStream, char *format, ...); +int STREAM_sans_printf(WordPtr inStream, char *str); +/* STREAM_printf returns the number of characters written, -1 in case of error*/ +int STREAM_lookahead(WordPtr inStream, char *outChar); +Boolean STREAM_eof(WordPtr inStream); +int STREAM_flush(WordPtr inStream); + +/*************************************************************************** + * ACCESSORS * + ***************************************************************************/ +char* STREAM_getString(WordPtr inStream); +FILE* STREAM_getFile(WordPtr inStream); +char* STREAM_getName(WordPtr inStream); + +#endif //STREAM_H diff --git a/src/runtime/c/teyjus/system/tjsignal.h b/src/runtime/c/teyjus/system/tjsignal.h new file mode 100644 index 000000000..77dd04d92 --- /dev/null +++ b/src/runtime/c/teyjus/system/tjsignal.h @@ -0,0 +1,41 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// +/**************************************************************************** + * * + * File signal.h -- code to implement signals and signal handlers for * + * Teyjus. (TEMP) * + * * + ****************************************************************************/ +#ifndef SIGNAL_H +#define SIGNAL_H + +#include + + +/**************************************************************************** + * Different sigsetjmp/siglongjmp depending on support.. * + ****************************************************************************/ + +#define SIGNAL_jmp_buf jmp_buf +#define SIGNAL_setjmp(env) setjmp(env) +#define SIGNAL_longjmp(env, val) longjmp(env, val) + + +#endif /* SIGNAL_H */ diff --git a/src/runtime/c/teyjus/tables/README b/src/runtime/c/teyjus/tables/README new file mode 100644 index 000000000..00c92caa2 --- /dev/null +++ b/src/runtime/c/teyjus/tables/README @@ -0,0 +1,27 @@ + TABLES + ====== +The files in source/tables define the pervasive tables and instruction +format tables. + +pervasives: + + pervasives.h{c} + =============== + Defines the pervasive tables for pervasive kinds, type skeletons + and constants. Note these files are automatically generated. + + pervinit.h{c} + ============= + Defines the initialization functions for pervasive tables: such functions + are necessary because the pervasive names in the system run-time have + special encoding in the simulator (source/simulator/mcstring.h{c}) for + garbage collection as opposed to simply C strings. These names have to + be laid out on the system memory upon system initialization. + + instructions.h{c} + ================= + Defines instruction formats and instruction opcodes. + Note these files are automatically generated. + + + \ No newline at end of file diff --git a/src/runtime/c/teyjus/tables/instructions.c b/src/runtime/c/teyjus/tables/instructions.c new file mode 100644 index 000000000..183eb1875 --- /dev/null +++ b/src/runtime/c/teyjus/tables/instructions.c @@ -0,0 +1,292 @@ +/****************************************************************************/ +/* */ +/* File instructions.c. This file defines the operand types table and */ +/* the instruction information table. */ +/* */ +/****************************************************************************/ + + +#include "instructions.h" + +/****************************************************************************/ +/* OPERAND TYPES TABLE */ +/****************************************************************************/ + +/* Max number of operand that could be taken by instructions including the */ +/* padding bytes and one to terminate the list. (machine dependent) */ +#define INSTR_MAX_OPERAND 8 + +/* this array is indexed by instruction category. For each category, + INSTR_operandTypeTab contains a string of values indicating the type + of the operand at that position, terminated by INSTR_X. This + information is useful when parsing instruction streams. */ +typedef INSTR_OperandType + INSTR_OperandTypeTab[INSTR_NUM_INSTR_CATS][INSTR_MAX_OPERAND]; + +INSTR_OperandTypeTab INSTR_operandTypeTable ={ + //INSTR_CAT_X + {INSTR_P, INSTR_P, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RX + {INSTR_R, INSTR_P, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_EX + {INSTR_E, INSTR_P, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1X + {INSTR_I1, INSTR_P, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_CX + {INSTR_P, INSTR_C, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_KX + {INSTR_P, INSTR_K, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_IX + {INSTR_P, INSTR_P, INSTR_P, INSTR_I, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_FX + {INSTR_P, INSTR_P, INSTR_P, INSTR_F, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_SX + {INSTR_P, INSTR_P, INSTR_P, INSTR_S, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_MTX + {INSTR_P, INSTR_P, INSTR_P, INSTR_MT, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_LX + {INSTR_P, INSTR_P, INSTR_P, INSTR_L, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RRX + {INSTR_R, INSTR_R, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_ERX + {INSTR_E, INSTR_R, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RCX + {INSTR_R, INSTR_C, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RIX + {INSTR_R, INSTR_P, INSTR_P, INSTR_I, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RFX + {INSTR_R, INSTR_P, INSTR_P, INSTR_F, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RSX + {INSTR_R, INSTR_P, INSTR_P, INSTR_S, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RI1X + {INSTR_R, INSTR_I1, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RCEX + {INSTR_R, INSTR_CE, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_ECEX + {INSTR_E, INSTR_CE, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_CLX + {INSTR_P, INSTR_C, INSTR_L, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RKX + {INSTR_R, INSTR_K, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_ECX + {INSTR_E, INSTR_C, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1ITX + {INSTR_I1, INSTR_P, INSTR_P, INSTR_IT, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1LX + {INSTR_I1, INSTR_P, INSTR_P, INSTR_L, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_SEGLX + {INSTR_SEG, INSTR_P, INSTR_P, INSTR_L, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1LWPX + {INSTR_I1, INSTR_P, INSTR_P, INSTR_L, INSTR_WP, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1NX + {INSTR_I1, INSTR_N, INSTR_P, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1HTX + {INSTR_I1, INSTR_P, INSTR_P, INSTR_HT, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1BVTX + {INSTR_I1, INSTR_P, INSTR_P, INSTR_BVT, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_CWPX + {INSTR_P, INSTR_C, INSTR_WP, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1WPX + {INSTR_I1, INSTR_P, INSTR_P, INSTR_WP, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RRI1X + {INSTR_R, INSTR_R, INSTR_I1, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RCLX + {INSTR_R, INSTR_C, INSTR_L, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_RCI1X + {INSTR_R, INSTR_C, INSTR_I1, INSTR_P, INSTR_P, INSTR_P, INSTR_X, INSTR_X}, + //INSTR_CAT_SEGI1LX + {INSTR_SEG, INSTR_I1, INSTR_P, INSTR_L, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1LLX + {INSTR_I1, INSTR_P, INSTR_P, INSTR_L, INSTR_L, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_NLLX + {INSTR_N, INSTR_P, INSTR_P, INSTR_L, INSTR_L, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_LLLLX + {INSTR_P, INSTR_P, INSTR_P, INSTR_L, INSTR_L, INSTR_L, INSTR_L, INSTR_X}, + //INSTR_CAT_I1CWPX + {INSTR_I1, INSTR_C, INSTR_WP, INSTR_X, INSTR_X, INSTR_X, INSTR_X, INSTR_X}, + //INSTR_CAT_I1I1WPX + {INSTR_I1, INSTR_I1, INSTR_P, INSTR_WP, INSTR_X, INSTR_X, INSTR_X, INSTR_X} +}; + +INSTR_OperandType* INSTR_operandTypes(INSTR_InstrCategory index) +{ + return INSTR_operandTypeTable[index]; +} + +/****************************************************************************/ +/* INSTRUCTION INFORMATION TABLE */ +/****************************************************************************/ +typedef struct //entry of the instruction info table +{ + char* name; + INSTR_InstrCategory type; + int size; +} INSTR_InstrInfoTab_; + +typedef INSTR_InstrInfoTab_ INSTR_InstrInfoTab[INSTR_NUM_INSTRS]; + +INSTR_InstrInfoTab INSTR_instrInfoTable ={ + {"put_variable_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"put_variable_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"put_value_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"put_value_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"put_unsafe_value", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"copy_value", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"put_m_const", INSTR_CAT_RCX, INSTR_RCX_LEN}, + {"put_p_const", INSTR_CAT_RCX, INSTR_RCX_LEN}, + {"put_nil", INSTR_CAT_RX, INSTR_RX_LEN}, + {"put_integer", INSTR_CAT_RIX, INSTR_RIX_LEN}, + {"put_float", INSTR_CAT_RFX, INSTR_RFX_LEN}, + {"put_string", INSTR_CAT_RSX, INSTR_RSX_LEN}, + {"put_index", INSTR_CAT_RI1X, INSTR_RI1X_LEN}, + {"put_app", INSTR_CAT_RRI1X, INSTR_RRI1X_LEN}, + {"put_list", INSTR_CAT_RX, INSTR_RX_LEN}, + {"put_lambda", INSTR_CAT_RRI1X, INSTR_RRI1X_LEN}, + {"set_variable_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_variable_te", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_variable_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"set_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"globalize_pt", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"globalize_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_m_const", INSTR_CAT_CX, INSTR_CX_LEN}, + {"set_p_const", INSTR_CAT_CX, INSTR_CX_LEN}, + {"set_nil", INSTR_CAT_X, INSTR_X_LEN}, + {"set_integer", INSTR_CAT_IX, INSTR_IX_LEN}, + {"set_float", INSTR_CAT_FX, INSTR_FX_LEN}, + {"set_string", INSTR_CAT_SX, INSTR_SX_LEN}, + {"set_index", INSTR_CAT_I1X, INSTR_I1X_LEN}, + {"set_void", INSTR_CAT_I1X, INSTR_I1X_LEN}, + {"deref", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_lambda", INSTR_CAT_RI1X, INSTR_RI1X_LEN}, + {"get_variable_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"get_variable_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"init_variable_t", INSTR_CAT_RCEX, INSTR_RCEX_LEN}, + {"init_variable_p", INSTR_CAT_ECEX, INSTR_ECEX_LEN}, + {"get_m_constant", INSTR_CAT_RCX, INSTR_RCX_LEN}, + {"get_p_constant", INSTR_CAT_RCLX, INSTR_RCLX_LEN}, + {"get_integer", INSTR_CAT_RIX, INSTR_RIX_LEN}, + {"get_float", INSTR_CAT_RFX, INSTR_RFX_LEN}, + {"get_string", INSTR_CAT_RSX, INSTR_RSX_LEN}, + {"get_nil", INSTR_CAT_RX, INSTR_RX_LEN}, + {"get_m_structure", INSTR_CAT_RCI1X, INSTR_RCI1X_LEN}, + {"get_p_structure", INSTR_CAT_RCI1X, INSTR_RCI1X_LEN}, + {"get_list", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_variable_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_variable_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_local_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_local_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_m_constant", INSTR_CAT_CX, INSTR_CX_LEN}, + {"unify_p_constant", INSTR_CAT_CLX, INSTR_CLX_LEN}, + {"unify_integer", INSTR_CAT_IX, INSTR_IX_LEN}, + {"unify_float", INSTR_CAT_FX, INSTR_FX_LEN}, + {"unify_string", INSTR_CAT_SX, INSTR_SX_LEN}, + {"unify_nil", INSTR_CAT_X, INSTR_X_LEN}, + {"unify_void", INSTR_CAT_I1X, INSTR_I1X_LEN}, + {"put_type_variable_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"put_type_variable_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"put_type_value_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"put_type_value_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"put_type_unsafe_value", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"put_type_const", INSTR_CAT_RKX, INSTR_RKX_LEN}, + {"put_type_structure", INSTR_CAT_RKX, INSTR_RKX_LEN}, + {"put_type_arrow", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_type_variable_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_type_variable_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"set_type_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_type_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"set_type_local_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"set_type_local_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"set_type_constant", INSTR_CAT_KX, INSTR_KX_LEN}, + {"get_type_variable_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"get_type_variable_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"init_type_variable_t", INSTR_CAT_RCEX, INSTR_RCEX_LEN}, + {"init_type_variable_p", INSTR_CAT_ECEX, INSTR_ECEX_LEN}, + {"get_type_value_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"get_type_value_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"get_type_constant", INSTR_CAT_RKX, INSTR_RKX_LEN}, + {"get_type_structure", INSTR_CAT_RKX, INSTR_RKX_LEN}, + {"get_type_arrow", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_type_variable_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_type_variable_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_type_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_type_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_envty_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_envty_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_type_local_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_type_local_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_envty_local_value_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"unify_envty_local_value_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"unify_type_constant", INSTR_CAT_KX, INSTR_KX_LEN}, + {"pattern_unify_t", INSTR_CAT_RRX, INSTR_RRX_LEN}, + {"pattern_unify_p", INSTR_CAT_ERX, INSTR_ERX_LEN}, + {"finish_unify", INSTR_CAT_X, INSTR_X_LEN}, + {"head_normalize_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"head_normalize_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"incr_universe", INSTR_CAT_X, INSTR_X_LEN}, + {"decr_universe", INSTR_CAT_X, INSTR_X_LEN}, + {"set_univ_tag", INSTR_CAT_ECX, INSTR_ECX_LEN}, + {"tag_exists_t", INSTR_CAT_RX, INSTR_RX_LEN}, + {"tag_exists_p", INSTR_CAT_EX, INSTR_EX_LEN}, + {"tag_variable", INSTR_CAT_EX, INSTR_EX_LEN}, + {"push_impl_point", INSTR_CAT_I1ITX, INSTR_I1ITX_LEN}, + {"pop_impl_point", INSTR_CAT_X, INSTR_X_LEN}, + {"add_imports", INSTR_CAT_SEGI1LX, INSTR_SEGI1LX_LEN}, + {"remove_imports", INSTR_CAT_SEGLX, INSTR_SEGLX_LEN}, + {"push_import", INSTR_CAT_MTX, INSTR_MTX_LEN}, + {"pop_imports", INSTR_CAT_I1X, INSTR_I1X_LEN}, + {"allocate", INSTR_CAT_I1X, INSTR_I1X_LEN}, + {"deallocate", INSTR_CAT_X, INSTR_X_LEN}, + {"call", INSTR_CAT_I1LX, INSTR_I1LX_LEN}, + {"call_name", INSTR_CAT_I1CWPX, INSTR_I1CWPX_LEN}, + {"execute", INSTR_CAT_LX, INSTR_LX_LEN}, + {"execute_name", INSTR_CAT_CWPX, INSTR_CWPX_LEN}, + {"proceed", INSTR_CAT_X, INSTR_X_LEN}, + {"try_me_else", INSTR_CAT_I1LX, INSTR_I1LX_LEN}, + {"retry_me_else", INSTR_CAT_I1LX, INSTR_I1LX_LEN}, + {"trust_me", INSTR_CAT_I1WPX, INSTR_I1WPX_LEN}, + {"try", INSTR_CAT_I1LX, INSTR_I1LX_LEN}, + {"retry", INSTR_CAT_I1LX, INSTR_I1LX_LEN}, + {"trust", INSTR_CAT_I1LWPX, INSTR_I1LWPX_LEN}, + {"trust_ext", INSTR_CAT_I1NX, INSTR_I1NX_LEN}, + {"try_else", INSTR_CAT_I1LLX, INSTR_I1LLX_LEN}, + {"retry_else", INSTR_CAT_I1LLX, INSTR_I1LLX_LEN}, + {"branch", INSTR_CAT_LX, INSTR_LX_LEN}, + {"switch_on_term", INSTR_CAT_LLLLX, INSTR_LLLLX_LEN}, + {"switch_on_constant", INSTR_CAT_I1HTX, INSTR_I1HTX_LEN}, + {"switch_on_bvar", INSTR_CAT_I1BVTX, INSTR_I1BVTX_LEN}, + {"switch_on_reg", INSTR_CAT_NLLX, INSTR_NLLX_LEN}, + {"neck_cut", INSTR_CAT_X, INSTR_X_LEN}, + {"get_level", INSTR_CAT_EX, INSTR_EX_LEN}, + {"put_level", INSTR_CAT_EX, INSTR_EX_LEN}, + {"cut", INSTR_CAT_EX, INSTR_EX_LEN}, + {"call_builtin", INSTR_CAT_I1I1WPX, INSTR_I1I1WPX_LEN}, + {"builtin", INSTR_CAT_I1X, INSTR_I1X_LEN}, + {"stop", INSTR_CAT_X, INSTR_X_LEN}, + {"halt", INSTR_CAT_X, INSTR_X_LEN}, + {"fail", INSTR_CAT_X, INSTR_X_LEN}, + {"create_type_variable", INSTR_CAT_EX, INSTR_EX_LEN}, + {"execute_link_only", INSTR_CAT_CWPX, INSTR_CWPX_LEN}, + {"call_link_only", INSTR_CAT_I1CWPX, INSTR_I1CWPX_LEN}, + {"put_variable_te", INSTR_CAT_RRX, INSTR_RRX_LEN} +}; + +/* Accessing functions */ +INSTR_InstrCategory INSTR_instrType(int index) +{ + return (INSTR_instrInfoTable[index]).type; +} + +char* INSTR_instrName(int index) +{ + return (INSTR_instrInfoTable[index]).name; +} + +int INSTR_instrSize(int index) +{ + return (INSTR_instrInfoTable[index]).size; +} + + diff --git a/src/runtime/c/teyjus/tables/instructions.h b/src/runtime/c/teyjus/tables/instructions.h new file mode 100644 index 000000000..2ced4e85d --- /dev/null +++ b/src/runtime/c/teyjus/tables/instructions.h @@ -0,0 +1,480 @@ +/****************************************************************************/ +/* File instructions.h. */ +/* This file defines instruction operand types, instruction categories and */ +/* instruction opcode. */ +/****************************************************************************/ + +#ifndef INSTRUCTIONS_H +#define INSTRUCTIONS_H + +#include "../simulator/mctypes.h" //to be changed +#include "../simulator/dataformats.h" //to be changed + +/****************************************************************************/ +/* OPERAND TYPES */ +/****************************************************************************/ + +/* possible types of instruction operands */ +typedef enum INSTR_OperandType +{ + // (1 byte) padding + INSTR_P, + // (1 word) padding + INSTR_WP, + // argument register number + INSTR_R, + // environment variable number + INSTR_E, + // next clause number in impt or impl pt + INSTR_N, + // 1 byte natural number + INSTR_I1, + // closure environment variable number + INSTR_CE, + // import segment index + INSTR_SEG, + // constant symbol table index + INSTR_C, + // kind symbol table index + INSTR_K, + // code location + INSTR_L, + // integer immediate value + INSTR_I, + // floating point immediate value + INSTR_F, + // string pointer + INSTR_S, + // module table address + INSTR_MT, + // impl table address + INSTR_IT, + // hash table address + INSTR_HT, + // branch table for bound var indexing + INSTR_BVT, + // operand list terminator + INSTR_X +} INSTR_OperandType; + +/**************************************************************************/ +/* Types for instruction operants */ +/**************************************************************************/ + +typedef Byte INSTR_OpCode; +typedef Byte INSTR_RegInd; +typedef Byte INSTR_EnvInd; +typedef Byte INSTR_NextClauseInd; +typedef Byte INSTR_OneByteInt; +typedef Byte INSTR_ClEnvInd; +typedef Byte INSTR_ImpSegInd; +typedef TwoBytes INSTR_CstIndex; +typedef TwoBytes INSTR_KstIndex; +typedef CSpacePtr INSTR_CodeLabel; +typedef int INSTR_Int; +typedef float INSTR_Float; +typedef DF_StrDataPtr INSTR_Str; +typedef MemPtr INSTR_ModTab; +typedef MemPtr INSTR_ImplTab; +typedef MemPtr INSTR_HashTab; +typedef MemPtr INSTR_BranchTab; + +/***************************************************************************/ +/* INSTRUCTION CATEGORIES */ +/***************************************************************************/ + /* The names of instruction categories no longer include padding bytes. */ +/* Thus we do not need to maintain two sets of names for different machine */ +/* architectures. */ +typedef enum INSTR_InstrCategory +{ + INSTR_CAT_X = 0, + INSTR_CAT_RX = 1, + INSTR_CAT_EX = 2, + INSTR_CAT_I1X = 3, + INSTR_CAT_CX = 4, + INSTR_CAT_KX = 5, + INSTR_CAT_IX = 6, + INSTR_CAT_FX = 7, + INSTR_CAT_SX = 8, + INSTR_CAT_MTX = 9, + INSTR_CAT_LX = 10, + INSTR_CAT_RRX = 11, + INSTR_CAT_ERX = 12, + INSTR_CAT_RCX = 13, + INSTR_CAT_RIX = 14, + INSTR_CAT_RFX = 15, + INSTR_CAT_RSX = 16, + INSTR_CAT_RI1X = 17, + INSTR_CAT_RCEX = 18, + INSTR_CAT_ECEX = 19, + INSTR_CAT_CLX = 20, + INSTR_CAT_RKX = 21, + INSTR_CAT_ECX = 22, + INSTR_CAT_I1ITX = 23, + INSTR_CAT_I1LX = 24, + INSTR_CAT_SEGLX = 25, + INSTR_CAT_I1LWPX = 26, + INSTR_CAT_I1NX = 27, + INSTR_CAT_I1HTX = 28, + INSTR_CAT_I1BVTX = 29, + INSTR_CAT_CWPX = 30, + INSTR_CAT_I1WPX = 31, + INSTR_CAT_RRI1X = 32, + INSTR_CAT_RCLX = 33, + INSTR_CAT_RCI1X = 34, + INSTR_CAT_SEGI1LX = 35, + INSTR_CAT_I1LLX = 36, + INSTR_CAT_NLLX = 37, + INSTR_CAT_LLLLX = 38, + INSTR_CAT_I1CWPX = 39, + INSTR_CAT_I1I1WPX = 40 +} INSTR_InstrCategory; + +#define INSTR_NUM_INSTR_CATS 41 + +#define INSTR_CALL_I1_LEN 7 + +/**************************************************************************/ +/* Macros defines instruction lengths and distances between op code and */ +/* operands. */ +/* The assumption is that the op code occupies 1 byte. */ +/**************************************************************************/ + +//INSTR_CAT_X +#define INSTR_X_LEN 4 +//INSTR_CAT_RX +#define INSTR_RX_LEN 4 +#define INSTR_RX_R 1 +//INSTR_CAT_EX +#define INSTR_EX_LEN 4 +#define INSTR_EX_E 1 +//INSTR_CAT_I1X +#define INSTR_I1X_LEN 4 +#define INSTR_I1X_I1 1 +//INSTR_CAT_CX +#define INSTR_CX_LEN 4 +#define INSTR_CX_C 2 +//INSTR_CAT_KX +#define INSTR_KX_LEN 4 +#define INSTR_KX_K 2 +//INSTR_CAT_IX +#define INSTR_IX_LEN 8 +#define INSTR_IX_I 4 +//INSTR_CAT_FX +#define INSTR_FX_LEN 8 +#define INSTR_FX_F 4 +//INSTR_CAT_SX +#define INSTR_SX_LEN 8 +#define INSTR_SX_S 4 +//INSTR_CAT_MTX +#define INSTR_MTX_LEN 8 +#define INSTR_MTX_MT 4 +//INSTR_CAT_LX +#define INSTR_LX_LEN 8 +#define INSTR_LX_L 4 +//INSTR_CAT_RRX +#define INSTR_RRX_LEN 4 +#define INSTR_RRX_R1 1 +#define INSTR_RRX_R2 2 +//INSTR_CAT_ERX +#define INSTR_ERX_LEN 4 +#define INSTR_ERX_E 1 +#define INSTR_ERX_R 2 +//INSTR_CAT_RCX +#define INSTR_RCX_LEN 4 +#define INSTR_RCX_R 1 +#define INSTR_RCX_C 2 +//INSTR_CAT_RIX +#define INSTR_RIX_LEN 8 +#define INSTR_RIX_R 1 +#define INSTR_RIX_I 4 +//INSTR_CAT_RFX +#define INSTR_RFX_LEN 8 +#define INSTR_RFX_R 1 +#define INSTR_RFX_F 4 +//INSTR_CAT_RSX +#define INSTR_RSX_LEN 8 +#define INSTR_RSX_R 1 +#define INSTR_RSX_S 4 +//INSTR_CAT_RI1X +#define INSTR_RI1X_LEN 4 +#define INSTR_RI1X_R 1 +#define INSTR_RI1X_I1 2 +//INSTR_CAT_RCEX +#define INSTR_RCEX_LEN 4 +#define INSTR_RCEX_R 1 +#define INSTR_RCEX_CE 2 +//INSTR_CAT_ECEX +#define INSTR_ECEX_LEN 4 +#define INSTR_ECEX_E 1 +#define INSTR_ECEX_CE 2 +//INSTR_CAT_CLX +#define INSTR_CLX_LEN 8 +#define INSTR_CLX_C 2 +#define INSTR_CLX_L 4 +//INSTR_CAT_RKX +#define INSTR_RKX_LEN 4 +#define INSTR_RKX_R 1 +#define INSTR_RKX_K 2 +//INSTR_CAT_ECX +#define INSTR_ECX_LEN 4 +#define INSTR_ECX_E 1 +#define INSTR_ECX_C 2 +//INSTR_CAT_I1ITX +#define INSTR_I1ITX_LEN 8 +#define INSTR_I1ITX_I1 1 +#define INSTR_I1ITX_IT 4 +//INSTR_CAT_I1LX +#define INSTR_I1LX_LEN 8 +#define INSTR_I1LX_I1 1 +#define INSTR_I1LX_L 4 +//INSTR_CAT_SEGLX +#define INSTR_SEGLX_LEN 8 +#define INSTR_SEGLX_SEG 1 +#define INSTR_SEGLX_L 4 +//INSTR_CAT_I1LWPX +#define INSTR_I1LWPX_LEN 12 +#define INSTR_I1LWPX_I1 1 +#define INSTR_I1LWPX_L 4 +//INSTR_CAT_I1NX +#define INSTR_I1NX_LEN 4 +#define INSTR_I1NX_I1 1 +#define INSTR_I1NX_N 2 +//INSTR_CAT_I1HTX +#define INSTR_I1HTX_LEN 8 +#define INSTR_I1HTX_I1 1 +#define INSTR_I1HTX_HT 4 +//INSTR_CAT_I1BVTX +#define INSTR_I1BVTX_LEN 8 +#define INSTR_I1BVTX_I1 1 +#define INSTR_I1BVTX_BVT 4 +//INSTR_CAT_CWPX +#define INSTR_CWPX_LEN 8 +#define INSTR_CWPX_C 2 +//INSTR_CAT_I1WPX +#define INSTR_I1WPX_LEN 8 +#define INSTR_I1WPX_I1 1 +//INSTR_CAT_RRI1X +#define INSTR_RRI1X_LEN 4 +#define INSTR_RRI1X_R1 1 +#define INSTR_RRI1X_R2 2 +#define INSTR_RRI1X_I1 3 +//INSTR_CAT_RCLX +#define INSTR_RCLX_LEN 8 +#define INSTR_RCLX_R 1 +#define INSTR_RCLX_C 2 +#define INSTR_RCLX_L 4 +//INSTR_CAT_RCI1X +#define INSTR_RCI1X_LEN 8 +#define INSTR_RCI1X_R 1 +#define INSTR_RCI1X_C 2 +#define INSTR_RCI1X_I1 4 +//INSTR_CAT_SEGI1LX +#define INSTR_SEGI1LX_LEN 8 +#define INSTR_SEGI1LX_SEG 1 +#define INSTR_SEGI1LX_I1 2 +#define INSTR_SEGI1LX_L 4 +//INSTR_CAT_I1LLX +#define INSTR_I1LLX_LEN 12 +#define INSTR_I1LLX_I1 1 +#define INSTR_I1LLX_L1 4 +#define INSTR_I1LLX_L2 8 +//INSTR_CAT_NLLX +#define INSTR_NLLX_LEN 12 +#define INSTR_NLLX_N 1 +#define INSTR_NLLX_L1 4 +#define INSTR_NLLX_L2 8 +//INSTR_CAT_LLLLX +#define INSTR_LLLLX_LEN 20 +#define INSTR_LLLLX_L1 4 +#define INSTR_LLLLX_L2 8 +#define INSTR_LLLLX_L3 12 +#define INSTR_LLLLX_L4 16 +//INSTR_CAT_I1CWPX +#define INSTR_I1CWPX_LEN 8 +#define INSTR_I1CWPX_I1 1 +#define INSTR_I1CWPX_C 2 +//INSTR_CAT_I1I1WPX +#define INSTR_I1I1WPX_LEN 8 +#define INSTR_I1I1WPX_I11 1 +#define INSTR_I1I1WPX_I12 2 + +/****************************************************************************/ +/* OPERAND TYPES TABLE */ +/****************************************************************************/ + +//the operand types array in a given entry +INSTR_OperandType* INSTR_operandTypes(INSTR_InstrCategory index); + +/***************************************************************************/ +/* OPCODES OF INSTRUCTIONS */ +/***************************************************************************/ +// Instructions for term unification and creation +#define put_variable_t 0 +#define put_variable_p 1 +#define put_value_t 2 +#define put_value_p 3 +#define put_unsafe_value 4 +#define copy_value 5 +#define put_m_const 6 +#define put_p_const 7 +#define put_nil 8 +#define put_integer 9 +#define put_float 10 +#define put_string 11 +#define put_index 12 +#define put_app 13 +#define put_list 14 +#define put_lambda 15 +#define set_variable_t 16 +#define set_variable_te 17 +#define set_variable_p 18 +#define set_value_t 19 +#define set_value_p 20 +#define globalize_pt 21 +#define globalize_t 22 +#define set_m_const 23 +#define set_p_const 24 +#define set_nil 25 +#define set_integer 26 +#define set_float 27 +#define set_string 28 +#define set_index 29 +#define set_void 30 +#define deref 31 +#define set_lambda 32 +#define get_variable_t 33 +#define get_variable_p 34 +#define init_variable_t 35 +#define init_variable_p 36 +#define get_m_constant 37 +#define get_p_constant 38 +#define get_integer 39 +#define get_float 40 +#define get_string 41 +#define get_nil 42 +#define get_m_structure 43 +#define get_p_structure 44 +#define get_list 45 +#define unify_variable_t 46 +#define unify_variable_p 47 +#define unify_value_t 48 +#define unify_value_p 49 +#define unify_local_value_t 50 +#define unify_local_value_p 51 +#define unify_m_constant 52 +#define unify_p_constant 53 +#define unify_integer 54 +#define unify_float 55 +#define unify_string 56 +#define unify_nil 57 +#define unify_void 58 +// Instructions for type unification and creation +#define put_type_variable_t 59 +#define put_type_variable_p 60 +#define put_type_value_t 61 +#define put_type_value_p 62 +#define put_type_unsafe_value 63 +#define put_type_const 64 +#define put_type_structure 65 +#define put_type_arrow 66 +#define set_type_variable_t 67 +#define set_type_variable_p 68 +#define set_type_value_t 69 +#define set_type_value_p 70 +#define set_type_local_value_t 71 +#define set_type_local_value_p 72 +#define set_type_constant 73 +#define get_type_variable_t 74 +#define get_type_variable_p 75 +#define init_type_variable_t 76 +#define init_type_variable_p 77 +#define get_type_value_t 78 +#define get_type_value_p 79 +#define get_type_constant 80 +#define get_type_structure 81 +#define get_type_arrow 82 +#define unify_type_variable_t 83 +#define unify_type_variable_p 84 +#define unify_type_value_t 85 +#define unify_type_value_p 86 +#define unify_envty_value_t 87 +#define unify_envty_value_p 88 +#define unify_type_local_value_t 89 +#define unify_type_local_value_p 90 +#define unify_envty_local_value_t 91 +#define unify_envty_local_value_p 92 +#define unify_type_constant 93 +// Instructions for handling higher-order aspects +#define pattern_unify_t 94 +#define pattern_unify_p 95 +#define finish_unify 96 +#define head_normalize_t 97 +#define head_normalize_p 98 +// Instructions for handling logical aspects +#define incr_universe 99 +#define decr_universe 100 +#define set_univ_tag 101 +#define tag_exists_t 102 +#define tag_exists_p 103 +#define tag_variable 104 +#define push_impl_point 105 +#define pop_impl_point 106 +#define add_imports 107 +#define remove_imports 108 +#define push_import 109 +#define pop_imports 110 +// Control Instructions +#define allocate 111 +#define deallocate 112 +#define call 113 +#define call_name 114 +#define execute 115 +#define execute_name 116 +#define proceed 117 +// Choice Instructions +#define try_me_else 118 +#define retry_me_else 119 +#define trust_me 120 +#define try 121 +#define retry 122 +#define trust 123 +#define trust_ext 124 +#define try_else 125 +#define retry_else 126 +#define branch 127 +// Indexing Instructions +#define switch_on_term 128 +#define switch_on_constant 129 +#define switch_on_bvar 130 +#define switch_on_reg 131 +// Cut Instructions +#define neck_cut 132 +#define get_level 133 +#define put_level 134 +#define cut 135 +// Miscellaneous Instructions +#define call_builtin 136 +#define builtin 137 +#define stop 138 +#define halt 139 +#define fail 140 +// new added +#define create_type_variable 141 +// resolved by the linker +#define execute_link_only 142 +#define call_link_only 143 +#define put_variable_te 144 + + +#define INSTR_NUM_INSTRS 145 + +/***************************************************************************/ +/* INSTRUCTION INFORMATION TABLE */ +/***************************************************************************/ +INSTR_InstrCategory INSTR_instrType(int index); //instr type in a given entry +char* INSTR_instrName(int index); //instr name in a given entry +int INSTR_instrSize(int index); //instr size in a given entry + +#endif //INSTRUCTIONS_H + diff --git a/src/runtime/c/teyjus/tables/pervasives.c b/src/runtime/c/teyjus/tables/pervasives.c new file mode 100644 index 000000000..4c2b3ad4c --- /dev/null +++ b/src/runtime/c/teyjus/tables/pervasives.c @@ -0,0 +1,810 @@ +/***************************************************************************/ +/* File pervasives.c. */ +/***************************************************************************/ + +#ifndef PERVASIVES_C +#define PERVASIVES_C + +#include +#include "pervasives.h" +#include "../system/error.h" //to be changed +#include "../system/operators.h" //to be changed + + +/****************************************************************************/ +/* PERVASIVE KIND */ +/****************************************************************************/ +//pervasive kind data table (array) +PERV_KindData PERV_kindDataTab[PERV_KIND_NUM] = { + //name, arity + // int + {"int", 0}, + // real + {"real", 0}, + // bool + {"o", 0}, + // string + {"string", 0}, + // list type constructor + {"list", 1}, + // in_stream + {"in_stream", 0}, + // out_stream + {"out_stream", 0} +}; + +PERV_KindData PERV_getKindData(int index) +{ + return PERV_kindDataTab[index]; +} + +void PERV_copyKindDataTab(PERV_KindData* dst) +{ + //this way of copy relies on the assumption that the pervasive kind data + //has the same structure as that of the run-time kind symbol table entries. + memcpy((void*)dst, (void*)PERV_kindDataTab, + sizeof(PERV_KindData) * PERV_KIND_NUM); +} + + +/***************************************************************************/ +/* TYPE SKELETIONS FOR PERVASIVE CONSTANTS */ +/****************************************************************************/ + +//pervasive type skeleton table (array) +PERV_TySkelData PERV_tySkelTab[PERV_TY_SKEL_NUM]; + +//pervasive type skeletons and type skeleton table initialization +//The type skeletons are created in the memory of the system through malloc, +//and addresses are entered into the pervasive type skeleton table. +void PERV_tySkelTabInit() +{ + int tySkelInd = 0; //ts tab index + MemPtr tySkelBase = (MemPtr)EM_malloc(WORD_SIZE * 336 ); //ts area + + // A + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // (list A) + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkStrType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkStrFuncType(tySkelBase, PERV_LIST_INDEX, 1); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // A->(list A)->(list A) + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkStrType(tySkelBase, (DF_TypePtr)(tySkelBase + 2 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkStrType(tySkelBase, (DF_TypePtr)(tySkelBase + 3 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkStrFuncType(tySkelBase, PERV_LIST_INDEX, 1); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkStrFuncType(tySkelBase, PERV_LIST_INDEX, 1); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // int + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // real + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // o (type of proposition) + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // int -> int + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // int -> int -> int + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // int -> int -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // int -> real + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // real -> int + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // real -> real + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // real -> string + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // real -> real -> real + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // real -> real -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_REAL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> int + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // int -> string + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> string -> string + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> string -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> int -> int -> string + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // o -> o -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // (A -> o) -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 2 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // A -> A -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // in_stream + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkSortType(tySkelBase, PERV_INSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // out_stream + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkSortType(tySkelBase, PERV_OUTSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> in_stream -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> out_stream -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_OUTSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // in_stream -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // out_stream -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_OUTSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // A -> string -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> A -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // out_stream -> string -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_OUTSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // in_stream -> int -> string -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // in_stream -> string -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // A -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // out_stream -> A -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_OUTSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // in_stream -> A -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSkelVarType(tySkelBase, 0); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // o -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> int -> in_stream -> out_stream -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_OUTSTREAM_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + + // string -> int -> o + PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase; + tySkelInd++; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_STRING_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + 1 * DF_TY_ATOMIC_SIZE)); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_INT_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + DF_mkSortType(tySkelBase, PERV_BOOL_INDEX); + tySkelBase += DF_TY_ATOMIC_SIZE; + +} + +void PERV_copyTySkelTab(PERV_TySkelData* dst) +{ + memcpy((void*)dst, (void*)PERV_tySkelTab, + sizeof(PERV_TySkelData) * PERV_KIND_NUM); +} + + +/***************************************************************************/ +/* PERVASIVE CONSTANTS */ +/***************************************************************************/ + +//pervasive constant data table (array) +PERV_ConstData PERV_constDataTab[PERV_CONST_NUM] = { + //name, tesize, tst, neededness, UC, prec, fixity + // logical and + {",", 0, 21, 0, 0, 110, OP_INFIXL}, + // logical or + {";", 0, 21, 0, 0, 100, OP_INFIXL}, + // existential quantifier + {"sigma", 1, 22, 1, 0, 0, OP_NONE}, + // universal quantifier + {"pi", 1, 22, 1, 0, 0, OP_NONE}, + // true proposition + {"true", 0, 6, 0, 0, 0, OP_NONE}, + // cut predicate + {"!", 0, 6, 0, 0, 0, OP_NONE}, + // fail predicate + {"fail", 0, 6, 0, 0, 0, OP_NONE}, + //nothing + {NULL, 0, 0, 0, 0, OP_NONE }, + // another logical and + {"&", 0, 21, 0, 0, 120, OP_INFIXR}, + // halt the system + {"halt", 0, 6, 0, 0, 0, OP_NONE}, + // return to top level + {"stop", 0, 6, 0, 0, 0, OP_NONE}, + // Prolog if; needed? + {":-", 0, 21, 0, 0, 0, OP_INFIXL}, + // implication; needed? + {"=>", 0, 21, 0, 0, 130, OP_INFIXR}, + //nothing + {NULL, 0, 0, 0, 0, OP_NONE }, + //nothing + {NULL, 0, 0, 0, 0, OP_NONE }, + // solve; used by code generator + {"solve", 0, 39, 0, 0, 0, OP_NONE}, + // is + {"is", 1, 23, 1, 0, 130, OP_INFIX}, + // not + {"not", 0, 39, 0, 0, 0, OP_NONE}, + // equality (unify) predicate + {"=", 1, 23, 1, 0, 130, OP_INFIX}, + // less than on integers + {"<", 0, 9, 0, 0, 130, OP_INFIX}, + // greater than on integers + {">", 0, 9, 0, 0, 130, OP_INFIX}, + // less than or eq on integers + {"<=", 0, 9, 0, 0, 130, OP_INFIX}, + // greater than or eq on integers + {">=", 0, 9, 0, 0, 130, OP_INFIX}, + // less than in reals + {"<", 0, 15, 0, 0, 130, OP_INFIX}, + // greater than on reals + {">", 0, 15, 0, 0, 130, OP_INFIX}, + // less than or eq on reals + {"<=", 0, 15, 0, 0, 130, OP_INFIX}, + // greater than or eq on reals + {">=", 0, 15, 0, 0, 130, OP_INFIX}, + // less than on strings + {"<", 0, 19, 0, 0, 130, OP_INFIX}, + // greater than on strings + {">", 0, 19, 0, 0, 130, OP_INFIX}, + // less than or eq on strings + {"<=", 0, 19, 0, 0, 130, OP_INFIX}, + // greater than or eq on strings + {">=", 0, 19, 0, 0, 130, OP_INFIX}, + // open_in + {"open_in", 0, 26, 0, 0, 0, OP_NONE}, + // open_out + {"open_out", 0, 27, 0, 0, 0, OP_NONE}, + // open_append + {"open_append", 0, 27, 0, 0, 0, OP_NONE}, + // close_in + {"close_in", 0, 28, 0, 0, 0, OP_NONE}, + // close_out + {"close_out", 0, 29, 0, 0, 0, OP_NONE}, + // open_string + {"open_string", 0, 26, 0, 0, 0, OP_NONE}, + // input + {"input", 0, 33, 0, 0, 0, OP_NONE}, + // output + {"output", 0, 32, 0, 0, 0, OP_NONE}, + // input_line + {"input_line", 0, 34, 0, 0, 0, OP_NONE}, + // lookahead + {"lookahead", 0, 34, 0, 0, 0, OP_NONE}, + // eof + {"eof", 0, 28, 0, 0, 0, OP_NONE}, + // flush + {"flush", 0, 29, 0, 0, 0, OP_NONE}, + // print + {"print", 0, 35, 0, 0, 0, OP_NONE}, + // read + {"read", 1, 36, 1, 0, 0, OP_NONE}, + // printterm + {"printterm", 1, 37, 0, 0, 0, OP_NONE}, + // term_to_string + {"term_to_string", 1, 30, 0, 0, 0, OP_NONE}, + // string_to_term + {"string_to_term", 1, 31, 1, 0, 0, OP_NONE}, + // readterm + {"readterm", 1, 38, 1, 0, 0, OP_NONE}, + // getenv predicate; needed? + {"getenv", 0, 19, 0, 0, 0, OP_NONE}, + // open_socket predicate + {"open_socket", 0, 40, 0, 0, 0, OP_NONE}, + // time predicate + {"time", 0, 9, 0, 0, 0, OP_NONE}, + // system predicate + {"system", 0, 41, 0, 0, 0, OP_NONE}, + //nothing + {NULL, 0, 0, 0, 0, OP_NONE }, + //nothing + {NULL, 0, 0, 0, 0, OP_NONE }, + //nothing + {NULL, 0, 0, 0, 0, OP_NONE }, + // unary minus on integers + {"-", 0, 7, 0, 0, 256, OP_PREFIX}, + // addition on integers + {"+", 0, 8, 0, 0, 150, OP_INFIXL}, + // subtraction on integers + {"-", 0, 8, 0, 0, 150, OP_INFIXL}, + // mutiplication on integers + {"*", 0, 8, 0, 0, 160, OP_INFIXL}, + // integer division + {"div", 0, 8, 0, 0, 160, OP_INFIXL}, + // modulus + {"mod", 0, 7, 0, 0, 160, OP_INFIXL}, + // coercion to real + {"int_to_real", 0, 10, 0, 0, 0, OP_NONE}, + // integer abs + {"abs", 0, 7, 0, 0, 0, OP_NONE}, + // unary minus on real + {"-", 0, 12, 0, 0, 256, OP_PREFIX}, + // addition on reals + {"+", 0, 14, 0, 0, 150, OP_INFIXL}, + // subtraction on reals + {"-", 0, 14, 0, 0, 150, OP_INFIXL}, + // multiplication on reals + {"*", 0, 14, 0, 0, 160, OP_INFIXL}, + // division + {"/", 0, 14, 0, 0, 160, OP_INFIXL}, + // square root + {"sqrt", 0, 12, 0, 0, 0, OP_NONE}, + // sine + {"sin", 0, 12, 0, 0, 0, OP_NONE}, + // cosine + {"cos", 0, 12, 0, 0, 0, OP_NONE}, + // arc tan + {"arctan", 0, 12, 0, 0, 0, OP_NONE}, + // natural log + {"ln", 0, 12, 0, 0, 0, OP_NONE}, + // floor function + {"floor", 0, 11, 0, 0, 0, OP_NONE}, + // ceiling function + {"ceil", 0, 11, 0, 0, 0, OP_NONE}, + // truncation + {"truncate", 0, 11, 0, 0, 0, OP_NONE}, + // real abs + {"rabs", 0, 12, 0, 0, 0, OP_NONE}, + // string concatination + {"^", 0, 18, 0, 0, 150, OP_INFIXL}, + // string length + {"size", 0, 16, 0, 0, 0, OP_NONE}, + // chr function + {"chr", 0, 17, 0, 0, 0, OP_NONE}, + // ord function + {"string_to_int", 0, 16, 0, 0, 0, OP_NONE}, + // substring + {"substring", 0, 20, 0, 0, 0, OP_NONE}, + // int to string + {"int_to_string", 0, 17, 0, 0, 0, OP_NONE}, + // real to string + {"real_to_string", 0, 13, 0, 0, 0, OP_NONE}, + // for unnamed universal constants (Note: tesize should be 0) + {"", 0, 0, 0, 0, 0, OP_NONE}, + // std_in + {"std_in", 0, 24, 0, 0, 0, OP_NONE}, + // std_out + {"std_out", 0, 25, 0, 0, 0, OP_NONE}, + // std_err + {"std_err", 0, 25, 0, 0, 0, OP_NONE}, + // nil + {"nil", 0, 1, 0, 0, 0, OP_NONE}, + // integer constant + {"", 0, 3, 0, 0, 0, OP_NONE}, + // real constant + {"", 0, 4, 0, 0, 0, OP_NONE}, + // string constant + {"", 0, 5, 0, 0, 0, OP_NONE}, + // cons + {"::", 0, 2, 0, 0, 140, OP_INFIXR} +}; + +PERV_ConstData PERV_getConstData(int index) +{ + return PERV_constDataTab[index]; +} + +void PERV_copyConstDataTab(PERV_ConstData* dst) +{ + //this way of copy relies on the assumption that the pervasive kind data + //has the same structure as that of the run-time kind symbol table entries. + memcpy((void*)dst, (void*)PERV_constDataTab, + sizeof(PERV_ConstData) * PERV_CONST_NUM); +} + +Boolean PERV_isLogicSymb(int index) +{ + return ((index >= PERV_LSSTART) && (index <= PERV_LSEND)); +} + +Boolean PERV_isPredSymb(int index) +{ + return ((index >= PERV_PREDSTART) && (index <= PERV_PREDEND)); +} + +PERV_LogicSymbTypes PERV_logicSymb(int index) +{ + return ((PERV_LogicSymbTypes)(index - PERV_LSSTART)); +} + +int PERV_predBuiltin(int index) +{ + return (index - PERV_PREDSTART); +} + + +#endif //PERVASIVES_C + diff --git a/src/runtime/c/teyjus/tables/pervasives.h b/src/runtime/c/teyjus/tables/pervasives.h new file mode 100644 index 000000000..48a96964c --- /dev/null +++ b/src/runtime/c/teyjus/tables/pervasives.h @@ -0,0 +1,326 @@ +/****************************************************************************/ +/* File pervasives.h. */ +/****************************************************************************/ + +#ifndef PERVASIVES_H +#define PERVASIVES_H + +#include "../simulator/mctypes.h" //to be changed +#include "../simulator/dataformats.h" //to be changed + + +/****************************************************************************/ +/* PERVASIVE KIND */ +/****************************************************************************/ +//indices for predefined sorts and type constructors +typedef enum PERV_KindIndexType +{ + // int + PERV_INT_INDEX = 0, + // real + PERV_REAL_INDEX = 1, + // bool + PERV_BOOL_INDEX = 2, + // string + PERV_STRING_INDEX = 3, + // list type constructor + PERV_LIST_INDEX = 4, + // in_stream + PERV_INSTREAM_INDEX = 5, + // out_stream + PERV_OUTSTREAM_INDEX = 6 +} PERV_KindIndexType; + +//total number of pervasive kinds +#define PERV_KIND_NUM 7 + +//pervasive kind data type +typedef struct +{ + char *name; + TwoBytes arity; +} PERV_KindData; + +//pervasive kind data table (array) +extern PERV_KindData PERV_kindDataTab[PERV_KIND_NUM]; + +//pervasive kind data access function +PERV_KindData PERV_getKindData(int index); + +//pervasive kind table copy function (used in module space initialization) +//this functiion relies on the assumption that the pervasive kind data +//has the same structure as that of the run-time kind symbol table entries. +void PERV_copyKindDataTab(PERV_KindData* dst); + + +/***************************************************************************/ +/* TYPE SKELETIONS FOR PERVASIVE CONSTANTS */ +/****************************************************************************/ + +//total number of type skeletons needed for pervasive constants +#define PERV_TY_SKEL_NUM 42 + +//pervasive type skel data type +typedef DF_TypePtr PERV_TySkelData; + +//pervasive type skel table (array) +extern PERV_TySkelData PERV_tySkelTab[PERV_TY_SKEL_NUM]; + +//pervasive type skeletons and type skeleton table initialization +//Note that type skeltons have to be dynamically allocated, and so does the +//info recorded in each entry of the pervasive type skeleton table +void PERV_tySkelTabInit(); + +//pervasive tyskel table copy function +void PERV_copyTySkelTab(PERV_TySkelData* dst); + + +/***************************************************************************/ +/* PERVASIVE CONSTANTS */ +/***************************************************************************/ + +//indices for predefined constants +typedef enum PERV_ConstIndexType +{ + // logical and + PERV_AND_INDEX = 0, + // logical or + PERV_OR_INDEX = 1, + // existential quantifier + PERV_SOME_INDEX = 2, + // universal quantifier + PERV_ALL_INDEX = 3, + // true proposition + PERV_TRUE_INDEX = 4, + // cut predicate + PERV_CUT_INDEX = 5, + // fail predicate + PERV_FAIL_INDEX = 6, + // empty + // another logical and + PERV_AMPAND_INDEX = 8, + // halt the system + PERV_HALT_INDEX = 9, + // return to top level + PERV_STOP_INDEX = 10, + // Prolog if; needed? + PERV_COLONDASH_INDEX = 11, + // implication; needed? + PERV_IMPL_INDEX = 12, + // empty + // empty + // solve; used by code generator + PERV_SOLVE_INDEX = 15, + // is + PERV_IS_INDEX = 16, + // not + PERV_NOT_INDEX = 17, + // equality (unify) predicate + PERV_EQ_INDEX = 18, + // less than on integers + PERV_INTLSS_INDEX = 19, + // greater than on integers + PERV_INTGRT_INDEX = 20, + // less than or eq on integers + PERV_INTLEQ_INDEX = 21, + // greater than or eq on integers + PERV_INTGEQ_INDEX = 22, + // less than in reals + PERV_REALLSS_INDEX = 23, + // greater than on reals + PERV_REALGRT_INDEX = 24, + // less than or eq on reals + PERV_REALLEQ_INDEX = 25, + // greater than or eq on reals + PERV_REALGEQ_INDEX = 26, + // less than on strings + PERV_STRLSS_INDEX = 27, + // greater than on strings + PERV_STRGRT_INDEX = 28, + // less than or eq on strings + PERV_STRLEQ_INDEX = 29, + // greater than or eq on strings + PERV_STRGEQ_INDEX = 30, + // open_in + PERV_OPENIN_INDEX = 31, + // open_out + PERV_OPENOUT_INDEX = 32, + // open_append + PERV_OPENAPP_INDEX = 33, + // close_in + PERV_CLOSEIN_INDEX = 34, + // close_out + PERV_CLOSEOUT_INDEX = 35, + // open_string + PERV_OPENSTR_INDEX = 36, + // input + PERV_INPUT_INDEX = 37, + // output + PERV_OUTPUT_INDEX = 38, + // input_line + PERV_INPUTLINE_INDEX = 39, + // lookahead + PERV_LOOKAHEAD_INDEX = 40, + // eof + PERV_EOF_INDEX = 41, + // flush + PERV_FLUSH_INDEX = 42, + // print + PERV_PRINT_INDEX = 43, + // read + PERV_READ_INDEX = 44, + // printterm + PERV_PRINTTERM_INDEX = 45, + // term_to_string + PERV_TERMTOSTR_INDEX = 46, + // string_to_term + PERV_STRTOTERM_INDEX = 47, + // readterm + PERV_READTERM_INDEX = 48, + // getenv predicate; needed? + PERV_GETENV_INDEX = 49, + // open_socket predicate + PERV_OPENSOCKET_INDEX = 50, + // time predicate + PERV_TIME_INDEX = 51, + // system predicate + PERV_SYSTEM_INDEX = 52, + // empty + // empty + // empty + // unary minus on integers + PERV_INTUMINUS_INDEX = 56, + // addition on integers + PERV_INTPLUS_INDEX = 57, + // subtraction on integers + PERV_INTMINUS_INDEX = 58, + // mutiplication on integers + PERV_INTMULT_INDEX = 59, + // integer division + PERV_INTDIV_INDEX = 60, + // modulus + PERV_MOD_INDEX = 61, + // coercion to real + PERV_ITOR_INDEX = 62, + // integer abs + PERV_IABS_INDEX = 63, + // unary minus on real + PERV_REALUMINUS_INDEX = 64, + // addition on reals + PERV_REALPLUS_INDEX = 65, + // subtraction on reals + PERV_REALMINUS_INDEX = 66, + // multiplication on reals + PERV_REALMULT_INDEX = 67, + // division + PERV_REALDIV_INDEX = 68, + // square root + PERV_SQRT_INDEX = 69, + // sine + PERV_SIN_INDEX = 70, + // cosine + PERV_COS_INDEX = 71, + // arc tan + PERV_ARCTAN_INDEX = 72, + // natural log + PERV_LOG_INDEX = 73, + // floor function + PERV_FLOOR_INDEX = 74, + // ceiling function + PERV_CEIL_INDEX = 75, + // truncation + PERV_TRUNC_INDEX = 76, + // real abs + PERV_RABS_INDEX = 77, + // string concatination + PERV_SCAT_INDEX = 78, + // string length + PERV_SLEN_INDEX = 79, + // chr function + PERV_ITOCHR_INDEX = 80, + // ord function + PERV_STOI_INDEX = 81, + // substring + PERV_SUBSTR_INDEX = 82, + // int to string + PERV_ITOSTR_INDEX = 83, + // real to string + PERV_RTOS_INDEX = 84, + // for unnamed universal constants (Note: tesize should be 0) + PERV_UNIV_INDEX = 85, + // std_in + PERV_STDIN_INDEX = 86, + // std_out + PERV_STDOUT_INDEX = 87, + // std_err + PERV_STDERR_INDEX = 88, + // nil + PERV_NIL_INDEX = 89, + // integer constant + PERV_INTC_INDEX = 90, + // real constant + PERV_REALC_INDEX = 91, + // string constant + PERV_STRC_INDEX = 92, + // cons + PERV_CONS_INDEX = 93 +} PERV_ConstIndexType; + +//total number pervasive constants +#define PERV_CONST_NUM 94 + +//pervasive const data type +typedef struct +{ + char *name; + TwoBytes typeEnvSize; + TwoBytes tskTabIndex; //index to the type skeleton table + TwoBytes neededness; //neededness (predicate constant) + TwoBytes univCount; + int precedence; + int fixity; +} PERV_ConstData; + +//pervasive const data table (array) +extern PERV_ConstData PERV_constDataTab[PERV_CONST_NUM]; + +//pervasive const data access function +PERV_ConstData PERV_getConstData(int index); + +//pervasive const table copy function (used in module space initialization) +//this functiion relies on the assumption that the pervasive kind data +//has the same structure as that of the run-time kind symbol table entries. +void PERV_copyConstDataTab(PERV_ConstData* dst); + +#define PERV_LSSTART PERV_AND_INDEX //begin of interpretable symbols +#define PERV_LSEND PERV_STOP_INDEX //end of interpretable symbols + +#define PERV_PREDSTART PERV_SOLVE_INDEX //begin of predicate symbols +#define PERV_PREDEND PERV_SYSTEM_INDEX //end of predicate symbols + +typedef enum PERV_LogicSymbTypes +{ + PERV_AND = 0, + PERV_OR = 1, + PERV_SOME = 2, + PERV_ALL = 3, + PERV_L_TRUE = 4, + PERV_CUT = 5, + PERV_FAIL = 6, + PERV_EQ = 7, + PERV_AMPAND = 8, + PERV_HALT = 9, + PERV_STOP = 10, +} PERV_LogicSymbTypes; + +//functions used by the simulator for interpreted goals +Boolean PERV_isLogicSymb(int index); +Boolean PERV_isPredSymb(int index); + +PERV_LogicSymbTypes PERV_logicSymb(int index); + +int PERV_predBuiltin(int index); + + +#endif //PERVASIVES_H + diff --git a/src/runtime/c/teyjus/tables/pervinit.c b/src/runtime/c/teyjus/tables/pervinit.c new file mode 100644 index 000000000..4e518572f --- /dev/null +++ b/src/runtime/c/teyjus/tables/pervinit.c @@ -0,0 +1,152 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +/***************************************************************************/ +/* File pervinit.h{c}. */ +/* Functions for setting up the symbol tables of pervasive constants and */ +/* kinds are provided. */ +/***************************************************************************/ +#include +#include + +#include "pervinit.h" +#include "pervasives.h" +#include "../system/memory.h" +#include "../simulator/dataformats.h" +#include "../simulator/mcstring.h" +#include "../simulator/mctypes.h" + +DF_StrDataPtr PERVINIT_writeName(char* name) +{ + int length = strlen(name); + MemPtr rtPtr, mcStr; + + rtPtr = (MemPtr)MEM_memExtend(MCSTR_numWords(length) + + DF_STRDATA_HEAD_SIZE); + mcStr = rtPtr + DF_STRDATA_HEAD_SIZE; + + //create data head + DF_mkStrDataHead((MemPtr)rtPtr); + //create the string data + MCSTR_toString((MCSTR_Str)mcStr, name, length); + return (DF_StrDataPtr)rtPtr; +} + +/***************************************************************************/ +/* PERVASIVE KINDS */ +/***************************************************************************/ +MEM_KstEnt PERVINIT_kindDataTab[PERV_KIND_NUM]; + +/* Set up pervasive kind symbol table. */ +/* The kind names are supposed to be written in the current top of system */ +/* memory. */ +static void PERVINIT_kindTabInit() +{ + int tabInd; + for (tabInd = 0; tabInd < PERV_KIND_NUM; tabInd++) { + if (PERV_kindDataTab[tabInd].name) + PERVINIT_kindDataTab[tabInd].name= + PERVINIT_writeName(PERV_kindDataTab[tabInd].name); + else PERVINIT_kindDataTab[tabInd].name = NULL; + + PERVINIT_kindDataTab[tabInd].arity=PERV_kindDataTab[tabInd].arity; + } +} + +/* copy the pervasive kind table into given address */ +void PERVINIT_copyKindDataTab(MEM_KstPtr dst) +{ + memcpy((void*)dst, (void*)PERVINIT_kindDataTab, + MEM_KST_ENTRY_SIZE * WORD_SIZE * PERV_KIND_NUM); +} + +/***************************************************************************/ +/* PERVASIVE TYPE SKELETONS */ +/***************************************************************************/ +MEM_TstPtr PERVINIT_tySkelTab; + +/* Set up pervasive type skeleton table. */ +static void PERVINIT_tySkelTabInit() +{ + PERVINIT_tySkelTab = PERV_tySkelTab; + PERV_tySkelTabInit(); +} + +/* copy the pervasive type skeleton table into given address */ +void PERVINIT_copyTySkelTab(PERV_TySkelData* dst) +{ + memcpy((void*)dst, (void*)PERVINIT_tySkelTab, + MEM_TST_ENTRY_SIZE * WORD_SIZE * PERV_TY_SKEL_NUM); +} + +/***************************************************************************/ +/* PERVASIVE CONSTANTS */ +/***************************************************************************/ +MEM_CstEnt PERVINIT_constDataTab[PERV_CONST_NUM]; + +/* Set up pervasive constant symbol table. */ +/* The constant names are supposed to be written in the current top of */ +/* system memory. */ +static void PERVINIT_constTabInit() +{ + int tabInd; + + for (tabInd = 0; tabInd < PERV_CONST_NUM; tabInd++) { + if (PERV_constDataTab[tabInd].name) + PERVINIT_constDataTab[tabInd].name = + PERVINIT_writeName(PERV_constDataTab[tabInd].name); + else PERVINIT_constDataTab[tabInd].name = NULL; + + PERVINIT_constDataTab[tabInd].typeEnvSize = + PERV_constDataTab[tabInd].typeEnvSize; + PERVINIT_constDataTab[tabInd].tskTabIndex = + PERV_constDataTab[tabInd].tskTabIndex; + PERVINIT_constDataTab[tabInd].neededness = + PERV_constDataTab[tabInd].neededness; + PERVINIT_constDataTab[tabInd].univCount = + PERV_constDataTab[tabInd].univCount; + PERVINIT_constDataTab[tabInd].precedence = + PERV_constDataTab[tabInd].precedence; + PERVINIT_constDataTab[tabInd].fixity = + PERV_constDataTab[tabInd].fixity; + } +} + +/* copy the pervsive constant table into given address */ +void PERVINIT_copyConstDataTab(MEM_CstPtr dst) +{ + memcpy((void*)dst, (void*)PERVINIT_constDataTab, + MEM_CST_ENTRY_SIZE * WORD_SIZE * PERV_CONST_NUM); + +} + +/***************************************************************************/ +/* PERVASIVE TABLES INITIALIZATION */ +/* Fill in the actual pervasive tables; create string data needed for names*/ +/* onto the current top of the system memory; create the type skeletons in */ +/* a malloced space. */ +/***************************************************************************/ +void PERVINIT_tableInit() +{ + PERVINIT_kindTabInit(); + PERVINIT_tySkelTabInit(); + PERVINIT_constTabInit(); +} + diff --git a/src/runtime/c/teyjus/tables/pervinit.h b/src/runtime/c/teyjus/tables/pervinit.h new file mode 100644 index 000000000..666b88776 --- /dev/null +++ b/src/runtime/c/teyjus/tables/pervinit.h @@ -0,0 +1,73 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +/***************************************************************************/ +/* File pervinit.h{c}. */ +/* Functions for setting up the symbol tables of pervasive constants and */ +/* kinds are provided. */ +/***************************************************************************/ + +#ifndef PERVINIT_H +#define PERVINIT_H + +#include "../simulator/dataformats.h" //to be modified +#include "../system/memory.h" //to be modified +#include "pervasives.h" +#include "../simulator/mctypes.h" + +/***************************************************************************/ +/* PERVASIVE KINDS */ +/***************************************************************************/ +//the actual pervasive kind table get copied during loading +extern MEM_KstEnt PERVINIT_kindDataTab[PERV_KIND_NUM]; + +/* copy the pervasive kind table into given address */ +void PERVINIT_copyKindDataTab(MEM_KstPtr dst); + + +/***************************************************************************/ +/* PERVASIVE TYPE SKELETONS */ +/***************************************************************************/ +//pervasive type skeleton table +extern MEM_TstPtr PERVINIT_tySkelTab; + +/* copy the pervasive type skeleton table into given address */ +void PERVINIT_copyTySkelTab(MEM_TstPtr dst); + + +/***************************************************************************/ +/* PERVASIVE CONSTANTS */ +/***************************************************************************/ +//the acutual pervasive constant table get copied during loading +extern MEM_CstEnt PERVINIT_constDataTab[PERV_CONST_NUM]; + +/* copy the pervasive constant table into given address */ +void PERVINIT_copyConstDataTab(MEM_CstPtr dst); + + +/***************************************************************************/ +/* PERVASIVE TABLES INITIALIZATION */ +/* Fill in the actual pervasive tables; create string data needed for names*/ +/* onto the current top of the system memory; create the type skeletons in */ +/* a malloced space. */ +/***************************************************************************/ +void PERVINIT_tableInit(); + +#endif //PERVINIT_H diff --git a/src/runtime/c/teyjus/tables_gen/Makefile b/src/runtime/c/teyjus/tables_gen/Makefile new file mode 100644 index 000000000..7cf2c532a --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/Makefile @@ -0,0 +1,28 @@ +all: instrformats/gen pervasives/gen + +instrformats/gen: instrformats/y.tab.o instrformats/lex.yy.o \ + instrformats/instrgen-c.o instrformats/instrgen-ocaml.o \ + util/util.o + gcc -o instrformats/gen $^ + +pervasives/gen: pervasives/y.tab.o pervasives/lex.yy.o \ + pervasives/ccode.o pervasives/ocamlcode.o \ + pervasives/pervgen-c.o pervasives/pervgen-ocaml.o \ + pervasives/types.o pervasives/op.o \ + util/util.o + gcc -o pervasives/gen $^ + +.o : .c + gcc -c -o $@ $^ + +instrformats/y.tab.c instrformats/y.tab.h : instrformats/instrformats.y + yacc -o instrformats/y.tab.c --defines=instrformats/y.tab.h instrformats/instrformats.y + +instrformats/lex.yy.c : instrformats/instrformats.l instrformats/y.tab.h + flex -o instrformats/lex.yy.c instrformats/instrformats.l + +pervasives/y.tab.c pervasives/y.tab.h : pervasives/pervasives.y + yacc -o pervasives/y.tab.c --defines=pervasives/y.tab.h pervasives/pervasives.y + +pervasives/lex.yy.c : pervasives/pervasives.l pervasives/y.tab.h + flex -o pervasives/lex.yy.c pervasives/pervasives.l diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrformats.l b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats.l new file mode 100644 index 000000000..28e43ab1b --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats.l @@ -0,0 +1,69 @@ +%{ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +#include "y.tab.h" +#include +#include + +static int commentLev = 0; +%} + +LETTER [A-Za-z] +DIGIT [0-9] +SYMBOL "_"|"+"|"-"|"*"|"/"|"!"|"~"|"@"|"$"|"%"|"^"|"&"|"*"|"<"|">"|"="|"'"|":"|"," + +ID ({LETTER}|{SYMBOL})({LETTER}|{DIGIT}|{SYMBOL})* +NUM {DIGIT}+ +WSPACE [ \t]+ +STRING [^*/]+ +STRING2 [^}]+ + +%x COMMENT COMMENT2 INCLUDE + +%% +"\n" {continue; } +";" {return SEMICOLON; } +"[" {return LBRACKET; } +"]" {return RBRACKET; } +"OPERAND TYPES" {return OPTYPES; } +"OPCODE" {return OPCODE; } +"INSTR CATEGORY" {return INSTRCAT; } +"MAX OPERAND" {return MAXOPERAND; } +"CALL_I1_LEN" {return CALL_I1_LEN; } +"INSTRUCTIONS" {return INSTRUCTIONS; } +{WSPACE} {continue; } +"/%" {commentLev = 1; BEGIN(COMMENT); continue; } +"/*" {BEGIN(COMMENT2); continue; } +"{" {BEGIN(INCLUDE); continue; } +{ID} {yylval.name = strdup(yytext); return ID; } +{NUM} {yylval.isval.ival = atoi(yytext); + yylval.isval.sval = strdup(yytext); + return NUM; } +"*/" {BEGIN(INITIAL); continue; } +{STRING} {yylval.text = strdup(yytext); return STRING; } + +[^%/\n]+ {continue; } +"/%" {commentLev++; continue; } +"%/" {commentLev--; + if (!commentLev) BEGIN(INITIAL); continue; } +"}" {BEGIN(INITIAL); continue; } +{STRING2} {yylval.text = strdup(yytext); return STRING2; } +. {return ERROR; } diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrformats.y b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats.y new file mode 100644 index 000000000..348312732 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats.y @@ -0,0 +1,283 @@ +%{ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +#include +#include "instrgen-c.h" +#include "instrgen-ocaml.h" +#include "../util/util.h" + +extern int yylex(); + +int yywrap() {return 1;} + +void yyerror(const char* str) +{ + printf("%s\n", str); +} + +%} + +%union{ + char* name; + char* text; + struct + { + int ival; + char* sval; + } isval; +} + +%token OPTYPES INSTRCAT INSTRUCTIONS OPCODE MAXOPERAND + CALL_I1_LEN SEMICOLON ERROR LBRACKET RBRACKET +%token ID +%token NUM +%token STRING STRING2 + +%start instr_format +%type operand_name operand_tname operand_type instr_name instr_cat + instr_head instr_length operand_comp_type +%type comments compiler_include +%type max_operand opcode operand_size +%% + +instr_format : compiler_include operands instrcats instructions + +compiler_include : STRING2 { ocgenInclude($1);} + + +operands : OPTYPES operand_decs opcode_type + { cgenOpsH(); ocgenOps();} + ; + +operand_decs : operand_dec operand_decs + | operand_dec_last + ; + +operand_dec : operand_name operand_tname operand_type operand_size operand_comp_type comments + { cgenOpTypes($1, $2, $3, $6, 0); + ocgenOpType($1, $4.ival, $5); + } + | operand_name comments + { cgenOpTypes($1, NULL, NULL, $2, 0); } + ; + +operand_dec_last : operand_name operand_tname operand_type operand_size operand_comp_type comments + { cgenOpTypes($1, $2, $3, $6, 1); + ocgenOpType($1, $4.ival, $5); + } + | operand_name comments + { cgenOpTypes($1, NULL, NULL, $2, 1); } + ; + + +operand_name : ID { $$ = $1; } + ; + +operand_tname : ID { $$ = $1; } + ; + +operand_type : ID { $$ = $1; } + ; + +operand_comp_type : ID { $$ = $1; } + ; + +comments : STRING {$$ = $1; } + ; + +operand_size : NUM { $$ = $1; } + ; + +opcode_type : OPCODE ID operand_size + { cgenOpCodeType($2); + ocgenOpCodeType($3.ival);} + ; + +instrcats : INSTRCAT max_operand instrcat_decs CALL_I1_LEN NUM + { cgenInstrCatH($5.sval); cgenInstrCatC($2.sval); + ocgenInstrCat(); + } + ; + +max_operand : MAXOPERAND NUM { $$ = $2; } + ; + +instrcat_decs : instrcat_dec instrcat_decs + | instrcat_dec_last + ; + +instrcat_dec : ID LBRACKET instr_format RBRACKET instr_lengths + { cgenOneInstrCatH($1, 0); cgenOneInstrCatC($1, 0); + ocgenOneInstrCat($1); + } + ; + +instrcat_dec_last : ID LBRACKET instr_format RBRACKET instr_lengths + { cgenOneInstrCatH($1, 1); cgenOneInstrCatC($1, 1); + ocgenOneInstrCat($1); + } + ; + +instr_format : oneOp instr_format + | lastOp + ; + +oneOp : ID { cgenInstrFormat($1, 0); ocgenInstrFormat($1); } + ; + +lastOp : ID { cgenInstrFormat($1, 1); ocgenInstrFormat($1); } + ; + + +instr_lengths : instr_len_first SEMICOLON instr_lengths_rest + | instr_len_first + ; + +instr_lengths_rest : instr_len SEMICOLON instr_lengths_rest + | instr_len + ; + +instr_len_first : ID NUM + {cgenInstrLength($1, $2.sval); + ocgenInstrLength($1, $2.sval);} + ; + +instr_len : ID NUM { cgenInstrLength($1, $2.sval);} + ; + + +instructions : instr_head instrs + { cgenInstrH($1); cgenInstrC(); cgenSimDispatch(); + ocgenInstr(); + } + ; + +instr_head : INSTRUCTIONS NUM + { cinitInstrC($2.ival); + cinitSimDispatch($2.ival); + $$ = $2.sval; + } + ; + + +instrs : instr SEMICOLON instrs + | last_instr + ; + +instr : comments opcode instr_name instr_cat instr_length + { cgenOneInstrH($1, $2.sval , $3); + cgenOneInstrC($2.ival, $3, $4, $5, 0); + cgenOneSimDispatch($2.ival, $3, 0); + ocgenOneInstr($2.sval, $3, $4, $5, 0); + } + | opcode instr_name instr_cat instr_length + { cgenOneInstrH(NULL, $1.sval , $2); + cgenOneInstrC($1.ival, $2, $3, $4, 0); + cgenOneSimDispatch($1.ival, $2, 0); + ocgenOneInstr($1.sval, $2, $3, $4, 0); + } + ; + +last_instr : comments opcode instr_name instr_cat instr_length + { cgenOneInstrH($1, $2.sval , $3); + cgenOneInstrC($2.ival, $3, $4, $5, 1); + cgenOneSimDispatch($2.ival, $3, 1); + ocgenOneInstr($2.sval, $3, $4, $5, 1); + } + | opcode instr_name instr_cat instr_length + { cgenOneInstrH(NULL, $1.sval , $2); + cgenOneInstrC($1.ival, $2, $3, $4, 1); + cgenOneSimDispatch($1.ival, $2, 1); + ocgenOneInstr($1.sval, $2, $3, $4, 1); + } + ; + +opcode : NUM { $$ = $1; } + ; + +instr_name : ID { $$ = $1; } + ; + +instr_cat : ID { $$ = $1; } + ; + +instr_length : ID { $$ = $1; } + ; + + +%% + +extern FILE* yyin; + +int main(argc, argv) + int argc; + char * argv[]; +{ + char * root = NULL; + int ret = 0; + + if(argc <= 1) + { + if (sizeof(void*) == 8) + { + //printf("No input file specified; using 'instrformats_64.in'.\n"); + yyin = UTIL_fopenR("instrformats_64.in"); + } + else + { + //printf("No input file specified; using 'instrformats_32.in'.\n"); + yyin = UTIL_fopenR("instrformats_32.in"); + } + } + else + { + yyin = UTIL_fopenR(argv[1]); + } + + if(argc > 2) + { + root = argv[2]; + } + else + { + //printf("Teyjus source root directory not specified; using '../../'.\n"); + root = "../../"; + } + + //printf("Generating instruction files...\n"); + + ret = yyparse(); + UTIL_fclose(yyin); + + if(ret != 0) + { + printf("Generation failed.\n"); + return -1; + } + cspitCInstructionsH(root); + cspitCInstructionsC(root); + cspitSimDispatch(root); + //ocSpitInstructionMLI(root); + //ocSpitInstructionML(root); + //printf("Done.\n"); + + return 0; +} diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrformats_32.in b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats_32.in new file mode 100644 index 000000000..1cfddddfb --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats_32.in @@ -0,0 +1,346 @@ +{ +type intref = int ref +type aconstant = Absyn.aconstant +type akind = Absyn.akind + +} + +OPERAND TYPES + + P /* (1 byte) padding */ + WP /* (1 word) padding */ + R RegInd Byte 1 int /* argument register number */ + E EnvInd Byte 1 int /* environment variable number */ + N NextClauseInd Byte 1 int /* next clause number in impt or impl pt */ + I1 OneByteInt Byte 1 int /* 1 byte natural number */ + CE ClEnvInd Byte 1 int /* closure environment variable number */ + SEG ImpSegInd Byte 1 int /* import segment index */ + C CstIndex TwoBytes 2 aconstant /* constant symbol table index */ + K KstIndex TwoBytes 2 akind /* kind symbol table index */ + L CodeLabel CSpacePtr 4 intref /* code location */ + I Int int 4 int /* integer immediate value */ + F Float float 4 float /* floating point immediate value */ + S Str DF_StrDataPtr 2 int /* string pointer */ + MT ModTab MemPtr 2 int /* module table address */ + IT ImplTab MemPtr 2 int /* impl table address */ + HT HashTab MemPtr 2 int /* hash table address */ + BVT BranchTab MemPtr 2 int /* branch table for bound var indexing */ + X /* operand list terminator */ + OPCODE Byte 1 + + +INSTR CATEGORY + + MAX OPERAND 8 + + X [P P P X X X X X] + X_LEN 4 + + RX [R P P X X X X X] + RX_LEN 4; RX_R 1 + + EX [E P P X X X X X] + EX_LEN 4; EX_E 1 + + I1X [I1 P P X X X X X] + I1X_LEN 4; I1X_I1 1 + + CX [P C X X X X X X] + CX_LEN 4; CX_C 2 + + KX [P K X X X X X X] + KX_LEN 4; KX_K 2 + + IX [P P P I X X X X] + IX_LEN 8; IX_I 4 + + FX [P P P F X X X X] + FX_LEN 8; FX_F 4 + + SX [P P P S X X X X] + SX_LEN 8; SX_S 4 + + MTX [P P P MT X X X X] + MTX_LEN 8; MTX_MT 4 + + LX [P P P L X X X X] + LX_LEN 8; LX_L 4 + + RRX [R R P X X X X X] + RRX_LEN 4; RRX_R1 1; RRX_R2 2 + + ERX [E R P X X X X X] + ERX_LEN 4; ERX_E 1; ERX_R 2 + + RCX [R C X X X X X X] + RCX_LEN 4; RCX_R 1; RCX_C 2 + + RIX [R P P I X X X X] + RIX_LEN 8; RIX_R 1; RIX_I 4 + + RFX [R P P F X X X X] + RFX_LEN 8; RFX_R 1; RFX_F 4 + + RSX [R P P S X X X X] + RSX_LEN 8; RSX_R 1; RSX_S 4 + + RI1X [R I1 P X X X X X] + RI1X_LEN 4; RI1X_R 1; RI1X_I1 2 + + RCEX [R CE P X X X X X] + RCEX_LEN 4; RCEX_R 1; RCEX_CE 2 + + ECEX [E CE P X X X X X] + ECEX_LEN 4; ECEX_E 1; ECEX_CE 2 + + CLX [P C L X X X X X] + CLX_LEN 8; CLX_C 2; CLX_L 4 + + RKX [R K X X X X X X] + RKX_LEN 4; RKX_R 1; RKX_K 2 + + ECX [E C X X X X X X] + ECX_LEN 4; ECX_E 1; ECX_C 2 + + I1ITX [I1 P P IT X X X X] + I1ITX_LEN 8; I1ITX_I1 1; I1ITX_IT 4 + + I1LX [I1 P P L X X X X] + I1LX_LEN 8; I1LX_I1 1; I1LX_L 4 + + SEGLX [SEG P P L X X X X] + SEGLX_LEN 8; SEGLX_SEG 1; SEGLX_L 4 + + I1LWPX [I1 P P L WP X X X] + I1LWPX_LEN 12; I1LWPX_I1 1; I1LWPX_L 4 + + I1NX [I1 N P X X X X X] + I1NX_LEN 4; I1NX_I1 1; I1NX_N 2 + + I1HTX [I1 P P HT X X X X] + I1HTX_LEN 8; I1HTX_I1 1; I1HTX_HT 4 + + I1BVTX [I1 P P BVT X X X X] + I1BVTX_LEN 8; I1BVTX_I1 1; I1BVTX_BVT 4 + + CWPX [P C WP X X X X X] + CWPX_LEN 8; CWPX_C 2 + + I1WPX [I1 P P WP X X X X] + I1WPX_LEN 8; I1WPX_I1 1 + + RRI1X [R R I1 X X X X X] + RRI1X_LEN 4; RRI1X_R1 1; RRI1X_R2 2; RRI1X_I1 3 + + RCLX [R C L X X X X X] + RCLX_LEN 8; RCLX_R 1; RCLX_C 2; RCLX_L 4 + + RCI1X [R C I1 P P P X X] + RCI1X_LEN 8; RCI1X_R 1; RCI1X_C 2; RCI1X_I1 4 + + SEGI1LX [SEG I1 P L X X X X] + SEGI1LX_LEN 8; SEGI1LX_SEG 1; SEGI1LX_I1 2; SEGI1LX_L 4 + + I1LLX [I1 P P L L X X X] + I1LLX_LEN 12; I1LLX_I1 1; I1LLX_L1 4; I1LLX_L2 8 + + NLLX [N P P L L X X X] + NLLX_LEN 12; NLLX_N 1; NLLX_L1 4; NLLX_L2 8 + + LLLLX [P P P L L L L X] + LLLLX_LEN 20; LLLLX_L1 4; LLLLX_L2 8; LLLLX_L3 12; LLLLX_L4 16 + + I1CWPX [I1 C WP X X X X X] + I1CWPX_LEN 8; I1CWPX_I1 1; I1CWPX_C 2 + + I1I1WPX [I1 I1 P WP X X X X] + I1I1WPX_LEN 8; I1I1WPX_I11 1; I1I1WPX_I12 2 + + CALL_I1_LEN 7 + + +INSTRUCTIONS 145 + + /* Instructions for term unification and creation */ + + 0 put_variable_t RRX RRX_LEN; + 1 put_variable_p ERX ERX_LEN; + 2 put_value_t RRX RRX_LEN; + 3 put_value_p ERX ERX_LEN; + 4 put_unsafe_value ERX ERX_LEN; + 5 copy_value ERX ERX_LEN; + 6 put_m_const RCX RCX_LEN; + 7 put_p_const RCX RCX_LEN; + 8 put_nil RX RX_LEN; + 9 put_integer RIX RIX_LEN; + 10 put_float RFX RFX_LEN; + 11 put_string RSX RSX_LEN; + 12 put_index RI1X RI1X_LEN; + 13 put_app RRI1X RRI1X_LEN; + 14 put_list RX RX_LEN; + 15 put_lambda RRI1X RRI1X_LEN; + + 16 set_variable_t RX RX_LEN; + 17 set_variable_te RX RX_LEN; + 18 set_variable_p EX EX_LEN; + 19 set_value_t RX RX_LEN; + 20 set_value_p EX EX_LEN; + 21 globalize_pt ERX ERX_LEN; + 22 globalize_t RX RX_LEN; + 23 set_m_const CX CX_LEN; + 24 set_p_const CX CX_LEN; + 25 set_nil X X_LEN; + 26 set_integer IX IX_LEN; + 27 set_float FX FX_LEN; + 28 set_string SX SX_LEN; + 29 set_index I1X I1X_LEN; + 30 set_void I1X I1X_LEN; + 31 deref RX RX_LEN; + 32 set_lambda RI1X RI1X_LEN; + + + 33 get_variable_t RRX RRX_LEN; + 34 get_variable_p ERX ERX_LEN; + 35 init_variable_t RCEX RCEX_LEN; + 36 init_variable_p ECEX ECEX_LEN; + 37 get_m_constant RCX RCX_LEN; + 38 get_p_constant RCLX RCLX_LEN; + 39 get_integer RIX RIX_LEN; + 40 get_float RFX RFX_LEN; + 41 get_string RSX RSX_LEN; + 42 get_nil RX RX_LEN; + 43 get_m_structure RCI1X RCI1X_LEN; + 44 get_p_structure RCI1X RCI1X_LEN; + 45 get_list RX RX_LEN; + + 46 unify_variable_t RX RX_LEN; + 47 unify_variable_p EX EX_LEN; + 48 unify_value_t RX RX_LEN; + 49 unify_value_p EX EX_LEN; + 50 unify_local_value_t RX RX_LEN; + 51 unify_local_value_p EX EX_LEN; + 52 unify_m_constant CX CX_LEN; + 53 unify_p_constant CLX CLX_LEN; + 54 unify_integer IX IX_LEN; + 55 unify_float FX FX_LEN; + 56 unify_string SX SX_LEN; + 57 unify_nil X X_LEN; + 58 unify_void I1X I1X_LEN; + + /* Instructions for type unification and creation */ + 59 put_type_variable_t RRX RRX_LEN; + 60 put_type_variable_p ERX ERX_LEN; + 61 put_type_value_t RRX RRX_LEN; + 62 put_type_value_p ERX ERX_LEN; + 63 put_type_unsafe_value ERX ERX_LEN; + 64 put_type_const RKX RKX_LEN; + 65 put_type_structure RKX RKX_LEN; + 66 put_type_arrow RX RX_LEN; + + 67 set_type_variable_t RX RX_LEN; + 68 set_type_variable_p EX EX_LEN; + 69 set_type_value_t RX RX_LEN; + 70 set_type_value_p EX EX_LEN; + 71 set_type_local_value_t RX RX_LEN; + 72 set_type_local_value_p EX EX_LEN; + 73 set_type_constant KX KX_LEN; + + 74 get_type_variable_t RRX RRX_LEN; + 75 get_type_variable_p ERX ERX_LEN; + 76 init_type_variable_t RCEX RCEX_LEN; + 77 init_type_variable_p ECEX ECEX_LEN; + 78 get_type_value_t RRX RRX_LEN; + 79 get_type_value_p ERX ERX_LEN; + 80 get_type_constant RKX RKX_LEN; + 81 get_type_structure RKX RKX_LEN; + 82 get_type_arrow RX RX_LEN; + + 83 unify_type_variable_t RX RX_LEN; + 84 unify_type_variable_p EX EX_LEN; + 85 unify_type_value_t RX RX_LEN; + 86 unify_type_value_p EX EX_LEN; + 87 unify_envty_value_t RX RX_LEN; + 88 unify_envty_value_p EX EX_LEN; + 89 unify_type_local_value_t RX RX_LEN; + 90 unify_type_local_value_p EX EX_LEN; + 91 unify_envty_local_value_t RX RX_LEN; + 92 unify_envty_local_value_p EX EX_LEN; + 93 unify_type_constant KX KX_LEN; + + /* Instructions for handling higher-order aspects */ + + 94 pattern_unify_t RRX RRX_LEN; + 95 pattern_unify_p ERX ERX_LEN; + 96 finish_unify X X_LEN; + 97 head_normalize_t RX RX_LEN; + 98 head_normalize_p EX EX_LEN; + + /* Instructions for handling logical aspects */ + + 99 incr_universe X X_LEN; + 100 decr_universe X X_LEN; + 101 set_univ_tag ECX ECX_LEN; + 102 tag_exists_t RX RX_LEN; + 103 tag_exists_p EX EX_LEN; + 104 tag_variable EX EX_LEN; + + 105 push_impl_point I1ITX I1ITX_LEN; + 106 pop_impl_point X X_LEN; + 107 add_imports SEGI1LX SEGI1LX_LEN; + 108 remove_imports SEGLX SEGLX_LEN; + 109 push_import MTX MTX_LEN; + 110 pop_imports I1X I1X_LEN; + + /* Control Instructions */ + + 111 allocate I1X I1X_LEN; + 112 deallocate X X_LEN; + 113 call I1LX I1LX_LEN; + 114 call_name I1CWPX I1CWPX_LEN; + 115 execute LX LX_LEN; + 116 execute_name CWPX CWPX_LEN; + 117 proceed X X_LEN; + + /* Choice Instructions */ + + 118 try_me_else I1LX I1LX_LEN; + 119 retry_me_else I1LX I1LX_LEN; + 120 trust_me I1WPX I1WPX_LEN; + 121 try I1LX I1LX_LEN; + 122 retry I1LX I1LX_LEN; + 123 trust I1LWPX I1LWPX_LEN; + 124 trust_ext I1NX I1NX_LEN; + 125 try_else I1LLX I1LLX_LEN; + 126 retry_else I1LLX I1LLX_LEN; + 127 branch LX LX_LEN; + + /* Indexing Instructions */ + + 128 switch_on_term LLLLX LLLLX_LEN; + 129 switch_on_constant I1HTX I1HTX_LEN; + 130 switch_on_bvar I1BVTX I1BVTX_LEN; + 131 switch_on_reg NLLX NLLX_LEN; + + /* Cut Instructions */ + + 132 neck_cut X X_LEN; + 133 get_level EX EX_LEN; + 134 put_level EX EX_LEN; + 135 cut EX EX_LEN; + + /* Miscellaneous Instructions */ + + 136 call_builtin I1I1WPX I1I1WPX_LEN; + 137 builtin I1X I1X_LEN; + 138 stop X X_LEN; + 139 halt X X_LEN; + 140 fail X X_LEN; + + /* new added */ + 141 create_type_variable EX EX_LEN; + + /* resolved by the linker */ + 142 execute_link_only CWPX CWPX_LEN; + 143 call_link_only I1CWPX I1CWPX_LEN; + + 144 put_variable_te RRX RRX_LEN \ No newline at end of file diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrformats_64.in b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats_64.in new file mode 100644 index 000000000..3aaebdf48 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrformats_64.in @@ -0,0 +1,346 @@ +{ +type intref = int ref +type aconstant = Absyn.aconstant +type akind = Absyn.akind + +} + +OPERAND TYPES + + P /* (1 byte) padding */ + WP /* (1 word) padding */ + R RegInd Byte 1 int /* argument register number */ + E EnvInd Byte 1 int /* environment variable number */ + N NextClauseInd Byte 1 int /* next clause number in impt or impl pt */ + I1 OneByteInt Byte 1 int /* 1 byte natural number */ + CE ClEnvInd Byte 1 int /* closure environment variable number */ + SEG ImpSegInd Byte 1 int /* import segment index */ + C CstIndex TwoBytes 2 aconstant /* constant symbol table index */ + K KstIndex TwoBytes 2 akind /* kind symbol table index */ + L CodeLabel CSpacePtr 8 intref /* code location */ + I Int int 4 int /* integer immediate value */ + F Float float 4 float /* floating point immediate value */ + S Str DF_StrDataPtr 2 int /* string pointer */ + MT ModTab MemPtr 2 int /* module table address */ + IT ImplTab MemPtr 2 int /* impl table address */ + HT HashTab MemPtr 2 int /* hash table address */ + BVT BranchTab MemPtr 2 int /* branch table for bound var indexing */ + X /* operand list terminator */ + OPCODE Byte 1 + + +INSTR CATEGORY + + MAX OPERAND 12 + + X [P P P P P P P X X X X X] + X_LEN 8 + + RX [R P P P P P P X X X X X] + RX_LEN 8; RX_R 1 + + EX [E P P P P P P X X X X X] + EX_LEN 8; EX_E 1 + + I1X [I1 P P P P P P X X X X X] + I1X_LEN 8; I1X_I1 1 + + CX [P C P P P P X X X X X X] + CX_LEN 8; CX_C 2 + + KX [P K P P P P X X X X X X] + KX_LEN 8; KX_K 2 + + IX [P P P P P P P I X X X X] + IX_LEN 16; IX_I 8 + + FX [P P P P P P P F X X X X] + FX_LEN 16; FX_F 8 + + SX [P P P P P P P S X X X X] + SX_LEN 16; SX_S 8 + + MTX [P P P P P P P MT X X X X] + MTX_LEN 16; MTX_MT 8 + + LX [P P P P P P P L X X X X] + LX_LEN 16; LX_L 8 + + RRX [R R P P P P P X X X X X] + RRX_LEN 8; RRX_R1 1; RRX_R2 2 + + ERX [E R P P P P P X X X X X] + ERX_LEN 8; ERX_E 1; ERX_R 2 + + RCX [R C P P P P X X X X X X] + RCX_LEN 8; RCX_R 1; RCX_C 2 + + RIX [R P P P P P P I X X X X] + RIX_LEN 16; RIX_R 1; RIX_I 8 + + RFX [R P P P P P P F X X X X] + RFX_LEN 16; RFX_R 1; RFX_F 8 + + RSX [R P P P P P P S X X X X] + RSX_LEN 16; RSX_R 1; RSX_S 8 + + RI1X [R I1 P P P P P X X X X X] + RI1X_LEN 8; RI1X_R 1; RI1X_I1 2 + + RCEX [R CE P P P P P X X X X X] + RCEX_LEN 8; RCEX_R 1; RCEX_CE 2 + + ECEX [E CE P P P P P X X X X X] + ECEX_LEN 8; ECEX_E 1; ECEX_CE 2 + + CLX [P C P P P P L X X X X X] + CLX_LEN 16; CLX_C 2; CLX_L 8 + + RKX [R K P P P P X X X X X X] + RKX_LEN 8; RKX_R 1; RKX_K 2 + + ECX [E C P P P P X X X X X X] + ECX_LEN 8; ECX_E 1; ECX_C 2 + + I1ITX [I1 P P P P P P IT X X X X] + I1ITX_LEN 16; I1ITX_I1 1; I1ITX_IT 8 + + I1LX [I1 P P P P P P L X X X X] + I1LX_LEN 16; I1LX_I1 1; I1LX_L 8 + + SEGLX [SEG P P P P P P L X X X X] + SEGLX_LEN 16; SEGLX_SEG 1; SEGLX_L 8 + + I1LWPX [I1 P P P P P P L WP X X X] + I1LWPX_LEN 24; I1LWPX_I1 1; I1LWPX_L 8 + + I1NX [I1 N P P P P P X X X X X] + I1NX_LEN 8; I1NX_I1 1; I1NX_N 2 + + I1HTX [I1 P P P P P P HT X X X X] + I1HTX_LEN 16; I1HTX_I1 1; I1HTX_HT 8 + + I1BVTX [I1 P P P P P P BVT X X X X] + I1BVTX_LEN 16; I1BVTX_I1 1; I1BVTX_BVT 8 + + CWPX [P C P P P P WP X X X X X] + CWPX_LEN 16; CWPX_C 2 + + I1WPX [I1 P P P P P P WP X X X X] + I1WPX_LEN 16; I1WPX_I1 1 + + RRI1X [R R I1 P P P P X X X X X] + RRI1X_LEN 8; RRI1X_R1 1; RRI1X_R2 2; RRI1X_I1 3 + + RCLX [R C P P P P L X X X X X] + RCLX_LEN 16; RCLX_R 1; RCLX_C 2; RCLX_L 8 + + RCI1X [R C I1 P P P X X X X X X] + RCI1X_LEN 8; RCI1X_R 1; RCI1X_C 2; RCI1X_I1 4 + + SEGI1LX [SEG I1 P P P P P L X X X X] + SEGI1LX_LEN 16; SEGI1LX_SEG 1; SEGI1LX_I1 2; SEGI1LX_L 8 + + I1LLX [I1 P P P P P P L L X X X] + I1LLX_LEN 24; I1LLX_I1 1; I1LLX_L1 8; I1LLX_L2 16 + + NLLX [N P P P P P P L L X X X] + NLLX_LEN 24; NLLX_N 1; NLLX_L1 8; NLLX_L2 16 + + LLLLX [P P P P P P P L L L L X] + LLLLX_LEN 40; LLLLX_L1 8; LLLLX_L2 16; LLLLX_L3 24; LLLLX_L4 32 + + I1CWPX [I1 C P P P P WP X X X X X] + I1CWPX_LEN 16; I1CWPX_I1 1; I1CWPX_C 2 + + I1I1WPX [I1 I1 P P P P P WP X X X X] + I1I1WPX_LEN 16; I1I1WPX_I11 1; I1I1WPX_I12 2 + + CALL_I1_LEN 15 + + +INSTRUCTIONS 145 + + /* Instructions for term unification and creation */ + + 0 put_variable_t RRX RRX_LEN; + 1 put_variable_p ERX ERX_LEN; + 2 put_value_t RRX RRX_LEN; + 3 put_value_p ERX ERX_LEN; + 4 put_unsafe_value ERX ERX_LEN; + 5 copy_value ERX ERX_LEN; + 6 put_m_const RCX RCX_LEN; + 7 put_p_const RCX RCX_LEN; + 8 put_nil RX RX_LEN; + 9 put_integer RIX RIX_LEN; + 10 put_float RFX RFX_LEN; + 11 put_string RSX RSX_LEN; + 12 put_index RI1X RI1X_LEN; + 13 put_app RRI1X RRI1X_LEN; + 14 put_list RX RX_LEN; + 15 put_lambda RRI1X RRI1X_LEN; + + 16 set_variable_t RX RX_LEN; + 17 set_variable_te RX RX_LEN; + 18 set_variable_p EX EX_LEN; + 19 set_value_t RX RX_LEN; + 20 set_value_p EX EX_LEN; + 21 globalize_pt ERX ERX_LEN; + 22 globalize_t RX RX_LEN; + 23 set_m_const CX CX_LEN; + 24 set_p_const CX CX_LEN; + 25 set_nil X X_LEN; + 26 set_integer IX IX_LEN; + 27 set_float FX FX_LEN; + 28 set_string SX SX_LEN; + 29 set_index I1X I1X_LEN; + 30 set_void I1X I1X_LEN; + 31 deref RX RX_LEN; + 32 set_lambda RI1X RI1X_LEN; + + + 33 get_variable_t RRX RRX_LEN; + 34 get_variable_p ERX ERX_LEN; + 35 init_variable_t RCEX RCEX_LEN; + 36 init_variable_p ECEX ECEX_LEN; + 37 get_m_constant RCX RCX_LEN; + 38 get_p_constant RCLX RCLX_LEN; + 39 get_integer RIX RIX_LEN; + 40 get_float RFX RFX_LEN; + 41 get_string RSX RSX_LEN; + 42 get_nil RX RX_LEN; + 43 get_m_structure RCI1X RCI1X_LEN; + 44 get_p_structure RCI1X RCI1X_LEN; + 45 get_list RX RX_LEN; + + 46 unify_variable_t RX RX_LEN; + 47 unify_variable_p EX EX_LEN; + 48 unify_value_t RX RX_LEN; + 49 unify_value_p EX EX_LEN; + 50 unify_local_value_t RX RX_LEN; + 51 unify_local_value_p EX EX_LEN; + 52 unify_m_constant CX CX_LEN; + 53 unify_p_constant CLX CLX_LEN; + 54 unify_integer IX IX_LEN; + 55 unify_float FX FX_LEN; + 56 unify_string SX SX_LEN; + 57 unify_nil X X_LEN; + 58 unify_void I1X I1X_LEN; + + /* Instructions for type unification and creation */ + 59 put_type_variable_t RRX RRX_LEN; + 60 put_type_variable_p ERX ERX_LEN; + 61 put_type_value_t RRX RRX_LEN; + 62 put_type_value_p ERX ERX_LEN; + 63 put_type_unsafe_value ERX ERX_LEN; + 64 put_type_const RKX RKX_LEN; + 65 put_type_structure RKX RKX_LEN; + 66 put_type_arrow RX RX_LEN; + + 67 set_type_variable_t RX RX_LEN; + 68 set_type_variable_p EX EX_LEN; + 69 set_type_value_t RX RX_LEN; + 70 set_type_value_p EX EX_LEN; + 71 set_type_local_value_t RX RX_LEN; + 72 set_type_local_value_p EX EX_LEN; + 73 set_type_constant KX KX_LEN; + + 74 get_type_variable_t RRX RRX_LEN; + 75 get_type_variable_p ERX ERX_LEN; + 76 init_type_variable_t RCEX RCEX_LEN; + 77 init_type_variable_p ECEX ECEX_LEN; + 78 get_type_value_t RRX RRX_LEN; + 79 get_type_value_p ERX ERX_LEN; + 80 get_type_constant RKX RKX_LEN; + 81 get_type_structure RKX RKX_LEN; + 82 get_type_arrow RX RX_LEN; + + 83 unify_type_variable_t RX RX_LEN; + 84 unify_type_variable_p EX EX_LEN; + 85 unify_type_value_t RX RX_LEN; + 86 unify_type_value_p EX EX_LEN; + 87 unify_envty_value_t RX RX_LEN; + 88 unify_envty_value_p EX EX_LEN; + 89 unify_type_local_value_t RX RX_LEN; + 90 unify_type_local_value_p EX EX_LEN; + 91 unify_envty_local_value_t RX RX_LEN; + 92 unify_envty_local_value_p EX EX_LEN; + 93 unify_type_constant KX KX_LEN; + + /* Instructions for handling higher-order aspects */ + + 94 pattern_unify_t RRX RRX_LEN; + 95 pattern_unify_p ERX ERX_LEN; + 96 finish_unify X X_LEN; + 97 head_normalize_t RX RX_LEN; + 98 head_normalize_p EX EX_LEN; + + /* Instructions for handling logical aspects */ + + 99 incr_universe X X_LEN; + 100 decr_universe X X_LEN; + 101 set_univ_tag ECX ECX_LEN; + 102 tag_exists_t RX RX_LEN; + 103 tag_exists_p EX EX_LEN; + 104 tag_variable EX EX_LEN; + + 105 push_impl_point I1ITX I1ITX_LEN; + 106 pop_impl_point X X_LEN; + 107 add_imports SEGI1LX SEGI1LX_LEN; + 108 remove_imports SEGLX SEGLX_LEN; + 109 push_import MTX MTX_LEN; + 110 pop_imports I1X I1X_LEN; + + /* Control Instructions */ + + 111 allocate I1X I1X_LEN; + 112 deallocate X X_LEN; + 113 call I1LX I1LX_LEN; + 114 call_name I1CWPX I1CWPX_LEN; + 115 execute LX LX_LEN; + 116 execute_name CWPX CWPX_LEN; + 117 proceed X X_LEN; + + /* Choice Instructions */ + + 118 try_me_else I1LX I1LX_LEN; + 119 retry_me_else I1LX I1LX_LEN; + 120 trust_me I1WPX I1WPX_LEN; + 121 try I1LX I1LX_LEN; + 122 retry I1LX I1LX_LEN; + 123 trust I1LWPX I1LWPX_LEN; + 124 trust_ext I1NX I1NX_LEN; + 125 try_else I1LLX I1LLX_LEN; + 126 retry_else I1LLX I1LLX_LEN; + 127 branch LX LX_LEN; + + /* Indexing Instructions */ + + 128 switch_on_term LLLLX LLLLX_LEN; + 129 switch_on_constant I1HTX I1HTX_LEN; + 130 switch_on_bvar I1BVTX I1BVTX_LEN; + 131 switch_on_reg NLLX NLLX_LEN; + + /* Cut Instructions */ + + 132 neck_cut X X_LEN; + 133 get_level EX EX_LEN; + 134 put_level EX EX_LEN; + 135 cut EX EX_LEN; + + /* Miscellaneous Instructions */ + + 136 call_builtin I1I1WPX I1I1WPX_LEN; + 137 builtin I1X I1X_LEN; + 138 stop X X_LEN; + 139 halt X X_LEN; + 140 fail X X_LEN; + + /* new added */ + 141 create_type_variable EX EX_LEN; + + /* resolved by the linker */ + 142 execute_link_only CWPX CWPX_LEN; + 143 call_link_only I1CWPX I1CWPX_LEN; + + 144 put_variable_te RRX RRX_LEN \ No newline at end of file diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.c b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.c new file mode 100644 index 000000000..394f85d9e --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.c @@ -0,0 +1,650 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +/******************************************************************************/ +/* File instrgen-c.h. This files contains function declarations for generating*/ +/* files instructions.h and instructions.c */ +/******************************************************************************/ +#include +#include +#include +#include "instrgen-c.h" +#include "../util/util.h" + +#define INDENT1 " " +#define INDENT1_LEN 4u +#define PREFIX "INSTR_" +#define PREFIX_LEN 6u +#define CATPREFIX "INSTR_CAT_" +#define CATPREFIX_LEN 10u +#define DEF "#define " +#define DEF_LEN 8u + +/*************************************************************************/ +/* instructions.h */ +/*************************************************************************/ +#define COMMENTS_BEG_H \ +"/****************************************************************************/\n/* File instructions.h. */ \n/* This file defines instruction operand types, instruction categories and */ \n/* instruction opcode. */ \n/****************************************************************************/ \n" + +#define COMPDEF_BEG_H "#ifndef INSTRUCTIONS_H\n#define INSTRUCTIONS_H\n" +#define COMPDEF_END_H "#endif //INSTRUCTIONS_H\n" + +#define INCLUDE_H \ +"#include \"../simulator/mctypes.h\" //to be changed \n#include \"../simulator/dataformats.h\" //to be changed \n" + +/* OPERAND TYPES */ +#define OPTYPES_COMMENTS_H \ +"/****************************************************************************/\n/* OPERAND TYPES */ \n/****************************************************************************/ \n\n" +#define OPTYPES_COMMENTS_H_LEN 300 + +#define OPERAND_TYPE_BEG \ +"/* possible types of instruction operands */ \ntypedef enum INSTR_OperandType \n{\n" +#define OPERAND_TYPE_BEG_LEN 200 + +#define OPERAND_TYPE_END "} INSTR_OperandType;\n\n" +#define OPERAND_TYPE_END_LEN 30 + +static char* opTypes = NULL; +static char* opTypeMaps = NULL ; + +void cgenOpTypes(char *name, char* typeName, char* types, char* comments, + int last) +{ + char* myOpTypes = opTypes; + char* myOpTypeMaps = opTypeMaps; + size_t length; + size_t commentLen = comments ? strlen(comments) : 0u; + length = (opTypes ? strlen(opTypes) : 0u) + INDENT1_LEN + PREFIX_LEN + + strlen(name) + (comments ? strlen(comments) : 0u) + 30u; + opTypes = UTIL_mallocStr(length); + if (myOpTypes) { strcpy(opTypes, myOpTypes); strcat(opTypes, INDENT1); } + else strcpy(opTypes, INDENT1); + if (comments) { + strcat(opTypes, "//"); + strcat(opTypes, comments); + strcat(opTypes, "\n"); + strcat(opTypes, INDENT1); + } + strcat(opTypes, PREFIX); + strcat(opTypes, name); + if (last) strcat(opTypes, "\n"); + else strcat(opTypes, ",\n"); + if (myOpTypes) free(myOpTypes); + + if (typeName) { + length = (opTypeMaps ? strlen(opTypeMaps) : 0u) + PREFIX_LEN + + strlen(types) + strlen(typeName) + 30u; + opTypeMaps = UTIL_mallocStr(length); + if (myOpTypeMaps) { + strcpy(opTypeMaps, myOpTypeMaps); + strcat(opTypeMaps, "typedef "); + } else strcpy(opTypeMaps, "typedef "); + strcat(opTypeMaps, types); + strcat(opTypeMaps, " "); + strcat(opTypeMaps, PREFIX); + strcat(opTypeMaps, typeName); + strcat(opTypeMaps, ";\n"); + if (myOpTypeMaps) free(myOpTypeMaps); + } +} + +#define OPTYPEMAP_COMMENT \ +"/**************************************************************************/ \n/* Types for instruction operants */ \n/**************************************************************************/ \n\n" +#define OPTYPEMAP_COMMENT_LEN 300 + +static char *opcodeType = NULL; + +void cgenOpCodeType(char* optype) +{ + size_t length = PREFIX_LEN + strlen(optype) + 50; + opcodeType = UTIL_mallocStr(length); + strcpy(opcodeType, "typedef "); + strcat(opcodeType, optype); + strcat(opcodeType, " "); + strcat(opcodeType, PREFIX); + strcat(opcodeType, "OpCode;\n"); +} + + +static char *opsH = NULL; + +void cgenOpsH() //assume neither opTypes nor opTypeMaps is empty +{ + size_t length = OPTYPES_COMMENTS_H_LEN + OPERAND_TYPE_BEG_LEN + + OPTYPEMAP_COMMENT_LEN + OPERAND_TYPE_END_LEN + strlen(opTypes) + + strlen(opTypeMaps) + strlen(opcodeType) + 50u; + opsH = UTIL_mallocStr(length); + + strcpy(opsH, OPTYPES_COMMENTS_H); + strcat(opsH, OPERAND_TYPE_BEG); + strcat(opsH, opTypes); + strcat(opsH, OPERAND_TYPE_END); + strcat(opsH, OPTYPEMAP_COMMENT); + strcat(opsH, opcodeType); + strcat(opsH, opTypeMaps); + + free(opTypes); + free(opcodeType); + free(opTypeMaps); +} + +/* INSTRUCTION CATEGORIES */ +#define INSTRCAT_COMMENTS_H \ +"/***************************************************************************/ \n/* INSTRUCTION CATEGORIES */ \n/***************************************************************************/ \n" +#define INSTRCAT_COMMENTS_H_LEN 300 + +#define INSTRCAT_TYPE_BEG \ +" /* The names of instruction categories no longer include padding bytes. */\n/* Thus we do not need to maintain two sets of names for different machine */ \n/* architectures. */ \ntypedef enum INSTR_InstrCategory \n{\n" +#define INSTRCAT_TYPE_BEG_LEN 350 +#define INSTRCAT_TYPE_END "} INSTR_InstrCategory;\n\n" +#define INSTRCAT_TYPE_END_LEN 50 + + +static char *instrcat_type = NULL; +static char *instrLen = NULL; +static char *oneInstrLen = NULL; +static int catNum = 0; + +void cgenOneInstrCatH(char* name, int last) +{ + char *myInstrCat = instrcat_type, *myInstrLen = instrLen; + size_t length = (myInstrCat ? strlen(myInstrCat) : 0u) + strlen(name) + + CATPREFIX_LEN + INDENT1_LEN + 10u; + instrcat_type = UTIL_mallocStr(length); + if (myInstrCat) { + strcpy(instrcat_type, myInstrCat); + strcat(instrcat_type, INDENT1); + } else strcpy(instrcat_type, INDENT1); + strcat(instrcat_type, CATPREFIX); + strcat(instrcat_type, name); + strcat(instrcat_type, " = "); + strcat(instrcat_type, UTIL_itoa(catNum)); + if (last) strcat(instrcat_type, "\n"); + else strcat(instrcat_type, ",\n"); + catNum++; + + if (myInstrCat) free(myInstrCat); + + //assume oneInstrLen cannot be empty + length = (myInstrLen ? strlen(myInstrLen) : 0u) + strlen(name) + + CATPREFIX_LEN + 10u + strlen(oneInstrLen); + instrLen = UTIL_mallocStr(length); + + if (myInstrLen) { + strcpy(instrLen, myInstrLen); + strcat(instrLen, "//"); + } else strcpy(instrLen, "//"); + strcat(instrLen, CATPREFIX); + strcat(instrLen, name); + strcat(instrLen, "\n"); + strcat(instrLen, oneInstrLen); + + free(oneInstrLen); + oneInstrLen = NULL; + if (myInstrLen) free(myInstrLen); +} + +#define INSTRLEN_COMMENTS \ +"/**************************************************************************/ \n/* Macros defines instruction lengths and distances between op code and */ \n/* operands. */ \n/* The assumption is that the op code occupies 1 byte. */ \n/**************************************************************************/ \n\n" +#define INSTRLEN_COMMENTS_LEN 450u + +void cgenInstrLength(char* name, char* len) +{ + char *myInstrLen = oneInstrLen; + size_t length = (myInstrLen ? strlen(myInstrLen) : 0u) + DEF_LEN + PREFIX_LEN + + strlen(name) + strlen(len) + 10u; + oneInstrLen = UTIL_mallocStr(length); + if (myInstrLen) { + strcpy(oneInstrLen, myInstrLen); + strcat(oneInstrLen, DEF); + } else strcpy(oneInstrLen, DEF); + strcat(oneInstrLen, PREFIX); + strcat(oneInstrLen, name); + strcat(oneInstrLen, " "); + strcat(oneInstrLen, len); + strcat(oneInstrLen, "\n"); + + free(myInstrLen); +} + +#define OPTYPE_TAB_H \ +"/****************************************************************************/\n/* OPERAND TYPES TABLE */ \n/****************************************************************************/ \n \n//the operand types array in a given entry \nINSTR_OperandType* INSTR_operandTypes(INSTR_InstrCategory index); \n" +#define OPTYPE_TAB_H_LEN 500 + + +static char *instrCatH = NULL; + +void cgenInstrCatH(char* callI1Len) +{ + size_t length = strlen(instrcat_type) + strlen(instrLen) + + INSTRCAT_TYPE_BEG_LEN + INSTRCAT_TYPE_END_LEN + INSTRCAT_COMMENTS_H_LEN + + INSTRLEN_COMMENTS_LEN + OPTYPE_TAB_H_LEN + 160u; + instrCatH = UTIL_mallocStr(length); + + strcpy(instrCatH, INSTRCAT_COMMENTS_H); + strcat(instrCatH, INSTRCAT_TYPE_BEG); + strcat(instrCatH, instrcat_type); + strcat(instrCatH, INSTRCAT_TYPE_END); + strcat(instrCatH, DEF); + strcat(instrCatH, "INSTR_NUM_INSTR_CATS "); + strcat(instrCatH, UTIL_itoa(catNum)); + strcat(instrCatH, "\n\n"); + strcat(instrCatH, DEF); + strcat(instrCatH, "INSTR_CALL_I1_LEN "); + strcat(instrCatH, callI1Len); + strcat(instrCatH, "\n\n"); + strcat(instrCatH, INSTRLEN_COMMENTS); + strcat(instrCatH, instrLen); + strcat(instrCatH, "\n"); + strcat(instrCatH, OPTYPE_TAB_H); + + + free(instrcat_type); + free(instrLen); +} + +#define INSTR_COMMENTS_H \ +"/***************************************************************************/ \n/* OPCODES OF INSTRUCTIONS */ \n/***************************************************************************/ \n" +#define INSTR_COMMENTS_H_LEN 250 + +static char* instrH = NULL; + +void cgenOneInstrH(char* comments, char* opCode, char* instrName) +{ + char* myInstrH = instrH; + size_t length = (myInstrH ? strlen(myInstrH) : 0u) + strlen(instrName) + + strlen(opCode) + DEF_LEN + CATPREFIX_LEN + + (comments ? strlen(comments) : 0u) + 10u; + instrH = UTIL_mallocStr(length); + if (myInstrH) { + strcpy(instrH, myInstrH); + if (comments) { + strcat(instrH, "//"); + strcat(instrH, comments); + strcat(instrH, "\n"); + strcat(instrH, DEF); + } else strcat(instrH, DEF); + } else { + if (comments) { + strcpy(instrH, "//"); + strcat(instrH, comments); + strcat(instrH, "\n"); + strcat(instrH, DEF); + } else strcpy(instrH, DEF); + } + strcat(instrH, instrName); + strcat(instrH, " "); + strcat(instrH, opCode); + strcat(instrH, "\n"); + + + if (myInstrH) free(myInstrH); +} + +#define INSTRTAB_H \ +"/***************************************************************************/ \n/* INSTRUCTION INFORMATION TABLE */ \n/***************************************************************************/ \nINSTR_InstrCategory INSTR_instrType(int index); //instr type in a given entry \nchar* INSTR_instrName(int index); //instr name in a given entry \nint INSTR_instrSize(int index); //instr size in a given entry \n" +#define INSTRTAB_H_LEN 500 + + + +char* instrOpc = NULL; + +void cgenInstrH(char* numInstr) +{ + size_t length = INSTR_COMMENTS_H_LEN + strlen(instrH) + DEF_LEN + + strlen(numInstr) + INSTRTAB_H_LEN + 20u; + + instrOpc = UTIL_mallocStr(length); + strcpy(instrOpc, INSTR_COMMENTS_H); + strcat(instrOpc, instrH); + strcat(instrOpc, "\n\n"); + strcat(instrOpc, DEF); + strcat(instrOpc, "INSTR_NUM_INSTRS"); + strcat(instrOpc, " "); + strcat(instrOpc, numInstr); + strcat(instrOpc, "\n\n"); + strcat(instrOpc, INSTRTAB_H); + + free(instrH); +} + + +/* dump instructions.h" */ +void cspitCInstructionsH(char * root) +{ + FILE* outFile; + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "tables/instructions.h"); + + outFile = UTIL_fopenW(filename); + fprintf(outFile, "%s\n%s\n%s\n", COMMENTS_BEG_H, COMPDEF_BEG_H, INCLUDE_H); + fprintf(outFile, "%s\n", opsH); + fprintf(outFile, "%s\n", instrCatH); + fprintf(outFile, "%s\n", instrOpc); + fprintf(outFile, "%s\n", COMPDEF_END_H); + UTIL_fclose(outFile); + + free(opsH); + free(instrCatH); + free(instrOpc); + + free(filename); +} + + +/*************************************************************************/ +/* instructions.c */ +/*************************************************************************/ +#define COMMENTS_BEG_C \ +"/****************************************************************************/\n/* */ \n/* File instructions.c. This file defines the operand types table and */ \n/* the instruction information table. */ \n/* */ \n/****************************************************************************/ \n\n" +#define INCLUDE_C "#include \"instructions.h\"\n" + +/*OPERAND TYPE TABLE */ +#define OPTYPE_TAB_COMMENTS \ +"/****************************************************************************/\n/* OPERAND TYPES TABLE */ \n/****************************************************************************/ \n\n" +#define OPTYPE_TAB_COMMENTS_LEN 250 + +#define MAX_OP_COMMENTS \ +"/* Max number of operand that could be taken by instructions including the */\n/* padding bytes and one to terminate the list. (machine dependent) */ \n" +#define MAX_OP_COMMENTS_LEN 200 + + +#define OPTYPE_TAB_TYPE \ +"/* this array is indexed by instruction category. For each category, \n INSTR_operandTypeTab contains a string of values indicating the type \n of the operand at that position, terminated by INSTR_X. This \n information is useful when parsing instruction streams. */ \ntypedef INSTR_OperandType \n INSTR_OperandTypeTab[INSTR_NUM_INSTR_CATS][INSTR_MAX_OPERAND]; \n\n" + +#define OPTYPE_TAB_TYPE_LEN 500 + +#define OPTYPE_TAB_BEG "INSTR_OperandTypeTab INSTR_operandTypeTable ={\n" +#define OPTYPE_TAB_BEG_LEN 80 +#define OPTYPE_TAB_END "};\n\n" +#define OPTYPE_TAB_END_LEN 10 + +static char* optypeTabEntry = NULL; + +void cgenInstrFormat(char* opType, int last) +{ + char* mytabEntry = optypeTabEntry; + size_t length = (mytabEntry ? strlen(mytabEntry) : 0u) + PREFIX_LEN + + strlen(opType) + 5u; + optypeTabEntry = UTIL_mallocStr(length); + + if (mytabEntry) { + strcpy(optypeTabEntry, mytabEntry); + strcat(optypeTabEntry, PREFIX); + } else strcpy(optypeTabEntry, PREFIX); + strcat(optypeTabEntry, opType); + if (!last) strcat(optypeTabEntry, ", "); + + if (mytabEntry) free(mytabEntry); +} + +static char* optypeTab = NULL; + +//assume optypeEntry is not empty +void cgenOneInstrCatC(char* name, int last) +{ + char* myoptypeTab = optypeTab; + size_t length = (myoptypeTab ? strlen(myoptypeTab) : 0u) + INDENT1_LEN*2 + + strlen(optypeTabEntry) + strlen(name) + 10u + CATPREFIX_LEN; + + optypeTab = UTIL_mallocStr(length); + + if (myoptypeTab) { + strcpy(optypeTab, myoptypeTab); + strcat(optypeTab, INDENT1); + } else strcpy(optypeTab, INDENT1); + strcat(optypeTab, "//"); + strcat(optypeTab, CATPREFIX); + strcat(optypeTab, name); + strcat(optypeTab, "\n"); + strcat(optypeTab, INDENT1); + strcat(optypeTab, "{"); + strcat(optypeTab, optypeTabEntry); + if (last) strcat(optypeTab, "}\n"); + else strcat(optypeTab, "},\n"); + + free(optypeTabEntry); + optypeTabEntry = NULL; + if (myoptypeTab) free(myoptypeTab); +} + +#define OPTYPE_FUNC \ +"INSTR_OperandType* INSTR_operandTypes(INSTR_InstrCategory index) \n{ \n return INSTR_operandTypeTable[index]; \n}\n" +#define OPTYPE_FUNC_LEN 250 + +static char* opTypeC = NULL; + +void cgenInstrCatC(char* max_op){ + size_t length = OPTYPE_TAB_COMMENTS_LEN + MAX_OP_COMMENTS_LEN + + OPTYPE_TAB_TYPE_LEN + OPTYPE_TAB_BEG_LEN + OPTYPE_TAB_END_LEN + + strlen(optypeTab) + OPTYPE_FUNC_LEN + strlen(max_op) + 100u; + opTypeC = UTIL_mallocStr(length); + strcpy(opTypeC, OPTYPE_TAB_COMMENTS); + strcat(opTypeC, MAX_OP_COMMENTS); + strcat(opTypeC, "#define INSTR_MAX_OPERAND "); + strcat(opTypeC, max_op); + strcat(opTypeC, "\n\n"); + strcat(opTypeC, OPTYPE_TAB_TYPE); + strcat(opTypeC, OPTYPE_TAB_BEG); + strcat(opTypeC, optypeTab); + strcat(opTypeC, OPTYPE_TAB_END); + strcat(opTypeC, OPTYPE_FUNC); +} + +//dynamic string array type +typedef struct StringArray +{ + char **array; + unsigned int length; +} StringArray; + + +static StringArray instrTab; + +void cinitInstrC(int numInstrs) +{ + instrTab.length = numInstrs; + instrTab.array = (char**)UTIL_malloc(sizeof(char*)*numInstrs); +} + +void cgenOneInstrC(int opcode, char* name, char* cat, char* len, int last) +{ + size_t length = strlen(name) + strlen(cat) + strlen(len) + PREFIX_LEN + + CATPREFIX_LEN + 20u + INDENT1_LEN ; + char* myText = UTIL_mallocStr(length); + + strcpy(myText, INDENT1); + strcat(myText, "{\""); + strcat(myText, name); + strcat(myText, "\", "); + strcat(myText, CATPREFIX); + strcat(myText, cat); + strcat(myText, ", "); + strcat(myText, PREFIX); + strcat(myText, len); + if (last) strcat(myText, "}\n"); + else strcat(myText, "},\n"); + + instrTab.array[opcode] = myText; +} + +#define INSTR_TAB_C_COMMENTS \ +"/****************************************************************************/\n/* INSTRUCTION INFORMATION TABLE */ \n/****************************************************************************/ \n" +#define INSTR_TAB_C_COMMENTS_LEN 250 + +#define INSTR_TAB_TYPE \ +"typedef struct //entry of the instruction info table \n{ \n char* name; \n INSTR_InstrCategory type; \n int size; \n} INSTR_InstrInfoTab_; \n\ntypedef INSTR_InstrInfoTab_ INSTR_InstrInfoTab[INSTR_NUM_INSTRS]; \n\n" +#define INSTR_TAB_TYPE_LEN 600 + +#define INSTR_TAB_BEG "INSTR_InstrInfoTab INSTR_instrInfoTable ={\n" +#define INSTR_TAB_BEG_LEN 80 + +#define INSTR_TAB_END "};\n\n" +#define INSTR_TAB_END_LEN 10 + +#define INSTR_TAB_FUNC_C \ +"/* Accessing functions */ \nINSTR_InstrCategory INSTR_instrType(int index) \n{ \n return (INSTR_instrInfoTable[index]).type; \n} \n\nchar* INSTR_instrName(int index) \n{ \n return (INSTR_instrInfoTable[index]).name; \n} \n\nint INSTR_instrSize(int index) \n{ \n return (INSTR_instrInfoTable[index]).size; \n}\n\n" +#define INSTR_TAB_FUNC_C_LEN 1000 + +static char* instrC = NULL; + +void cgenInstrC() +{ + size_t i, length; + char *myText = NULL, *myText2; + for (i = 0; i < instrTab.length; i++) { + if (instrTab.array[i]) { + length = (myText ? strlen(myText) : 0u) + strlen(instrTab.array[i]); + myText2 = UTIL_mallocStr(length + 100u); + if (myText) { + strcpy(myText2, myText); + strcat(myText2, instrTab.array[i]); + } else strcpy(myText2, instrTab.array[i]); + free(instrTab.array[i]); + free(myText); + myText = myText2; + } + } + free(instrTab.array); + length = INSTR_TAB_C_COMMENTS_LEN + INSTR_TAB_TYPE_LEN + + INSTR_TAB_BEG_LEN + INSTR_TAB_END_LEN + INSTR_TAB_FUNC_C_LEN + + strlen(myText); + instrC = UTIL_mallocStr(length); + strcpy(instrC, INSTR_TAB_C_COMMENTS); + strcat(instrC, INSTR_TAB_TYPE); + strcat(instrC, INSTR_TAB_BEG); + strcat(instrC, myText); + strcat(instrC, INSTR_TAB_END); + strcat(instrC, INSTR_TAB_FUNC_C); + free(myText); +} + + +/* dump instructions.c" */ +void cspitCInstructionsC(char * root) +{ + FILE* outFile; + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "tables/instructions.c"); + + outFile = UTIL_fopenW(filename); + fprintf(outFile, "%s\n%s\n", COMMENTS_BEG_C, INCLUDE_C); + fprintf(outFile, "%s\n", opTypeC); + fprintf(outFile, "%s\n", instrC); + UTIL_fclose(outFile); + + free(opTypeC); + free(instrC); + free(filename); +} + +/* simdispatch.c */ +#define SIMPREFIX "SINSTR_" +#define SIMPREFIX_LEN 7 + +#define SIMDIS_COMMENTS \ +"/***************************************************************************/ \n/* */ \n/* File simdispatch.c. The instruction dispatch table used by the */ \n/* simulator is defined here as an array of function pointers, each of */ \n/* which refers to a function realizing a corresponding instruction. */ \n/* These functions are defined in the file ./siminstr.c. */ \n/***************************************************************************/ \n\n" +#define SIMDIS_COMMENTS_LEN 600 + +#define SIMDIS_INCLUDE \ +"#include \"../tables/instructions.h\" //to be modified \n#include \"siminstr.h\" \n#include \"simdispatch.h\"\n\n" +#define SIMDIS_INCLUDE_LEN 250 + +#define SIMDIS_TAB_BEG \ +"SDP_InstrFunctionPtr SDP_dispatchTable[INSTR_NUM_INSTRS] = {\n" +#define SIMDIS_TAB_BEG_LEN 80 + +#define SIMDIS_TAB_END "};\n" +#define SIMDIS_TAB_END_LEN 10 + +static StringArray dispatchTab; + +void cinitSimDispatch(int size) +{ + dispatchTab.length = size; + dispatchTab.array = (char**)UTIL_malloc(sizeof(char*)*size); +} + +void cgenOneSimDispatch(int ind, char* instr, int last) +{ + size_t length = strlen(instr) + SIMPREFIX_LEN + INDENT1_LEN + 10u; + char* myText = UTIL_mallocStr(length); + + strcpy(myText, INDENT1); + strcat(myText, SIMPREFIX); + strcat(myText, instr); + if (last) strcat(myText, "\n"); + else strcat(myText, ",\n"); + + dispatchTab.array[ind] = myText; +} + +static char* dispatch = NULL; + +void cgenSimDispatch() +{ + size_t i, length; + char *myText = NULL, *myText2; + + for(i = 0; i < dispatchTab.length; i++) { + if (dispatchTab.array[i]){ + length = (myText ? strlen(myText) : 0)+strlen(dispatchTab.array[i]); + myText2 = UTIL_mallocStr(length); + if (myText){ + strcpy(myText2, myText); + strcat(myText2, dispatchTab.array[i]); + } else strcpy(myText2, dispatchTab.array[i]); + free(dispatchTab.array[i]); + free(myText); + myText = myText2; + } + } + free(dispatchTab.array); + length = SIMDIS_COMMENTS_LEN + SIMDIS_INCLUDE_LEN + SIMDIS_TAB_BEG_LEN + + SIMDIS_TAB_BEG_LEN + SIMDIS_TAB_END_LEN + strlen(myText); + dispatch = UTIL_mallocStr(length); + strcpy(dispatch, SIMDIS_COMMENTS); + strcat(dispatch, SIMDIS_INCLUDE); + strcat(dispatch, SIMDIS_TAB_BEG); + strcat(dispatch, myText); + strcat(dispatch, SIMDIS_TAB_END); + + free(myText); +} + +void cspitSimDispatch(char * root) +{ + FILE* outFile; + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "simulator/simdispatch.c"); + outFile = UTIL_fopenW(filename); + fprintf(outFile, "%s\n", dispatch); + + free(dispatch); + UTIL_fclose(outFile); + free(filename); +} + + + + diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.h b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.h new file mode 100644 index 000000000..0c1c6b6fd --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-c.h @@ -0,0 +1,70 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +/******************************************************************************/ +/* File instrgen-c.h. This files contains function declarations for generating*/ +/* files instructions.h and instructions.c */ +/******************************************************************************/ + +/* instructions.h */ +/* generating operand types */ + +void cgenOpTypes(char *name, char* typeName, char* types, char* comments, + int last); + +void cgenOpCodeType(char* optype); + +void cgenOpsH(); + +void cgenInstrCatH(char* callI1Len); + +void cgenOneInstrCatH(char* name, int last); + +void cgenInstrLength(char* name, char* length); + +void cgenInstrH(char* numInstr); + +void cgenOneInstrH(char* comments, char* opcode, char* name); + + +/* dump instructions.h" */ +void cspitCInstructionsH(char * root); + +/* instructions.c */ + +void cgenInstrFormat(char* opType, int last); + +void cgenOneInstrCatC(char* name, int last); + +void cgenInstrCatC(char* max_op); + +void cinitInstrC(int numInstr); +void cgenOneInstrC(int opcode, char* name, char* cat, char* len, int last); +void cgenInstrC(); + +/* dump instructions.c" */ +void cspitCInstructionsC(char * root); + +/* simdispatch.c */ +void cinitSimDispatch(int size); +void cgenOneSimDispatch(int ind, char* instr, int last); +void cgenSimDispatch(); + +void cspitSimDispatch(char * root); diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.c b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.c new file mode 100644 index 000000000..5309509c8 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.c @@ -0,0 +1,841 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +/*************************************************************************/ +/* functions for generating ocaml instr.mli and instr.ml */ +/*************************************************************************/ +#include "../util/util.h" +#include +#include +#include +#include + +static char* addLine(char* str, char* addOn) +{ + size_t length = (str ? strlen(str) : 0) + strlen(addOn) + 2; + char* newStr = UTIL_mallocStr(length); + + if (str) { + strcpy(newStr, str); + strcat(newStr, addOn); + } else strcpy(newStr, addOn); + strcat(newStr, "\n\n"); + return newStr; +} + +static char* addStr(char* str, char* addOn) +{ + size_t length = (str ? strlen(str) : 0) + strlen(addOn); + char* newStr = UTIL_mallocStr(length); + + if (str) { + strcpy(newStr, str); + strcat(newStr, addOn); + } else strcpy(newStr, addOn); + return newStr; +} + + +/**********************************************************************/ +/* auxiliary functions for making ocaml language constructs */ +/**********************************************************************/ +#define TYPE_SUFFIX "type" +#define SIZE_SUFFIX "Size" +#define WRITE_PREFIX "write" +#define READ_PREFIX "read" +#define DISPLAY_PREFIX "display" +#define INDENT " " +#define INDENT2 " " +#define WRITE "Bytecode.write" +#define READ "Bytecode.read" +#define DISPLAY "Bytecode.display" +#define INSCAT_PREFIX "inscat" +#define INS_PREFIX "Ins_" + +static char* OC_mkVarDec(char* varName, char* varType) +{ + size_t length = strlen(varName) + strlen(varType) + 10; + char* vardec = UTIL_mallocStr(length); + + strcpy(vardec, "val "); + strcat(vardec, varName); + strcat(vardec, " : "); + strcat(vardec, varType); + strcat(vardec, "\n"); + + return vardec; +} + +static char* OC_mkVarDef(char* varName, char* defs) +{ + size_t length = strlen(varName) + strlen(defs) + 10; + char* vardef = UTIL_mallocStr(length); + + strcpy(vardef, "let "); + strcat(vardef, varName); + strcat(vardef, " = "); + strcat(vardef, defs); + strcat(vardef, "\n"); + + return vardef; +} + +static char* OC_mkTypeDec(char* typeName, char* defs) +{ + size_t length = strlen(typeName) + strlen(defs) + 10; + char* typedec = UTIL_mallocStr(length); + + strcpy(typedec, "type "); + strcat(typedec, typeName); + strcat(typedec, " = "); + strcat(typedec, defs); + strcat(typedec, "\n"); + + return typedec; +} + +static char* OC_mkFunc(char* funcName, char* arg, char* body) +{ + size_t length = strlen(funcName) + strlen(arg) + strlen(body) + 20; + char* func = UTIL_mallocStr(length); + + strcpy(func, "let "); + strcat(func, funcName); + strcat(func, " "); + strcat(func, arg); + strcat(func, " = "); + strcat(func, body); + strcat(func, "\n"); + + return func; +} + +static char* OC_mkCrossType(char *lop, char *rop) +{ + size_t length = strlen(lop) + strlen(rop) + 5; + char* crossType = UTIL_mallocStr(length); + + strcpy(crossType, lop); + strcat(crossType, " * "); + strcat(crossType, rop); + + return crossType; +} + +static char* OC_mkValueCtr(char* ctrName, char* types) +{ + size_t length = strlen(ctrName) + strlen(types) + 10; + char* ctr = UTIL_mallocStr(length); + + strcpy(ctr, ctrName); + strcat(ctr, " of "); + strcat(ctr, types); + return ctr; +} + +static char* OC_mkDisjValueCtrs(char* prev, char* next) +{ + size_t length = strlen(prev) + strlen(next) + 10; + char* ctr = UTIL_mallocStr(length); + + strcpy(ctr, prev); + strcat(ctr, "\n"); + strcat(ctr, INDENT); + strcat(ctr, "| "); + strcat(ctr, next); + + return ctr; +} + +static char* OC_mkFuncSeq(char* prev, char* new) +{ + size_t length = strlen(prev) + strlen(new) + 20; + char* funcSeq = UTIL_mallocStr(length); + + strcpy(funcSeq, prev); + strcat(funcSeq, "; "); + strcat(funcSeq, new); + return funcSeq; +} + +static char* OC_mkArgList(char* prev, char* new) +{ + size_t length = strlen(prev) + strlen(new) + 2; + char* args = UTIL_mallocStr(length); + + strcpy(args, prev); + strcat(args, ", "); + strcat(args, new); + + return args; +} + +static char* OC_mkStrConcat(char* prev, char* new) +{ + size_t length = strlen(prev) + strlen(new) + 20; + char* str = UTIL_mallocStr(length); + + strcpy(str, "("); + strcat(str, prev); + strcat(str, ") ^ \", \" ^ ("); + strcat(str, new); + strcat(str, ")"); + + return str; +} + + +static char* OC_mkArrow(char* left, char* right) +{ + size_t length = strlen(left) + strlen(right) + 20; + char* arrow = UTIL_mallocStr(length); + + strcpy(arrow, left); + strcat(arrow, " -> "); + strcat(arrow, right); + + return arrow; +} + +static char* OC_mkStructure(char* func, char* arg) +{ + size_t length = strlen(func) + strlen(arg) + 5; + char* app = UTIL_mallocStr(length); + + strcpy(app, func); + strcat(app, "("); + strcat(app, arg); + strcat(app, ")"); + + return app; +} + +static char* OC_mkCond(char* cond, char* branch) +{ + size_t length = strlen(cond) + strlen(branch) + 20; + char* str = UTIL_mallocStr(length); + + strcpy(str, INDENT); + strcat(str, "if "); + strcat(str, cond); + strcat(str, " then "); + strcat(str, branch); + strcat(str, "\n"); + strcat(str, INDENT); + strcat(str, "else"); + + return str; +} + +static char* OC_mkLetIn(char* varName, char* def) +{ + size_t length = strlen(varName) + strlen(def) + 20; + char* str = UTIL_mallocStr(length); + + strcpy(str, INDENT); + strcat(str, "let "); + strcat(str, varName); + strcat(str, " = "); + strcat(str, def); + strcat(str, " in\n"); + + return str; +} + +/**************************************************************************/ +/* type definitions */ +/**************************************************************************/ +static char* typeDefs; + +void ocgenInclude(char* include) +{ + typeDefs = include; +} + +/**************************************************************************/ +/* operand types */ +/**************************************************************************/ +static char* opTypes; +static char* opSizesMLI; +static char* opSizesML; +static char* writeFuncs; +static char* readFuncs; + +static char* ocgenWriteOpFunc(char* typeName, char* compType, int numBytes) +{ + char* funcName = UTIL_appendStr(WRITE_PREFIX, typeName); + char* numBytesText = UTIL_itoa(numBytes); + char* arg = "arg"; + char* funcBody1 = UTIL_mallocStr(strlen(WRITE) + strlen(compType) + + strlen(numBytesText)); + char *funcBody2, *func; + + strcpy(funcBody1, WRITE); + strcat(funcBody1, compType); + strcat(funcBody1, numBytesText); free(numBytesText); + + funcBody2 = UTIL_appendStr(funcBody1, " arg"); free(funcBody1); + func = OC_mkFunc(funcName, arg, funcBody2); + free(funcName); free(funcBody2); + return func; +} + +static char* ocgenReadOpFunc(char* typeName, char* compType, int numBytes) +{ + char* funcName = UTIL_appendStr(READ_PREFIX, typeName); + char* numBytesText = UTIL_itoa(numBytes); + char* arg = "()"; + char* funcBody1 = UTIL_mallocStr(strlen(READ) + strlen(compType) + + strlen(numBytesText)); + char* funcBody2, *func; + + strcpy(funcBody1, READ); + strcat(funcBody1, compType); + strcat(funcBody1, numBytesText); free(numBytesText); + + funcBody2 = UTIL_appendStr(funcBody1, " ()"); free(funcBody1); + func = OC_mkFunc(funcName, arg, funcBody2); + free(funcName); free(funcBody2); + return func; +} + +void ocgenOpType(char* typeName, int numBytes, char* compType) +{ + /* generate type declarations*/ + char* myName = UTIL_lowerCase(typeName); + char* myTypeName = UTIL_appendStr(myName, TYPE_SUFFIX); + char* myOpType = OC_mkTypeDec(myTypeName, compType); + char* myopTypes = addStr(opTypes, myOpType); + /* generate write functions */ + char* func = ocgenWriteOpFunc(typeName, compType, numBytes); + char* myWriteFuncs = addStr(writeFuncs, func); + /* generate read functions */ + char* readFunc = ocgenReadOpFunc(typeName, compType, numBytes); + char* myReadFuncs = addStr(readFuncs, readFunc); + + /* generate sizes */ + if (numBytes < 4) { + char* mySizeName = UTIL_appendStr(myName, SIZE_SUFFIX); + char* myOpSizeMLI = OC_mkVarDec(mySizeName, "int"); + char* size = UTIL_itoa((int)(0 /*pow(2,(numBytes * 8))-1*/)); + char* myOpSizeML = OC_mkVarDef(mySizeName, size); + char* myopSizesMLI = addStr(opSizesMLI, myOpSizeMLI); + char* myopSizesML = addStr(opSizesML, myOpSizeML); + + free(mySizeName); free(size); free(myOpSizeMLI); free(myOpSizeML); + free(opSizesMLI); free(opSizesML); + opSizesMLI = myopSizesMLI; + opSizesML = myopSizesML; + } + free(myTypeName); free(myName); + free(opTypes); free(myOpType); + opTypes = myopTypes; + free(writeFuncs); free(func); + writeFuncs = myWriteFuncs; + free(readFuncs); free(readFunc); + readFuncs = myReadFuncs; +} + +void ocgenOpCodeType(int numBytes) +{ + char* mySizeName = UTIL_appendStr("opcode", SIZE_SUFFIX); + char* size = UTIL_itoa((int)(0 /*pow(2,(numBytes * 8))-1*/)); + char* myOpCodeSizeMLI = OC_mkVarDec(mySizeName, "int"); + char* myOpCodeSizeML = OC_mkVarDef(mySizeName, size); + char* myopSizeMLI = addLine(opSizesMLI, myOpCodeSizeMLI); + char* myopSizeML = addLine(opSizesML, myOpCodeSizeML); + char* func = ocgenWriteOpFunc("opcode", "int", numBytes); + char* myWriteFuncs = addLine(writeFuncs, func); + char* readFunc = ocgenReadOpFunc("opcode", "int", numBytes); + char* myReadFuncs = addLine(readFuncs, readFunc); + + free(size); free(mySizeName); + free(opSizesMLI); free(myOpCodeSizeMLI); + free(opSizesML); free(myOpCodeSizeML); + free(writeFuncs); free(func); + free(readFuncs); free(readFunc); + opSizesMLI = myopSizeMLI; + opSizesML = myopSizeML; + writeFuncs = myWriteFuncs; + readFuncs = myReadFuncs; +} + +static char* opMLI; +static char* opML; + +void ocgenOps() +{ + char* wordSizeName = "wordSize"; + char* wordSizeMLI = OC_mkVarDec(wordSizeName, "int"); + char* wordSize = UTIL_itoa(sizeof(void*)); + char* wordSizeML = OC_mkVarDef(wordSizeName, wordSize); + char* text; + + free(wordSize); + opMLI = addLine(opMLI, wordSizeMLI); free(wordSizeMLI); + text = addLine(opMLI, opSizesMLI); free(opMLI); free(opSizesMLI); + opMLI = addLine(text, opTypes); free(text); + + opML = addLine(opML, wordSizeML); free(wordSizeML); + text = addLine(opML, opSizesML); free(opML); free(opSizesML); + opML = addLine(text, writeFuncs); free(text); free(writeFuncs); + text = addLine(opML, readFuncs); free(opML); free(readFuncs); + opML = addLine(text, opTypes); free(text); free(opTypes); +} + +/****************************************************************************/ +/* instruction categories */ +/****************************************************************************/ +static char* instrCatWriteFunc = NULL; +static char* instrCatReadFunc = NULL; +static char* instrCatDisplayFunc = NULL; +static char* instrCatType = NULL; +static int argInd = 1; +static char* argList = NULL; + +void ocgenInstrFormat(char* opName) +{ + char *myop, *myOpName, *myFuncName, *myArgInd, *myFuncCall, *myArg, + *myArgList, *myinstrCatType, *myinstrCatWriteFunc, *myReadBody, + *myinstrCatReadFunc, * myinstrCatDisplayFunc; + + if (strcmp(opName, "P") == 0 || strcmp(opName, "WP") == 0 || + strcmp(opName, "X") == 0) return; + + //type declaration + myop = UTIL_lowerCase(opName); + myOpName = UTIL_appendStr(myop, TYPE_SUFFIX); free(myop); + if (instrCatType) { + myinstrCatType = OC_mkCrossType(instrCatType, myOpName); + free(instrCatType); free(myOpName); + instrCatType = myinstrCatType; + } else instrCatType = myOpName; + + //argument + myArgInd = UTIL_itoa(argInd); + argInd++; + myArg = UTIL_appendStr("arg", myArgInd); free(myArgInd); + //argument list + if (argList) { + myArgList = OC_mkArgList(argList, myArg); free(argList); + argList = myArgList; + } else argList = myArg; + + //write function + myFuncName = UTIL_appendStr(WRITE_PREFIX, opName); + myFuncCall = UTIL_mallocStr(strlen(myFuncName) + strlen(myArg) + 5); + strcpy(myFuncCall, myFuncName); free(myFuncName); + strcat(myFuncCall, " "); + strcat(myFuncCall, myArg); + if (instrCatWriteFunc) { + myinstrCatWriteFunc = OC_mkFuncSeq(instrCatWriteFunc, myFuncCall); + free(instrCatWriteFunc); + instrCatWriteFunc = myinstrCatWriteFunc; + free(myFuncCall); + } else instrCatWriteFunc = myFuncCall; + + //read function + myFuncName = UTIL_appendStr(READ_PREFIX, opName); + myFuncCall = UTIL_mallocStr(strlen(myFuncName) + 5); + strcpy(myFuncCall, myFuncName); free(myFuncName); + strcat(myFuncCall, " ()"); + myReadBody = OC_mkLetIn(myArg, myFuncCall); free(myFuncCall); + if (instrCatReadFunc) { + myinstrCatReadFunc = UTIL_appendStr(instrCatReadFunc, myReadBody); + free(instrCatReadFunc); + instrCatReadFunc = myinstrCatReadFunc; + free(myReadBody); + } else instrCatReadFunc = myReadBody; + + //display function + myFuncName = UTIL_appendStr(DISPLAY, opName); + myFuncCall = UTIL_mallocStr(strlen(myFuncName) + strlen(myArg) + 5); + strcpy(myFuncCall, myFuncName); free(myFuncName); + strcat(myFuncCall, " "); + strcat(myFuncCall, myArg); + if (instrCatDisplayFunc) { + myinstrCatDisplayFunc = OC_mkStrConcat(instrCatDisplayFunc, myFuncCall); + free(instrCatDisplayFunc); + instrCatDisplayFunc = myinstrCatDisplayFunc; + free(myFuncCall); + } else instrCatDisplayFunc = myFuncCall; +} + +static char* instrCatTypes; +static char* instrCatWriteFuncs; +static char* instrCatReadFuncs; +static char* instrCatDisplayFuncs; + + +void ocgenOneInstrCat(char* catName) +{ + char *myCatName, *myInstrCatType, *myInstrCatTypes, *myArgs, + *myWriteFuncName, *myWriteFunc, *myInstrCatWriteFuncs, + *myReadFuncName, *myReadFunc, *myReadFuncBody, *myInstrCatReadFuncs, + *myDisplayFuncName, *myDisplayFunc, *myInstrCatDisplayFuncs, *myArgs2, *temp; + + if (instrCatType) { + myCatName = UTIL_appendStr(INSCAT_PREFIX, catName); + myInstrCatType = OC_mkTypeDec(myCatName, instrCatType); + myInstrCatTypes = addStr(instrCatTypes, myInstrCatType); + + myArgs = UTIL_mallocStr(strlen(argList) + 5); + strcpy(myArgs, "("); + strcat(myArgs, argList); + strcat(myArgs, ")"); + + /* write function */ + myWriteFuncName = UTIL_appendStr(WRITE_PREFIX, catName); + myWriteFunc = OC_mkFunc(myWriteFuncName, myArgs, instrCatWriteFunc); + myInstrCatWriteFuncs = addStr(instrCatWriteFuncs, myWriteFunc); + + /* read function */ + myReadFuncName = UTIL_appendStr(READ_PREFIX, catName); + myArgs2 = UTIL_appendStr(INDENT, myArgs); + temp = UTIL_appendStr(instrCatReadFunc, myArgs2); free(myArgs2); + myReadFuncBody= UTIL_appendStr("\n", temp); free(temp); + myReadFunc = OC_mkFunc(myReadFuncName, "()", myReadFuncBody); + myInstrCatReadFuncs = addStr(instrCatReadFuncs, myReadFunc); + + /* display function */ + myDisplayFuncName = UTIL_appendStr(DISPLAY_PREFIX, catName); + myDisplayFunc = OC_mkFunc(myDisplayFuncName, myArgs, instrCatDisplayFunc); + myInstrCatDisplayFuncs = addStr(instrCatDisplayFuncs, myDisplayFunc); + + + free(myCatName); free(myInstrCatType); + free(instrCatType); free(instrCatTypes); + free(myWriteFuncName); free(myWriteFunc); + free(instrCatWriteFunc); free(instrCatWriteFuncs); + free(myReadFuncName); free(myReadFunc); + free(instrCatReadFunc); free(instrCatReadFuncs); + free(myDisplayFuncName); free(myDisplayFunc); + free(instrCatDisplayFunc); free(instrCatDisplayFuncs); + free(argList); + + argList = NULL; argInd = 1; + instrCatType = NULL; + instrCatWriteFunc = NULL; instrCatReadFunc = NULL; + instrCatDisplayFunc = NULL; + instrCatTypes = myInstrCatTypes; + instrCatWriteFuncs = myInstrCatWriteFuncs; + instrCatReadFuncs = myInstrCatReadFuncs; + instrCatDisplayFuncs = myInstrCatDisplayFuncs; + } +} + +static char* instrCatLength; +void ocgenInstrLength(char* varName, char* numBytes) +{ + char* myVarName = UTIL_appendStr(INSCAT_PREFIX, varName); + char* varDef = OC_mkVarDef(myVarName, numBytes); + char* myInstrCatLength = addStr(instrCatLength, varDef); + + free(myVarName); free(varDef); free(instrCatLength); + instrCatLength = myInstrCatLength; +} + +static char* instrCatMLI; +static char* instrCatML; + +void ocgenInstrCat() +{ + char* text = instrCatTypes; + char* text2 = addLine(text, "\n"); + + instrCatMLI = text; + + text = addLine(text2, instrCatWriteFuncs); + free(instrCatWriteFuncs); free(text2); + + text2 = addLine(text, instrCatReadFuncs); + free(instrCatReadFuncs); free(text); + + text = addLine(text2, instrCatDisplayFuncs); + free(instrCatDisplayFuncs); free(text2); + + instrCatML = addLine(text, instrCatLength); + free(text); free(instrCatLength); +} + +/****************************************************************************/ +/* instructions */ +/****************************************************************************/ +#define GETSIZE_PREFIX "getSize_" +#define WRITEOPCODE "writeopcode " + +static char* instructionTypes; +static char* insWriteFuncBody; +static char* insReadFuncBody; +static char* insDisplayFuncBody; +static char* insSizesDec; +static char* insSizesDef; + +static void ocgenReadFuncBody(char* opcode, char* myInsName, char* myInsLength, char* insCat, + int last) +{ + char *ins, *readArgs, *returnValue, *myReadFuncBody, *mycond, *tmp; + + if (strcmp(insCat, "X") == 0) ins = myInsName; + else { + readArgs = UTIL_appendStr(READ_PREFIX, insCat); + ins = UTIL_mallocStr(strlen(readArgs) + strlen(myInsName) + 10); + strcpy(ins, myInsName); + strcat(ins, " ("); + strcat(ins, readArgs); + strcat(ins, " ())"); + free(readArgs); + } + returnValue = UTIL_mallocStr(strlen(ins) + strlen(myInsLength) + 5); + strcpy(returnValue, "("); + strcat(returnValue, ins); + strcat(returnValue, ", "); + strcat(returnValue, myInsLength); + strcat(returnValue, ")"); + + if (last) { + tmp = UTIL_appendStr(" ", returnValue); free(returnValue); + }else { + mycond = UTIL_mallocStr(strlen(opcode) + 10); + strcpy(mycond, "opcode = "); + strcat(mycond, opcode); + tmp = OC_mkCond(mycond, returnValue); + free(mycond); free(returnValue); + } + + if (insReadFuncBody) { + myReadFuncBody = UTIL_appendStr(insReadFuncBody, tmp); + free(insReadFuncBody); free(tmp); + insReadFuncBody = myReadFuncBody; + } else insReadFuncBody = tmp; + +} + +static char* OC_mkWS(int size) +{ + int i; + char* text; + + if (size > 0) { + text = UTIL_mallocStr(size); + for (i = 0; i < size; i++) text[i]= ' '; + text[size] = '\0'; + } else text = strdup(" "); + + return text; +} + +static void ocgenDisplayFuncBody(char* pattern, char* insName, char* insLength, + char* insCat) +{ + char *displayargs, *funcBody, *myInsName, *ins, *returnValue, *insText, + *myDisplayFuncBody; + + myInsName = UTIL_appendStr(insName, OC_mkWS(25u - strlen(insName))); + insText = UTIL_mallocStr(strlen(myInsName) + 5); + strcpy(insText, "\""); + strcat(insText, myInsName); free(myInsName); + strcat(insText, "\""); + + + if (strcmp(insCat, "X") == 0) ins = insText; + else { + displayargs = UTIL_appendStr(DISPLAY_PREFIX, insCat); + ins = UTIL_mallocStr(strlen(displayargs) + strlen(insText) + 10); + strcpy(ins, insText); + strcat(ins, "^ ("); + strcat(ins, displayargs); + strcat(ins, " arg)"); + free(displayargs); free(insText); + } + + returnValue = UTIL_mallocStr(strlen(ins) + strlen(insLength) + 5); + strcpy(returnValue, "("); + strcat(returnValue, ins); + strcat(returnValue, ", "); + strcat(returnValue, insLength); + strcat(returnValue, ")"); + + funcBody = OC_mkArrow(pattern, returnValue); + free(returnValue); + + if (insDisplayFuncBody) { + myDisplayFuncBody = OC_mkDisjValueCtrs(insDisplayFuncBody, funcBody); + free(insDisplayFuncBody); free(funcBody); + insDisplayFuncBody = myDisplayFuncBody; + } else { + insDisplayFuncBody = UTIL_appendStr(INDENT2, funcBody); + free(funcBody); + } +} + + +void ocgenOneInstr(char* opcode, char* insName, char* insCat, char* insLength, + int last) +{ + char *myCatName, *myInsName, *myValueCtr, *myInstrTypes; + char *myInsSizeName, *myInsLength, *mySizeDef, *mySizeDec, *mySizeDefs, + *mySizeDecs; + char *myPattern, *myWriteOpCodeFunc, *myfuncBody, *myFunc, *myInsWriteFuncBody; + + /* value constructors for type instruction */ + myInsName = UTIL_appendStr(INS_PREFIX, insName); + if (strcmp(insCat, "X") == 0) { + myValueCtr = myInsName; + } else { + myCatName = UTIL_appendStr(INSCAT_PREFIX, insCat); + myValueCtr = OC_mkValueCtr(myInsName, myCatName); free(myCatName); + } + if (instructionTypes) { + myInstrTypes = OC_mkDisjValueCtrs(instructionTypes, myValueCtr); + free(instructionTypes); + instructionTypes = myInstrTypes; + } else instructionTypes = myValueCtr; + + /* write function body */ + myWriteOpCodeFunc = UTIL_appendStr(WRITEOPCODE, opcode); + if (strcmp(insCat, "X") == 0) { + myPattern = strdup(myInsName); + myfuncBody = myWriteOpCodeFunc; + } else { + char* myWriteArgsName = UTIL_appendStr(WRITE_PREFIX, insCat); + char* myWriteArgs = UTIL_mallocStr(strlen(myWriteArgsName) + 5); + myPattern = OC_mkStructure(myInsName, "arg"); + strcpy(myWriteArgs, myWriteArgsName); free(myWriteArgsName); + strcat(myWriteArgs, " arg"); + myfuncBody = OC_mkFuncSeq(myWriteOpCodeFunc, myWriteArgs); + free(myWriteArgs); + } + myFunc = OC_mkArrow(myPattern, myfuncBody); + free(myfuncBody); + if (insWriteFuncBody) { + myInsWriteFuncBody = OC_mkDisjValueCtrs(insWriteFuncBody, myFunc); + free(insWriteFuncBody); free(myFunc); + insWriteFuncBody = myInsWriteFuncBody; + } else { + insWriteFuncBody = UTIL_appendStr(INDENT2, myFunc); + free(myFunc); + } + /* instruction sizes */ + myInsSizeName = UTIL_appendStr(GETSIZE_PREFIX, insName); + myInsLength = UTIL_appendStr(INSCAT_PREFIX, insLength); + mySizeDef = OC_mkVarDef(myInsSizeName, myInsLength); + mySizeDec = OC_mkVarDec(myInsSizeName, "int"); free(myInsSizeName); + + mySizeDefs = addStr(insSizesDef, mySizeDef); + free(insSizesDef); free(mySizeDef); + mySizeDecs = addStr(insSizesDec, mySizeDec); + free(insSizesDec); free(mySizeDec); + + insSizesDef = mySizeDefs; + insSizesDec = mySizeDecs; + + ocgenReadFuncBody(opcode, myInsName, myInsLength, insCat, last); + ocgenDisplayFuncBody(myPattern, insName, myInsLength, insCat); + + free(myInsName); free(myInsLength); free(myPattern); +} + +#define INSTRTYPE_HEAD "type instruction = " + +#define INSTWRITEFUNC_DEF_HEAD "let writeInstruction inst =\n match inst with\n" +#define INSTWRITEFUNC_DEC "val writeInstruction : instruction -> unit\n" + +#define INSTREADFUNC_DEF_HEAD \ +"let readInstruction getKindFunc getConstantFunc = \n Bytecode.setGetKindFn getKindFunc; \n Bytecode.setGetConstantFn getConstantFunc; \n let opcode = readopcode () in\n" + +#define INSTREADFUNC_DEC \ +"val readInstruction : \n(int -> int -> Absyn.akind option) -> (int -> int -> Absyn.aconstant option) ->\n(instruction * int)\n" + +#define INSTDISPLAYFUNC_DEF_HEAD \ +"let displayInstruction inst =\n match inst with\n" +#define INSTDISPLAYFUNC_DEC \ +"val displayInstruction : instruction -> (string * int)\n" + +static char* instrMLI; +static char* instrML; + +void ocgenInstr() +{ + char* text = UTIL_appendStr(INSTRTYPE_HEAD, instructionTypes); + char* text2 = UTIL_appendStr(text, "\n\n"); + + free(instructionTypes); free(text); + + text = addLine(text2, insSizesDec); free(insSizesDec); + instrMLI = addStr(text, INSTWRITEFUNC_DEC); free(text); + text = addStr(instrMLI, INSTREADFUNC_DEC); free(instrMLI); + instrMLI = addStr(text, INSTDISPLAYFUNC_DEC); free(text); + + text = addLine(text2, insSizesDef); free(text2); free(insSizesDef); + text2 = addStr(text, INSTWRITEFUNC_DEF_HEAD); free(text); + instrML = addStr(text2, insWriteFuncBody); + free(text2); free(insWriteFuncBody); + text = addStr(instrML, "\n\n"); free(instrML); + text2 = addStr(text, INSTREADFUNC_DEF_HEAD); free(text); + instrML = addStr(text2, insReadFuncBody); + free(text2); free(insReadFuncBody); + text = addStr(instrML, "\n\n"); free(instrML); + text2 = addStr(text, INSTDISPLAYFUNC_DEF_HEAD); free(text); + instrML = addStr(text2, insDisplayFuncBody); + free(text2); free(insDisplayFuncBody); +} + +/****************************************************************************/ +/* dump files */ +/****************************************************************************/ +/* dump files */ +void ocSpitInstructionMLI(char * root) +{ + FILE* outFile; + + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "compiler/instr.mli"); + + outFile = UTIL_fopenW(filename); + fprintf(outFile, typeDefs); + fprintf(outFile, opMLI); free(opMLI); + fprintf(outFile, instrCatMLI); free(instrCatMLI); + fprintf(outFile, "\n\n"); + fprintf(outFile, instrMLI); free(instrMLI); + UTIL_fclose(outFile); + free(filename); +} + +/* dump files */ +void ocSpitInstructionML(char * root) +{ + FILE* outFile; + + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "compiler/instr.ml"); + + outFile = UTIL_fopenW(filename); + fprintf(outFile, typeDefs); free(typeDefs); + fprintf(outFile, opML); free(opML); + fprintf(outFile, instrCatML); free(instrCatML); + fprintf(outFile, instrML); free(instrML); + UTIL_fclose(outFile); + + free(filename); +} + diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.h b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.h new file mode 100644 index 000000000..58cdd02b7 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/instrgen-ocaml.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 . // +////////////////////////////////////////////////////////////////////////////// + +/*************************************************************************/ +/* functions for generating ocaml instr.mli and instr.ml */ +/*************************************************************************/ +/* include */ +void ocgenInclude(char* include); + +/* operand types */ +void ocgenOpType(char* typeName, int numBytes, char* compType); +void ocgenOpCodeType(int numBytes); +void ocgenOps(); + +/* instruction category */ +void ocgenInstrFormat(char* opName); +void ocgenOneInstrCat(char* catName); +void ocgenInstrLength(char* varName, char* numBytes); +void ocgenInstrCat(); + +/* instructions */ +void ocgenOneInstr(char* opcode, char* insName, char* insCat, char* insLength, + int last); +void ocgenInstr(); + + +/* dump files */ +void ocSpitInstructionMLI(char * root); +void ocSpitInstructionML(char * root); + diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/lex.yy.c b/src/runtime/c/teyjus/tables_gen/instrformats/lex.yy.c new file mode 100644 index 000000000..d8be9c390 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/lex.yy.c @@ -0,0 +1,1977 @@ +#line 2 "instrformats/lex.yy.c" + +#line 4 "instrformats/lex.yy.c" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 +#define YY_FLEX_SUBMINOR_VERSION 35 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include +#include +#include +#include + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have . Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#endif /* ! C99 */ + +#endif /* ! FLEXINT_H */ + +#ifdef __cplusplus + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +/* C99 requires __STDC__ to be defined as 1. */ +#if defined (__STDC__) + +#define YY_USE_CONST + +#endif /* defined (__STDC__) */ +#endif /* ! __cplusplus */ + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN (yy_start) = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START (((yy_start) - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart(yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#ifdef __ia64__ +/* On IA-64, the buffer size is 16k, not 8k. + * Moreover, YY_BUF_SIZE is 2*YY_READ_BUF_SIZE in the general case. + * Ditto for the __ia64__ case accordingly. + */ +#define YY_BUF_SIZE 32768 +#else +#define YY_BUF_SIZE 16384 +#endif /* __ia64__ */ +#endif + +/* The state buf must be large enough to hold one state per character in the main buffer. + */ +#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +extern int yyleng; + +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + + #define YY_LESS_LINENO(n) + +/* Return all but the first "n" matched characters back to the input stream. */ +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + *yy_cp = (yy_hold_char); \ + YY_RESTORE_YY_MORE_OFFSET \ + (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, (yytext_ptr) ) + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +/* Stack of input buffers. */ +static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ +static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ +static YY_BUFFER_STATE * yy_buffer_stack = 0; /**< Stack as an array. */ + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + * + * Returns the top of the stack, or NULL. + */ +#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ + ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ + : NULL) + +/* Same as previous macro, but useful when we know that the buffer stack is not + * NULL or when we need an lvalue. For internal use only. + */ +#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; +static int yy_n_chars; /* number of characters read into yy_ch_buf */ +int yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 0; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart (FILE *input_file ); +void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE yy_create_buffer (FILE *file,int size ); +void yy_delete_buffer (YY_BUFFER_STATE b ); +void yy_flush_buffer (YY_BUFFER_STATE b ); +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ); +void yypop_buffer_state (void ); + +static void yyensure_buffer_stack (void ); +static void yy_load_buffer_state (void ); +static void yy_init_buffer (YY_BUFFER_STATE b,FILE *file ); + +#define YY_FLUSH_BUFFER yy_flush_buffer(YY_CURRENT_BUFFER ) + +YY_BUFFER_STATE yy_scan_buffer (char *base,yy_size_t size ); +YY_BUFFER_STATE yy_scan_string (yyconst char *yy_str ); +YY_BUFFER_STATE yy_scan_bytes (yyconst char *bytes,int len ); + +void *yyalloc (yy_size_t ); +void *yyrealloc (void *,yy_size_t ); +void yyfree (void * ); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! YY_CURRENT_BUFFER ){ \ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! YY_CURRENT_BUFFER ){\ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer(yyin,YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) + +typedef unsigned char YY_CHAR; + +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; + +typedef int yy_state_type; + +extern int yylineno; + +int yylineno = 1; + +extern char *yytext; +#define yytext_ptr yytext + +static yy_state_type yy_get_previous_state (void ); +static yy_state_type yy_try_NUL_trans (yy_state_type current_state ); +static int yy_get_next_buffer (void ); +static void yy_fatal_error (yyconst char msg[] ); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + (yytext_ptr) = yy_bp; \ + yyleng = (size_t) (yy_cp - yy_bp); \ + (yy_hold_char) = *yy_cp; \ + *yy_cp = '\0'; \ + (yy_c_buf_p) = yy_cp; + +#define YY_NUM_RULES 25 +#define YY_END_OF_BUFFER 26 +/* This struct is not used in this scanner, + but its presence is necessary. */ +struct yy_trans_info + { + flex_int32_t yy_verify; + flex_int32_t yy_nxt; + }; +static yyconst flex_int16_t yy_accept[103] = + { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 26, 24, + 11, 1, 15, 15, 15, 16, 2, 15, 15, 15, + 15, 3, 4, 14, 19, 25, 25, 18, 25, 25, + 23, 22, 11, 15, 15, 15, 12, 13, 16, 15, + 15, 15, 15, 19, 21, 20, 18, 17, 23, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, + 15, 0, 15, 15, 15, 0, 15, 0, 6, 15, + 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, + 15, 0, 15, 0, 0, 15, 0, 15, 0, 0, + 9, 0, 15, 8, 0, 0, 10, 0, 0, 5, + + 7, 0 + } ; + +static yyconst flex_int32_t yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 4, 5, 1, 1, 6, 7, 8, 9, 1, + 1, 10, 11, 12, 13, 1, 14, 15, 16, 15, + 15, 15, 15, 15, 15, 15, 15, 17, 18, 19, + 20, 21, 1, 22, 23, 24, 25, 26, 27, 24, + 28, 24, 29, 24, 24, 30, 31, 32, 33, 34, + 24, 35, 36, 37, 38, 24, 24, 39, 40, 24, + 41, 1, 42, 43, 44, 1, 24, 24, 24, 24, + + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 45, 1, 46, 47, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst flex_int32_t yy_meta[48] = + { 0, + 1, 1, 2, 1, 1, 1, 2, 1, 1, 3, + 1, 1, 1, 4, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 5, 1 + } ; + +static yyconst flex_int16_t yy_base[109] = + { 0, + 0, 0, 45, 46, 40, 41, 146, 145, 190, 193, + 54, 193, 56, 0, 91, 89, 193, 166, 156, 164, + 152, 193, 193, 193, 0, 171, 177, 0, 169, 193, + 0, 193, 104, 0, 0, 0, 0, 0, 94, 152, + 145, 141, 86, 0, 193, 193, 0, 193, 0, 149, + 141, 173, 143, 140, 130, 138, 139, 145, 147, 140, + 93, 134, 140, 134, 149, 139, 138, 135, 0, 135, + 111, 131, 113, 113, 126, 99, 91, 98, 103, 88, + 97, 96, 89, 89, 80, 87, 90, 85, 90, 81, + 0, 81, 76, 193, 80, 67, 0, 38, 17, 193, + + 193, 193, 131, 136, 141, 146, 151, 156 + } ; + +static yyconst flex_int16_t yy_def[109] = + { 0, + 102, 1, 103, 103, 104, 104, 105, 105, 102, 102, + 102, 102, 102, 13, 13, 102, 102, 13, 13, 13, + 13, 102, 102, 102, 106, 102, 102, 107, 102, 102, + 108, 102, 102, 13, 13, 13, 13, 13, 102, 13, + 13, 13, 13, 106, 102, 102, 107, 102, 108, 13, + 13, 13, 13, 13, 13, 13, 102, 13, 13, 13, + 13, 102, 13, 13, 13, 102, 13, 102, 13, 13, + 13, 102, 13, 102, 13, 13, 102, 13, 102, 102, + 13, 102, 13, 102, 102, 13, 102, 13, 102, 102, + 13, 102, 13, 102, 102, 102, 13, 102, 102, 102, + + 102, 0, 102, 102, 102, 102, 102, 102 + } ; + +static yyconst flex_int16_t yy_nxt[241] = + { 0, + 10, 11, 12, 11, 13, 13, 13, 13, 13, 14, + 13, 13, 13, 15, 16, 16, 13, 17, 13, 13, + 13, 13, 13, 13, 18, 13, 13, 13, 19, 13, + 20, 13, 21, 13, 13, 13, 13, 13, 13, 13, + 22, 23, 13, 13, 24, 10, 13, 12, 12, 29, + 29, 26, 26, 30, 30, 33, 101, 33, 27, 27, + 34, 34, 34, 34, 34, 35, 34, 34, 34, 34, + 36, 36, 34, 100, 34, 34, 34, 34, 36, 36, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, + 36, 36, 36, 36, 36, 36, 66, 37, 34, 34, + + 38, 99, 34, 39, 39, 33, 98, 33, 39, 39, + 53, 97, 54, 96, 95, 94, 93, 92, 91, 90, + 89, 88, 87, 86, 85, 84, 83, 82, 81, 80, + 67, 25, 25, 25, 25, 25, 28, 28, 28, 28, + 28, 31, 31, 31, 31, 31, 44, 79, 44, 78, + 44, 47, 47, 77, 76, 47, 49, 49, 49, 49, + 75, 74, 73, 72, 71, 70, 69, 68, 65, 64, + 63, 62, 61, 60, 59, 58, 57, 56, 55, 52, + 51, 50, 48, 46, 45, 43, 42, 41, 40, 102, + 32, 32, 9, 102, 102, 102, 102, 102, 102, 102, + + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102 + } ; + +static yyconst flex_int16_t yy_chk[241] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 3, 4, 5, + 6, 3, 4, 5, 6, 11, 99, 11, 3, 4, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 98, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 61, 15, 13, 13, + + 15, 96, 13, 16, 16, 33, 95, 33, 39, 39, + 43, 93, 43, 92, 90, 89, 88, 87, 86, 85, + 84, 83, 82, 81, 80, 79, 78, 77, 76, 75, + 61, 103, 103, 103, 103, 103, 104, 104, 104, 104, + 104, 105, 105, 105, 105, 105, 106, 74, 106, 73, + 106, 107, 107, 72, 71, 107, 108, 108, 108, 108, + 70, 68, 67, 66, 65, 64, 63, 62, 60, 59, + 58, 57, 56, 55, 54, 53, 52, 51, 50, 42, + 41, 40, 29, 27, 26, 21, 20, 19, 18, 9, + 8, 7, 102, 102, 102, 102, 102, 102, 102, 102, + + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +extern int yy_flex_debug; +int yy_flex_debug = 0; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *yytext; +#line 1 "instrformats/instrformats.l" +#line 2 "instrformats/instrformats.l" +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +#include "y.tab.h" +#include +#include + +static int commentLev = 0; + +#line 571 "instrformats/lex.yy.c" + +#define INITIAL 0 +#define COMMENT 1 +#define COMMENT2 2 +#define INCLUDE 3 + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +static int yy_init_globals (void ); + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int yylex_destroy (void ); + +int yyget_debug (void ); + +void yyset_debug (int debug_flag ); + +YY_EXTRA_TYPE yyget_extra (void ); + +void yyset_extra (YY_EXTRA_TYPE user_defined ); + +FILE *yyget_in (void ); + +void yyset_in (FILE * in_str ); + +FILE *yyget_out (void ); + +void yyset_out (FILE * out_str ); + +int yyget_leng (void ); + +char *yyget_text (void ); + +int yyget_lineno (void ); + +void yyset_lineno (int line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap (void ); +#else +extern int yywrap (void ); +#endif +#endif + + static void yyunput (int c,char *buf_ptr ); + +#ifndef yytext_ptr +static void yy_flex_strncpy (char *,yyconst char *,int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * ); +#endif + +#ifndef YY_NO_INPUT + +#ifdef __cplusplus +static int yyinput (void ); +#else +static int input (void ); +#endif + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#ifdef __ia64__ +/* On IA-64, the buffer size is 16k, not 8k */ +#define YY_READ_BUF_SIZE 16384 +#else +#define YY_READ_BUF_SIZE 8192 +#endif /* __ia64__ */ +#endif + +/* Copy whatever the last rule matched to the standard output. */ +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO do { if (fwrite( yytext, yyleng, 1, yyout )) {} } while (0) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ + { \ + int c = '*'; \ + size_t n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else \ + { \ + errno=0; \ + while ( (result = fread(buf, 1, max_size, yyin))==0 && ferror(yyin)) \ + { \ + if( errno != EINTR) \ + { \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + break; \ + } \ + errno=0; \ + clearerr(yyin); \ + } \ + }\ +\ + +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* end tables serialization structures and prototypes */ + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int yylex (void); + +#define YY_DECL int yylex (void) +#endif /* !YY_DECL */ + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + YY_USER_ACTION + +/** The main scanner function which does all the work. + */ +YY_DECL +{ + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 41 "instrformats/instrformats.l" + +#line 763 "instrformats/lex.yy.c" + + if ( !(yy_init) ) + { + (yy_init) = 1; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! (yy_start) ) + (yy_start) = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! YY_CURRENT_BUFFER ) { + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_load_buffer_state( ); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = (yy_c_buf_p); + + /* Support of yytext. */ + *yy_cp = (yy_hold_char); + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = (yy_start); +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 103 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 193 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + +do_action: /* This label is used only to access EOF actions. */ + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = (yy_hold_char); + yy_cp = (yy_last_accepting_cpos); + yy_current_state = (yy_last_accepting_state); + goto yy_find_action; + +case 1: +/* rule 1 can match eol */ +YY_RULE_SETUP +#line 42 "instrformats/instrformats.l" +{continue; } + YY_BREAK +case 2: +YY_RULE_SETUP +#line 43 "instrformats/instrformats.l" +{return SEMICOLON; } + YY_BREAK +case 3: +YY_RULE_SETUP +#line 44 "instrformats/instrformats.l" +{return LBRACKET; } + YY_BREAK +case 4: +YY_RULE_SETUP +#line 45 "instrformats/instrformats.l" +{return RBRACKET; } + YY_BREAK +case 5: +YY_RULE_SETUP +#line 46 "instrformats/instrformats.l" +{return OPTYPES; } + YY_BREAK +case 6: +YY_RULE_SETUP +#line 47 "instrformats/instrformats.l" +{return OPCODE; } + YY_BREAK +case 7: +YY_RULE_SETUP +#line 48 "instrformats/instrformats.l" +{return INSTRCAT; } + YY_BREAK +case 8: +YY_RULE_SETUP +#line 49 "instrformats/instrformats.l" +{return MAXOPERAND; } + YY_BREAK +case 9: +YY_RULE_SETUP +#line 50 "instrformats/instrformats.l" +{return CALL_I1_LEN; } + YY_BREAK +case 10: +YY_RULE_SETUP +#line 51 "instrformats/instrformats.l" +{return INSTRUCTIONS; } + YY_BREAK +case 11: +YY_RULE_SETUP +#line 52 "instrformats/instrformats.l" +{continue; } + YY_BREAK +case 12: +YY_RULE_SETUP +#line 53 "instrformats/instrformats.l" +{commentLev = 1; BEGIN(COMMENT); continue; } + YY_BREAK +case 13: +YY_RULE_SETUP +#line 54 "instrformats/instrformats.l" +{BEGIN(COMMENT2); continue; } + YY_BREAK +case 14: +YY_RULE_SETUP +#line 55 "instrformats/instrformats.l" +{BEGIN(INCLUDE); continue; } + YY_BREAK +case 15: +YY_RULE_SETUP +#line 56 "instrformats/instrformats.l" +{yylval.name = strdup(yytext); return ID; } + YY_BREAK +case 16: +YY_RULE_SETUP +#line 57 "instrformats/instrformats.l" +{yylval.isval.ival = atoi(yytext); + yylval.isval.sval = strdup(yytext); + return NUM; } + YY_BREAK +case 17: +YY_RULE_SETUP +#line 60 "instrformats/instrformats.l" +{BEGIN(INITIAL); continue; } + YY_BREAK +case 18: +/* rule 18 can match eol */ +YY_RULE_SETUP +#line 61 "instrformats/instrformats.l" +{yylval.text = strdup(yytext); return STRING; } + YY_BREAK +case 19: +YY_RULE_SETUP +#line 63 "instrformats/instrformats.l" +{continue; } + YY_BREAK +case 20: +YY_RULE_SETUP +#line 64 "instrformats/instrformats.l" +{commentLev++; continue; } + YY_BREAK +case 21: +YY_RULE_SETUP +#line 65 "instrformats/instrformats.l" +{commentLev--; + if (!commentLev) BEGIN(INITIAL); continue; } + YY_BREAK +case 22: +YY_RULE_SETUP +#line 67 "instrformats/instrformats.l" +{BEGIN(INITIAL); continue; } + YY_BREAK +case 23: +/* rule 23 can match eol */ +YY_RULE_SETUP +#line 68 "instrformats/instrformats.l" +{yylval.text = strdup(yytext); return STRING2; } + YY_BREAK +case 24: +YY_RULE_SETUP +#line 69 "instrformats/instrformats.l" +{return ERROR; } + YY_BREAK +case 25: +YY_RULE_SETUP +#line 70 "instrformats/instrformats.l" +ECHO; + YY_BREAK +#line 977 "instrformats/lex.yy.c" +case YY_STATE_EOF(INITIAL): +case YY_STATE_EOF(COMMENT): +case YY_STATE_EOF(COMMENT2): +case YY_STATE_EOF(INCLUDE): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = (yy_hold_char); + YY_RESTORE_YY_MORE_OFFSET + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between YY_CURRENT_BUFFER and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + YY_CURRENT_BUFFER_LVALUE->yy_input_file = yyin; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++(yy_c_buf_p); + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = (yy_c_buf_p); + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_END_OF_FILE: + { + (yy_did_buffer_switch_on_eof) = 0; + + if ( yywrap( ) ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = + (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + (yy_c_buf_p) = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ +} /* end of yylex */ + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ +static int yy_get_next_buffer (void) +{ + register char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; + register char *source = (yytext_ptr); + register int number_to_move, i; + int ret_val; + + if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr)) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; + + else + { + int num_to_read = + YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = YY_CURRENT_BUFFER; + + int yy_c_buf_p_offset = + (int) ((yy_c_buf_p) - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + int new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + yyrealloc((void *) b->yy_ch_buf,b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + (yy_c_buf_p) = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = YY_CURRENT_BUFFER_LVALUE->yy_buf_size - + number_to_move - 1; + + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), + (yy_n_chars), (size_t) num_to_read ); + + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + if ( (yy_n_chars) == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart(yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + if ((yy_size_t) ((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { + /* Extend the array by 50%, plus the number we really need. */ + yy_size_t new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) yyrealloc((void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf,new_size ); + if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); + } + + (yy_n_chars) += number_to_move; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; + + (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; + + return ret_val; +} + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + + static yy_state_type yy_get_previous_state (void) +{ + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = (yy_start); + + for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 103 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; +} + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) +{ + register int yy_is_jam; + register char *yy_cp = (yy_c_buf_p); + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + (yy_last_accepting_state) = yy_current_state; + (yy_last_accepting_cpos) = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 103 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 102); + + return yy_is_jam ? 0 : yy_current_state; +} + + static void yyunput (int c, register char * yy_bp ) +{ + register char *yy_cp; + + yy_cp = (yy_c_buf_p); + + /* undo effects of setting up yytext */ + *yy_cp = (yy_hold_char); + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register int number_to_move = (yy_n_chars) + 2; + register char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; + register char *source = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; + + while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_buf_size; + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + (yytext_ptr) = yy_bp; + (yy_hold_char) = *yy_cp; + (yy_c_buf_p) = yy_cp; +} + +#ifndef YY_NO_INPUT +#ifdef __cplusplus + static int yyinput (void) +#else + static int input (void) +#endif + +{ + int c; + + *(yy_c_buf_p) = (yy_hold_char); + + if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + /* This was really a NUL. */ + *(yy_c_buf_p) = '\0'; + + else + { /* need more input */ + int offset = (yy_c_buf_p) - (yytext_ptr); + ++(yy_c_buf_p); + + switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart(yyin ); + + /*FALLTHROUGH*/ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap( ) ) + return EOF; + + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = (yytext_ptr) + offset; + break; + } + } + } + + c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ + *(yy_c_buf_p) = '\0'; /* preserve yytext */ + (yy_hold_char) = *++(yy_c_buf_p); + + return c; +} +#endif /* ifndef YY_NO_INPUT */ + +/** Immediately switch to a different input stream. + * @param input_file A readable stream. + * + * @note This function does not reset the start condition to @c INITIAL . + */ + void yyrestart (FILE * input_file ) +{ + + if ( ! YY_CURRENT_BUFFER ){ + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer(yyin,YY_BUF_SIZE ); + } + + yy_init_buffer(YY_CURRENT_BUFFER,input_file ); + yy_load_buffer_state( ); +} + +/** Switch to a different input buffer. + * @param new_buffer The new input buffer. + * + */ + void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ) +{ + + /* TODO. We should be able to replace this entire function body + * with + * yypop_buffer_state(); + * yypush_buffer_state(new_buffer); + */ + yyensure_buffer_stack (); + if ( YY_CURRENT_BUFFER == new_buffer ) + return; + + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + YY_CURRENT_BUFFER_LVALUE = new_buffer; + yy_load_buffer_state( ); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + (yy_did_buffer_switch_on_eof) = 1; +} + +static void yy_load_buffer_state (void) +{ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; + yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file; + (yy_hold_char) = *(yy_c_buf_p); +} + +/** Allocate and initialize an input buffer state. + * @param file A readable stream. + * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. + * + * @return the allocated buffer state. + */ + YY_BUFFER_STATE yy_create_buffer (FILE * file, int size ) +{ + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yyalloc(b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer(b,file ); + + return b; +} + +/** Destroy the buffer. + * @param b a buffer created with yy_create_buffer() + * + */ + void yy_delete_buffer (YY_BUFFER_STATE b ) +{ + + if ( ! b ) + return; + + if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ + YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yyfree((void *) b->yy_ch_buf ); + + yyfree((void *) b ); +} + +#ifndef __cplusplus +extern int isatty (int ); +#endif /* __cplusplus */ + +/* Initializes or reinitializes a buffer. + * This function is sometimes called more than once on the same buffer, + * such as during a yyrestart() or at EOF. + */ + static void yy_init_buffer (YY_BUFFER_STATE b, FILE * file ) + +{ + int oerrno = errno; + + yy_flush_buffer(b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + + /* If b is the current buffer, then yy_init_buffer was _probably_ + * called from yyrestart() or through yy_get_next_buffer. + * In that case, we don't want to reset the lineno or column. + */ + if (b != YY_CURRENT_BUFFER){ + b->yy_bs_lineno = 1; + b->yy_bs_column = 0; + } + + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; + + errno = oerrno; +} + +/** Discard all buffered characters. On the next scan, YY_INPUT will be called. + * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. + * + */ + void yy_flush_buffer (YY_BUFFER_STATE b ) +{ + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == YY_CURRENT_BUFFER ) + yy_load_buffer_state( ); +} + +/** Pushes the new state onto the stack. The new state becomes + * the current state. This function will allocate the stack + * if necessary. + * @param new_buffer The new state. + * + */ +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ) +{ + if (new_buffer == NULL) + return; + + yyensure_buffer_stack(); + + /* This block is copied from yy_switch_to_buffer. */ + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + /* Only push if top exists. Otherwise, replace top. */ + if (YY_CURRENT_BUFFER) + (yy_buffer_stack_top)++; + YY_CURRENT_BUFFER_LVALUE = new_buffer; + + /* copied from yy_switch_to_buffer. */ + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; +} + +/** Removes and deletes the top of the stack, if present. + * The next element becomes the new top. + * + */ +void yypop_buffer_state (void) +{ + if (!YY_CURRENT_BUFFER) + return; + + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + if ((yy_buffer_stack_top) > 0) + --(yy_buffer_stack_top); + + if (YY_CURRENT_BUFFER) { + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; + } +} + +/* Allocates the stack if it does not exist. + * Guarantees space for at least one push. + */ +static void yyensure_buffer_stack (void) +{ + int num_to_alloc; + + if (!(yy_buffer_stack)) { + + /* First allocation is just for 2 elements, since we don't know if this + * scanner will even need a stack. We use 2 instead of 1 to avoid an + * immediate realloc on the next call. + */ + num_to_alloc = 1; + (yy_buffer_stack) = (struct yy_buffer_state**)yyalloc + (num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); + + (yy_buffer_stack_max) = num_to_alloc; + (yy_buffer_stack_top) = 0; + return; + } + + if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ + + /* Increase the buffer to prepare for a possible push. */ + int grow_size = 8 /* arbitrary grow size */; + + num_to_alloc = (yy_buffer_stack_max) + grow_size; + (yy_buffer_stack) = (struct yy_buffer_state**)yyrealloc + ((yy_buffer_stack), + num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + /* zero only the new slots.*/ + memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); + (yy_buffer_stack_max) = num_to_alloc; + } +} + +/** Setup the input buffer state to scan directly from a user-specified character buffer. + * @param base the character buffer + * @param size the size in bytes of the character buffer + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_buffer (char * base, yy_size_t size ) +{ + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yyalloc(sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer(b ); + + return b; +} + +/** Setup the input buffer state to scan a string. The next call to yylex() will + * scan from a @e copy of @a str. + * @param yystr a NUL-terminated string to scan + * + * @return the newly allocated buffer state object. + * @note If you want to scan bytes that may contain NUL values, then use + * yy_scan_bytes() instead. + */ +YY_BUFFER_STATE yy_scan_string (yyconst char * yystr ) +{ + + return yy_scan_bytes(yystr,strlen(yystr) ); +} + +/** Setup the input buffer state to scan the given bytes. The next call to yylex() will + * scan from a @e copy of @a bytes. + * @param yybytes the byte buffer to scan + * @param _yybytes_len the number of bytes in the buffer pointed to by @a bytes. + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_bytes (yyconst char * yybytes, int _yybytes_len ) +{ + YY_BUFFER_STATE b; + char *buf; + yy_size_t n; + int i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = _yybytes_len + 2; + buf = (char *) yyalloc(n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < _yybytes_len; ++i ) + buf[i] = yybytes[i]; + + buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer(buf,n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; +} + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +static void yy_fatal_error (yyconst char* msg ) +{ + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); +} + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + yytext[yyleng] = (yy_hold_char); \ + (yy_c_buf_p) = yytext + yyless_macro_arg; \ + (yy_hold_char) = *(yy_c_buf_p); \ + *(yy_c_buf_p) = '\0'; \ + yyleng = yyless_macro_arg; \ + } \ + while ( 0 ) + +/* Accessor methods (get/set functions) to struct members. */ + +/** Get the current line number. + * + */ +int yyget_lineno (void) +{ + + return yylineno; +} + +/** Get the input stream. + * + */ +FILE *yyget_in (void) +{ + return yyin; +} + +/** Get the output stream. + * + */ +FILE *yyget_out (void) +{ + return yyout; +} + +/** Get the length of the current token. + * + */ +int yyget_leng (void) +{ + return yyleng; +} + +/** Get the current token. + * + */ + +char *yyget_text (void) +{ + return yytext; +} + +/** Set the current line number. + * @param line_number + * + */ +void yyset_lineno (int line_number ) +{ + + yylineno = line_number; +} + +/** Set the input stream. This does not discard the current + * input buffer. + * @param in_str A readable stream. + * + * @see yy_switch_to_buffer + */ +void yyset_in (FILE * in_str ) +{ + yyin = in_str ; +} + +void yyset_out (FILE * out_str ) +{ + yyout = out_str ; +} + +int yyget_debug (void) +{ + return yy_flex_debug; +} + +void yyset_debug (int bdebug ) +{ + yy_flex_debug = bdebug ; +} + +static int yy_init_globals (void) +{ + /* Initialization is the same as for the non-reentrant scanner. + * This function is called from yylex_destroy(), so don't allocate here. + */ + + (yy_buffer_stack) = 0; + (yy_buffer_stack_top) = 0; + (yy_buffer_stack_max) = 0; + (yy_c_buf_p) = (char *) 0; + (yy_init) = 0; + (yy_start) = 0; + +/* Defined in main.c */ +#ifdef YY_STDINIT + yyin = stdin; + yyout = stdout; +#else + yyin = (FILE *) 0; + yyout = (FILE *) 0; +#endif + + /* For future reference: Set errno on error, since we are called by + * yylex_init() + */ + return 0; +} + +/* yylex_destroy is for both reentrant and non-reentrant scanners. */ +int yylex_destroy (void) +{ + + /* Pop the buffer stack, destroying each element. */ + while(YY_CURRENT_BUFFER){ + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + yypop_buffer_state(); + } + + /* Destroy the stack itself. */ + yyfree((yy_buffer_stack) ); + (yy_buffer_stack) = NULL; + + /* Reset the globals. This is important in a non-reentrant scanner so the next time + * yylex() is called, initialization will occur. */ + yy_init_globals( ); + + return 0; +} + +/* + * Internal utility routines. + */ + +#ifndef yytext_ptr +static void yy_flex_strncpy (char* s1, yyconst char * s2, int n ) +{ + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; +} +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (yyconst char * s ) +{ + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; +} +#endif + +void *yyalloc (yy_size_t size ) +{ + return (void *) malloc( size ); +} + +void *yyrealloc (void * ptr, yy_size_t size ) +{ + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); +} + +void yyfree (void * ptr ) +{ + free( (char *) ptr ); /* see yyrealloc() for (char *) cast */ +} + +#define YYTABLES_NAME "yytables" + +#line 70 "instrformats/instrformats.l" diff --git a/src/runtime/c/teyjus/tables_gen/instrformats/y.tab.h b/src/runtime/c/teyjus/tables_gen/instrformats/y.tab.h new file mode 100644 index 000000000..cff620e11 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/instrformats/y.tab.h @@ -0,0 +1,104 @@ + +/* A Bison parser, made by GNU Bison 2.4.1. */ + +/* Skeleton interface for Bison's Yacc-like parsers in C + + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. + + This program 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. + + This program 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 this program. If not, see . */ + +/* As a special exception, you may create a larger work that contains + part or all of the Bison parser skeleton and distribute that work + under terms of your choice, so long as that work isn't itself a + parser generator using the skeleton or a modified version thereof + as a parser skeleton. Alternatively, if you modify or redistribute + the parser skeleton itself, you may (at your option) remove this + special exception, which will cause the skeleton and the resulting + Bison output files to be licensed under the GNU General Public + License without this special exception. + + This special exception was added by the Free Software Foundation in + version 2.2 of Bison. */ + + +/* Tokens. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + /* Put the tokens into the symbol table, so that GDB and other debuggers + know about them. */ + enum yytokentype { + OPTYPES = 258, + INSTRCAT = 259, + INSTRUCTIONS = 260, + OPCODE = 261, + MAXOPERAND = 262, + CALL_I1_LEN = 263, + SEMICOLON = 264, + ERROR = 265, + LBRACKET = 266, + RBRACKET = 267, + ID = 268, + NUM = 269, + STRING = 270, + STRING2 = 271 + }; +#endif +/* Tokens. */ +#define OPTYPES 258 +#define INSTRCAT 259 +#define INSTRUCTIONS 260 +#define OPCODE 261 +#define MAXOPERAND 262 +#define CALL_I1_LEN 263 +#define SEMICOLON 264 +#define ERROR 265 +#define LBRACKET 266 +#define RBRACKET 267 +#define ID 268 +#define NUM 269 +#define STRING 270 +#define STRING2 271 + + + + +#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED +typedef union YYSTYPE +{ + +/* Line 1676 of yacc.c */ +#line 38 "instrformats/instrformats.y" + + char* name; + char* text; + struct + { + int ival; + char* sval; + } isval; + + + +/* Line 1676 of yacc.c */ +#line 96 "instrformats/y.tab.h" +} YYSTYPE; +# define YYSTYPE_IS_TRIVIAL 1 +# define yystype YYSTYPE /* obsolescent; will be withdrawn */ +# define YYSTYPE_IS_DECLARED 1 +#endif + +extern YYSTYPE yylval; + + diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/ccode.c b/src/runtime/c/teyjus/tables_gen/pervasives/ccode.c new file mode 100644 index 000000000..dbdb047e5 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/ccode.c @@ -0,0 +1,1024 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* ocamlcode.c. */ +/* This file defines auxiliary functions in making pervasives.h and */ +/* pervasives.c. */ +/* Since space and time efficiency is not an important concern in the */ +/* system source code generation phase, the code here is structured in the */ +/* way for the convenience of making changes on pervasive.mli{ml}. */ +/***************************************************************************/ +#include +#include +#include + +#include "ccode.h" +#include "types.h" +#include "../util/util.h" //to be modified + +/**************************************************************************/ +/* Functions for making various language constructs */ +/**************************************************************************/ +/* // */ +char* C_mkOneLineComments(char* comments) +{ + size_t length = strlen(comments) + 5; + char* commentsText = UTIL_mallocStr(length); + + strcpy(commentsText, "// "); + strcat(commentsText, comments); + + return commentsText; +} + +/* = */ +char* C_mkAssign(char* varName, char* varValue) +{ + size_t length = strlen(varName) + strlen(varValue) + 5; + char* assign = UTIL_mallocStr(length); + + strcpy(assign, varName); + strcat(assign, " = "); + strcat(assign, varValue); + + return assign; +} + +/* #define */ +char* C_mkDefine(char* macroName, char* macroValue) +{ + size_t length = strlen(macroName) + strlen(macroValue) + 10; + char* def = UTIL_mallocStr(length); + + strcpy(def, "#define "); + strcat(def, macroName); + strcat(def, " "); + strcat(def, macroValue); + + return def; +} + +/* enum \n {\n } */ +char* C_mkEnum(char* typeName, char* body) +{ + size_t length = strlen(typeName) + strlen(body) + 15; + char* enumText = UTIL_mallocStr(length); + + strcpy(enumText, "enum "); + strcat(enumText, typeName); + strcat(enumText, "\n{\n"); + strcat(enumText, body); + strcat(enumText, "}"); + + return enumText; +} + +/* typedef ; \n\n */ +char* C_mkTypeDef(char* typeStr, char* typeName) +{ + size_t length = strlen(typeStr) + strlen(typeName) + 15; + char* typeDefText = UTIL_mallocStr(length); + + strcpy(typeDefText, "typedef "); + strcat(typeDefText, typeStr); + strcat(typeDefText, " "); + strcat(typeDefText, typeName); + strcat(typeDefText, ";\n\n"); + + return typeDefText; +} + +/********************************************************************/ +/* Names */ +/********************************************************************/ +#define C_INDENT " " + +#define C_PREFIX "PERV_" +#define C_SUFFIX "_INDEX" + +#define C_NUMKINDS "PERV_KIND_NUM" +#define C_NUMTYSKELS "PERV_TY_SKEL_NUM" +#define C_NUMCONSTS "PERV_CONST_NUM" + +#define C_TY_KINDIND "PERV_KindIndexType" +#define C_TY_CONSTIND "PERV_ConstIndexType" + + +/* PERV__INDEX */ +char* C_mkIndexName(char* name) +{ + char* nameUC = UTIL_upperCase(name); + size_t length = strlen(nameUC) + strlen(C_PREFIX) + strlen(C_SUFFIX); + char* indexName = UTIL_mallocStr(length); + + strcpy(indexName, C_PREFIX); + strcat(indexName, nameUC); free(nameUC); + strcat(indexName, C_SUFFIX); + + return indexName; +} + +/* PERV_ */ +char* C_mkIndexName2(char* name) +{ + char* nameUC = UTIL_upperCase(name); + size_t length = strlen(nameUC) + strlen(C_PREFIX); + char* indexName = UTIL_mallocStr(length); + + strcpy(indexName, C_PREFIX); + strcat(indexName, nameUC); free(nameUC); + + return indexName; +} + +/* + //comments \n + PERV__INDEX = +*/ +char* C_mkIndex(char* name, char* indexNum, char* comments) +{ + char* commentText = (comments) ? C_mkOneLineComments(comments) : NULL; + char* varName = C_mkIndexName(name); + char* assign = C_mkAssign(varName, indexNum); + size_t length = ((commentText) ? strlen(commentText) + strlen(C_INDENT): 0) + + strlen(assign) + strlen(C_INDENT) + 5; + char* index = UTIL_mallocStr(length); + + free(varName); + strcpy(index, C_INDENT); + if (commentText) { + strcat(index, commentText); strcat(index, "\n"); + strcat(index, C_INDENT); free(commentText); + } + strcat(index, assign); free(assign); + + return index; +} + +/* + PERV_ = +*/ +char* C_mkIndex2(char* name, char* indexNum) +{ + char* varName = C_mkIndexName2(name); + char* assign = C_mkAssign(varName, indexNum); + char* index = UTIL_mallocStr(strlen(assign) + strlen(C_INDENT)); + + free(varName); + strcpy(index, C_INDENT); + strcat(index, assign); free(assign); + + return index; +} + +/* // empty */ +char* C_mkEmptyComments() +{ + size_t length = strlen(C_INDENT) + 10; + char* text = UTIL_mallocStr(length); + + strcpy(text, C_INDENT); + strcat(text, "// empty\n"); + + return text; +} + +/********************************************************************/ +/* Kind relevant components */ +/********************************************************************/ +/***************************************************************/ +/* pervasives.h */ +/***************************************************************/ +#define C_NUMKINDS_COMMENTS "//total number of pervasive kinds\n" + +/* + //total number of pervasive kinds \n" + #define PERV_KIND_NUM \n +*/ +char* C_mkNumKinds(char* num) +{ + char* def = C_mkDefine(C_NUMKINDS, num); + size_t length = strlen(def) + strlen(C_NUMKINDS_COMMENTS) + 5; + char* numKinds = UTIL_mallocStr(length); + + strcpy(numKinds, C_NUMKINDS_COMMENTS); + strcat(numKinds, def); free(def); + strcat(numKinds, "\n\n"); + + return numKinds; +} + +#define C_KINDINDEX_COMMENTS \ +"//indices for predefined sorts and type constructors\n" +/* + //indices for predefined sorts and type constructors\n" + typedef enum PERV_KindIndexType \n + { } PERV_KindIndexType; \n +*/ +char* C_mkKindIndexType(char* body) +{ + char* enumText = C_mkEnum(C_TY_KINDIND, body); + char* typeDefText = C_mkTypeDef(enumText, C_TY_KINDIND); + size_t length = strlen(typeDefText) + strlen(C_KINDINDEX_COMMENTS); + char* kindIndexType = UTIL_mallocStr(length); + + strcpy(kindIndexType, C_KINDINDEX_COMMENTS); + strcat(kindIndexType, typeDefText); + free(enumText); free(typeDefText); + + return kindIndexType; +} + +//comments +#define C_KIND_COMMENTS \ +"/****************************************************************************/\n/* PERVASIVE KIND */ \n/****************************************************************************/ \n" +//PERV_KindData +#define C_KINDDATA_TYPE_DEF \ +"//pervasive kind data type \ntypedef struct \n{ \n char *name; \n TwoBytes arity; \n} PERV_KindData; \n\n" + +//PERV_kindDataTab +#define C_KINDDATATAB_DEC \ +"//pervasive kind data table (array) \nextern PERV_KindData PERV_kindDataTab[PERV_KIND_NUM]; \n\n" + +//PERV_genKindData +#define C_GETKINDDATA_DEC \ +"//pervasive kind data access function \nPERV_KindData PERV_getKindData(int index); \n\n" + +//PERV_copyKindDataTab +#define C_COPYKINDDATATAB_DEC \ +"//pervasive kind table copy function (used in module space initialization) \n//this functiion relies on the assumption that the pervasive kind data \n//has the same structure as that of the run-time kind symbol table entries. \nvoid PERV_copyKindDataTab(PERV_KindData* dst); \n\n" +char* C_mkKindH(char* kindIndexType, char* numKinds) +{ + size_t length = strlen(C_KIND_COMMENTS) + strlen(kindIndexType) + + strlen(numKinds) + strlen(C_KINDDATA_TYPE_DEF) + + strlen(C_KINDDATATAB_DEC) + strlen(C_GETKINDDATA_DEC) + + strlen(C_COPYKINDDATATAB_DEC); + char* kindH = UTIL_mallocStr(length); + + strcpy(kindH, C_KIND_COMMENTS); + strcat(kindH, kindIndexType); + strcat(kindH, numKinds); + strcat(kindH, C_KINDDATA_TYPE_DEF); + strcat(kindH, C_KINDDATATAB_DEC); + strcat(kindH, C_GETKINDDATA_DEC); + strcat(kindH, C_COPYKINDDATATAB_DEC); + + return kindH; +} + +/***************************************************************/ +/* pervasives.c */ +/***************************************************************/ +/* + //comments \n + {"", } +*/ +char* C_mkKindTabEntry(char* name, char* arity, char* comments) +{ + char* commentText = (comments) ? C_mkOneLineComments(comments) : NULL; + size_t length = ((commentText) ? strlen(commentText) + strlen(C_INDENT): 0) + + strlen(name) + strlen(arity) + strlen(C_INDENT)*2 + 10; + char* entry = UTIL_mallocStr(length); + + strcpy(entry, C_INDENT); + if (commentText) { + strcat(entry, commentText); strcat(entry, "\n"); + strcat(entry, C_INDENT); free(commentText); + } + strcat(entry, "{\""); + strcat(entry, name); + strcat(entry, "\","); + strcat(entry, C_INDENT); + strcat(entry, arity); + strcat(entry, "}"); + + return entry; +} + +#define C_KIND_TAB_BEG \ +"//pervasive kind data table (array) \nPERV_KindData PERV_kindDataTab[PERV_KIND_NUM] = { \n //name, arity \n" +#define C_KIND_TAB_END "};\n\n" + +/* + //pervasive kind data table (array) + PERV_KindData PERV_kindDataTab[PERV_KIND_NUM] = { \n body \n};\n +*/ +char* C_mkKindTab(char* body) +{ + size_t length = strlen(C_KIND_TAB_BEG) + strlen(C_KIND_TAB_END) + strlen(body); + char* kindTab = UTIL_mallocStr(length); + + strcpy(kindTab, C_KIND_TAB_BEG); + strcat(kindTab, body); + strcat(kindTab, C_KIND_TAB_END); + + return kindTab; +} + +//PERV_getKindData +#define C_GETKINDDATA_DEF \ +"PERV_KindData PERV_getKindData(int index) \n{ \n return PERV_kindDataTab[index]; \n} \n\n" +//PERV_copyKindDataTab +#define C_COPYKINDDATATAB_DEF \ +"void PERV_copyKindDataTab(PERV_KindData* dst) \n{ \n //this way of copy relies on the assumption that the pervasive kind data \n //has the same structure as that of the run-time kind symbol table entries.\n memcpy((void*)dst, (void*)PERV_kindDataTab, \n sizeof(PERV_KindData) * PERV_KIND_NUM); \n} \n\n" + +char* C_mkKindC(char* kindTab) +{ + size_t length = strlen(C_KIND_COMMENTS) + strlen(kindTab) + + strlen(C_GETKINDDATA_DEF) + strlen(C_COPYKINDDATATAB_DEF); + char* kindC = UTIL_mallocStr(length); + + strcpy(kindC, C_KIND_COMMENTS); + strcat(kindC, kindTab); + strcat(kindC, C_GETKINDDATA_DEF); + strcat(kindC, C_COPYKINDDATATAB_DEF); + + return kindC; +} + + +/*********************************************************************/ +/* Type Skeleton relevant components */ +/*********************************************************************/ +#define C_NUMTYSKELS_COMMENTS \ +"//total number of type skeletons needed for pervasive constants\n" + + +/* + //total number of type skeletons needed for pervasive constants\n + #define PERV_TY_SKEL_NUM \n +*/ +char* C_mkNumTySkels(char* num) +{ + char* def = C_mkDefine(C_NUMTYSKELS, num); + size_t length = strlen(def) + strlen(C_NUMTYSKELS_COMMENTS) + 5; + char* numTySkels = UTIL_mallocStr(length); + + strcpy(numTySkels, C_NUMTYSKELS_COMMENTS); + strcat(numTySkels, def); free(def); + strcat(numTySkels, "\n\n"); + + return numTySkels; +} + +//comments +#define C_TYSKEL_COMMENTS \ +"/***************************************************************************/\n/* TYPE SKELETIONS FOR PERVASIVE CONSTANTS */ \n/****************************************************************************/\n\n" +//PERV_TySkelData +#define C_TYSKELDATA_TYPE_DEF \ +"//pervasive type skel data type \ntypedef DF_TypePtr PERV_TySkelData; \n\n" + +//PERV_TySkelTab +#define C_TYSKELTAB_DEC \ +"//pervasive type skel table (array) \nextern PERV_TySkelData PERV_tySkelTab[PERV_TY_SKEL_NUM]; \n\n" + +//PERV_tySkelTabInit +#define C_TYSKELTABINIT_DEC \ +"//pervasive type skeletons and type skeleton table initialization \n//Note that type skeltons have to be dynamically allocated, and so does the \n//info recorded in each entry of the pervasive type skeleton table \nvoid PERV_tySkelTabInit(); \n\n" + +//PERV_copyTySkelTab +#define C_COPYTYSKELTAB_DEC \ +"//pervasive tyskel table copy function \nvoid PERV_copyTySkelTab(PERV_TySkelData* dst); \n\n" + +char* C_mkTySkelsH(char* numTySkels) +{ + size_t length = strlen(C_TYSKEL_COMMENTS) + strlen(numTySkels) + + strlen(C_TYSKELDATA_TYPE_DEF) + strlen(C_TYSKELTAB_DEC) + + strlen(C_TYSKELTABINIT_DEC) + strlen(C_COPYTYSKELTAB_DEC); + char* tySkelsH = UTIL_mallocStr(length); + + strcpy(tySkelsH, C_TYSKEL_COMMENTS); + strcat(tySkelsH, numTySkels); + strcat(tySkelsH, C_TYSKELDATA_TYPE_DEF); + strcat(tySkelsH, C_TYSKELTAB_DEC); + strcat(tySkelsH, C_TYSKELTABINIT_DEC); + strcat(tySkelsH, C_COPYTYSKELTAB_DEC); + + return tySkelsH; +} + +/************************************************************************/ +/* pervasives.c */ +/************************************************************************/ +//manipulating each type skeleton +#define MKSKVARTYPE_BEG " DF_mkSkelVarType(tySkelBase, " +#define MKSORTTYPE_BEG " DF_mkSortType(tySkelBase, " +#define MKATOMTYPE_END ");\n" +#define MKARROWTYPE_BEG \ +" DF_mkArrowType(tySkelBase, (DF_TypePtr)(tySkelBase + " +#define MKSTRTYPE_BEG \ +" DF_mkStrType(tySkelBase, (DF_TypePtr)(tySkelBase + " +#define MKSTRFUNCTYPE_BEG " DF_mkStrFuncType(tySkelBase, " +#define MKCOMPTYPE_END " * DF_TY_ATOMIC_SIZE));\n" +#define TYSKELBASE_INC " tySkelBase += DF_TY_ATOMIC_SIZE;\n" + +static char* C_genTySkelSort(char* name) +{ + char* kindName = C_mkIndexName(name); + char* mytext = NULL; + mytext = UTIL_mallocStr(strlen(MKSORTTYPE_BEG) + strlen(MKATOMTYPE_END) + + strlen(kindName) + strlen(TYSKELBASE_INC)); + + strcpy(mytext, MKSORTTYPE_BEG); + strcat(mytext, kindName); free(kindName); + strcat(mytext, MKATOMTYPE_END); + strcat(mytext, TYSKELBASE_INC); + return mytext; +} + +static char* C_genTySkelSkVar(char* index) +{ + char* mytext = NULL; + mytext = UTIL_mallocStr(strlen(MKSKVARTYPE_BEG) + strlen(MKATOMTYPE_END) + + strlen(index) + strlen(TYSKELBASE_INC)); + + strcpy(mytext, MKSKVARTYPE_BEG); + strcat(mytext, index); + strcat(mytext, MKATOMTYPE_END); + strcat(mytext, TYSKELBASE_INC); + return mytext; +} + +static char* C_genTySkelFunc(char* name, char* arity) +{ + char* kindName = C_mkIndexName(name); + char* mytext = NULL; + mytext = UTIL_mallocStr(strlen(MKSTRFUNCTYPE_BEG) + strlen(kindName) + + strlen(arity) + strlen(MKATOMTYPE_END) + + strlen(TYSKELBASE_INC) + 5); + + strcpy(mytext, MKSTRFUNCTYPE_BEG); + strcat(mytext, kindName); free(kindName); + strcat(mytext, ", "); + strcat(mytext, arity); + strcat(mytext, MKATOMTYPE_END); + strcat(mytext, TYSKELBASE_INC); + return mytext; +} + +static char* C_genTySkelArrow(int argPosNum) +{ + char* argPos = UTIL_itoa(argPosNum); + char* mytext = NULL; + mytext = UTIL_mallocStr(strlen(MKARROWTYPE_BEG) + strlen(argPos) + + strlen(MKCOMPTYPE_END) + strlen(TYSKELBASE_INC)); + + strcpy(mytext, MKARROWTYPE_BEG); + strcat(mytext, argPos); free(argPos); + strcat(mytext, MKCOMPTYPE_END); + strcat(mytext, TYSKELBASE_INC); + return mytext; +} + +static char* C_genTySkelStr(int argPosNum) +{ + char* argPos = UTIL_itoa(argPosNum); + char* mytext = NULL; + mytext = UTIL_mallocStr(strlen(MKSTRTYPE_BEG) + strlen(argPos) + + strlen(MKCOMPTYPE_END) + strlen(TYSKELBASE_INC)); + + strcpy(mytext, MKSTRTYPE_BEG); + strcat(mytext, argPos); free(argPos); + strcat(mytext, MKCOMPTYPE_END); + strcat(mytext, TYSKELBASE_INC); + return mytext; +} + +//data structure used for breath-first traversal of type skels +typedef struct Types +{ + int length; + TypeList types; +} Types; + +int C_totalSpace = 0; + +static char* C_genOneTySkel(Types types) +{ + TypeList typeList = types.types; + int length = types.length; + char* mytext = NULL; + + if (length) { + Type myType = typeList -> oneType; + TypeList remaining = typeList -> next; + char *mytext1 = NULL, *mytext2 = NULL; + free(typeList); + switch (myType -> tag){ + case SORT: + { + mytext1 = C_genTySkelSort(myType->data.sort); + C_totalSpace++; + types.types = remaining; + types.length = length-1; + mytext2 = C_genOneTySkel(types); + break; + } + case SKVAR: + { + mytext1 = C_genTySkelSkVar(myType->data.skvar); + C_totalSpace++; + types.types = remaining; + types.length = length-1; + mytext2 = C_genOneTySkel(types); + break; + } + case FUNC: + { + mytext1 = C_genTySkelFunc(myType->data.func.name, + myType->data.func.arity); + C_totalSpace++; + types.types = remaining; + types.length = length -1; + mytext2 = C_genOneTySkel(types); + break; + } + case ARROW: + { + Type lop = myType->data.arrow.lop; + Type rop = myType->data.arrow.rop; + mytext1 = C_genTySkelArrow(length); + C_totalSpace++; + remaining = addItemToEnd(remaining, lop); + types.types = addItemToEnd(remaining, rop); + types.length = length+1; + mytext2 = C_genOneTySkel(types); + break; + } + case STR: + { + Type func = myType->data.str.functor; + TypeList args = myType->data.str.args; + int arity = myType -> data.str.arity; + mytext1 = C_genTySkelStr(length); + C_totalSpace++; + remaining = addItemToEnd(remaining, func); + types.types = append(remaining, args); + types.length = length + arity; + mytext2 = C_genOneTySkel(types); + break; + } + } + freeType(myType); + mytext = UTIL_mallocStr(strlen(mytext1) + strlen(mytext2)); + strcpy(mytext, mytext1); free(mytext1); + strcat(mytext, mytext2); free(mytext2); + } else { + mytext = strdup(""); + } + return mytext; +} + +#define C_TYSKELS_PRE \ +"PERV_tySkelTab[tySkelInd] = (PERV_TySkelData)tySkelBase;\n tySkelInd++;\n" + +char* C_genTySkel(Type tyskel, char* comments) +{ + char* commentText = (comments) ? C_mkOneLineComments(comments) : NULL; + Types tyskels; + char* tyskelText1; + char* tyskelText2; + size_t length; + + tyskels.length = 1; + tyskels.types = addItem(tyskel, NULL); + tyskelText1 = C_genOneTySkel(tyskels); + + length = ((commentText) ? strlen(commentText) + strlen(C_INDENT): 0) + + strlen(tyskelText1) + strlen(C_TYSKELS_PRE) + strlen(C_INDENT) + 5; + tyskelText2 = UTIL_mallocStr(length); + + strcpy(tyskelText2, C_INDENT); + if (commentText) { + strcat(tyskelText2, commentText); free(commentText); + strcat(tyskelText2, "\n"); + } + strcat(tyskelText2, C_INDENT); + strcat(tyskelText2, C_TYSKELS_PRE); + strcat(tyskelText2, tyskelText1); free(tyskelText1); + strcat(tyskelText2, "\n"); + + return tyskelText2; +} + +#define TYSKELTABINIT_BEG \ +"//pervasive type skeletons and type skeleton table initialization \n//The type skeletons are created in the memory of the system through malloc, \n//and addresses are entered into the pervasive type skeleton table. \nvoid PERV_tySkelTabInit() \n{ \n int tySkelInd = 0; //ts tab index\n" +#define TYSKELTABINIT_END "}\n\n" + +#define TYSPACE_BEG " MemPtr tySkelBase = (MemPtr)EM_malloc(WORD_SIZE * " +#define TYSPACE_END " ); //ts area\n\n" + +char* C_mkTySkelTabInit(char* body, int space) +{ + char* spaceText = UTIL_itoa(space * 2); + char* tabInit = UTIL_mallocStr(strlen(TYSKELTABINIT_BEG) + + strlen(TYSPACE_BEG) + strlen(spaceText) + + strlen(TYSPACE_END) + strlen(body) + + strlen(TYSKELTABINIT_END)); + strcpy(tabInit, TYSKELTABINIT_BEG); + strcat(tabInit, TYSPACE_BEG); + strcat(tabInit, spaceText); free(spaceText); + strcat(tabInit, TYSPACE_END); + strcat(tabInit, body); + strcat(tabInit, TYSKELTABINIT_END); + + return tabInit; +} + + +//PERV_tySkelTab +#define TYSKELTAB_DEF \ +"//pervasive type skeleton table (array) \nPERV_TySkelData PERV_tySkelTab[PERV_TY_SKEL_NUM]; \n\n" + +//PERV_copyTySkelTab +#define COPYTYSKELTAB_DEF \ +"void PERV_copyTySkelTab(PERV_TySkelData* dst) \n{ \n memcpy((void*)dst, (void*)PERV_tySkelTab, \n sizeof(PERV_TySkelData) * PERV_KIND_NUM); \n}\n\n" +char* C_mkTySkelsC(char* tySkelTab) +{ + char* text = UTIL_mallocStr(strlen(C_TYSKEL_COMMENTS) + + strlen(TYSKELTAB_DEF) + + strlen(tySkelTab) + + strlen(COPYTYSKELTAB_DEF)); + strcpy(text, C_TYSKEL_COMMENTS); + strcat(text, TYSKELTAB_DEF); + strcat(text, tySkelTab); + strcat(text, COPYTYSKELTAB_DEF); + + return text; +} + +/*********************************************************************/ +/* Constant relevant components */ +/*********************************************************************/ +#define C_NUMCONSTS_COMMENTS \ +"//total number pervasive constants\n" + +/* + //total number pervasive constants\n + #define PERV_CONST_NUM \n +*/ +char* C_mkNumConsts(char* num) +{ + char* def = C_mkDefine(C_NUMCONSTS, num); + size_t length = strlen(def) + strlen(C_NUMCONSTS_COMMENTS) + 5; + char* numConsts = UTIL_mallocStr(length); + + strcpy(numConsts, C_NUMCONSTS_COMMENTS); + strcat(numConsts, def); free(def); + strcat(numConsts, "\n\n"); + + return numConsts; +} + +#define C_CONSTINDEX_COMMENTS \ +"//indices for predefined constants\n" + +char* C_mkConstIndexType(char* body) +{ + char* enumText = C_mkEnum(C_TY_CONSTIND, body); + char* typeDefText = C_mkTypeDef(enumText, C_TY_CONSTIND); + size_t length = strlen(typeDefText) + strlen(C_CONSTINDEX_COMMENTS); + char* constIndexType = UTIL_mallocStr(length); + + strcpy(constIndexType, C_CONSTINDEX_COMMENTS); + strcat(constIndexType, typeDefText); + free(enumText); free(typeDefText); + + return constIndexType; +} + +//comments +#define C_CONST_COMMENTS \ +"/***************************************************************************/ \n/* PERVASIVE CONSTANTS */ \n/***************************************************************************/\n\n" + +//PERV_ConstData +#define C_CONSTDATA_TYPE \ +"//pervasive const data type \ntypedef struct \n{ \n char *name; \n TwoBytes typeEnvSize; \n TwoBytes tskTabIndex; //index to the type skeleton table \n TwoBytes neededness; //neededness (predicate constant) \n TwoBytes univCount; \n int precedence; \n int fixity; \n} PERV_ConstData; \n\n" + +//PERV_ConstDataTab +#define C_CONSTDATA_TAB_DEC \ +"//pervasive const data table (array) \nextern PERV_ConstData PERV_constDataTab[PERV_CONST_NUM]; \n\n" + +//PERV_getConstData +#define C_GETCONSTDATA_DEC \ +"//pervasive const data access function \nPERV_ConstData PERV_getConstData(int index); \n\n" + +//PERV_copyConstDataTab +#define C_COPYCONSTDATATAB_DEC \ +"//pervasive const table copy function (used in module space initialization) \n//this functiion relies on the assumption that the pervasive kind data \n//has the same structure as that of the run-time kind symbol table entries. \nvoid PERV_copyConstDataTab(PERV_ConstData* dst); \n\n" + +//PERV_isLogicSymb PERV_isPredSymb +#define C_ISLS_ISPS_DEC \ +"//functions used by the simulator for interpreted goals \nBoolean PERV_isLogicSymb(int index); \nBoolean PERV_isPredSymb(int index); \n\n" + + +//PERV_logicSymb +#define C_LOGICSYMB_DEC "PERV_LogicSymbTypes PERV_logicSymb(int index); \n\n" + +//PERV_predBuiltin +#define C_PREDBUILTIN_DEC "int PERV_predBuiltin(int index); \n\n" + +char* C_mkConstH(char* constIndexType, char* numConsts, char* property) +{ + size_t length = strlen(C_CONST_COMMENTS) + strlen(constIndexType) + + strlen(numConsts) + strlen(C_CONSTDATA_TYPE) + + strlen(C_CONSTDATA_TAB_DEC) + strlen(C_GETCONSTDATA_DEC) + + strlen(C_COPYCONSTDATATAB_DEC) + strlen(property) + + strlen(C_ISLS_ISPS_DEC) + strlen(C_LOGICSYMB_DEC) + + strlen(C_PREDBUILTIN_DEC); + char* constH = UTIL_mallocStr(length); + + strcpy(constH, C_CONST_COMMENTS); + strcat(constH, constIndexType); + strcat(constH, numConsts); + strcat(constH, C_CONSTDATA_TYPE); + strcat(constH, C_CONSTDATA_TAB_DEC); + strcat(constH, C_GETCONSTDATA_DEC); + strcat(constH, C_COPYCONSTDATATAB_DEC); + strcat(constH, property); + strcat(constH, C_ISLS_ISPS_DEC); + strcat(constH, C_LOGICSYMB_DEC); + strcat(constH, C_PREDBUILTIN_DEC); + + return constH; +} + +/***************************************************************/ +/* pervasives.c */ +/***************************************************************/ +//traslate precedence info into a string +static char* C_mkPrec(OP_Prec prec) +{ + if (OP_precIsMax(prec)) return strdup("256"); + else return UTIL_itoa(prec.data.prec); +} +//translate fixity info into a string +static char* C_mkFixity(OP_Fixity fixity) +{ + switch (fixity){ + case OP_INFIX : return strdup("OP_INFIX"); + case OP_INFIXL : return strdup("OP_INFIXL"); + case OP_INFIXR : return strdup("OP_INFIXR"); + case OP_PREFIX : return strdup("OP_PREFIX"); + case OP_PREFIXR : return strdup("OP_PREFIXR"); + case OP_POSTFIX : return strdup("OP_POSTFIX"); + case OP_POSTFIXL : return strdup("OP_POSTFIXL"); + case OP_NONE : return strdup("OP_NONE"); + default : return strdup("OP_NONE"); + } +} + + +// { name, tesize, tst, (need), UC, prec, fixity } +char* C_mkConstTabEntry(char* name, char* tesize, OP_Prec prec, + OP_Fixity fixity, char* tyskelInd, char* neededness, + char* comments) +{ + char* commentText = (comments) ? C_mkOneLineComments(comments) : NULL; + char* precText = C_mkPrec(prec); + char* fixityText = C_mkFixity(fixity); + size_t length = ((commentText) ? strlen(commentText) + strlen(C_INDENT): 0) + + strlen(name) + strlen(tesize) + strlen(tyskelInd) + + strlen(neededness) + strlen(precText) + strlen(fixityText) + + strlen(C_INDENT)*7 + 15; + char* entry = UTIL_mallocStr(length); + + strcpy(entry, C_INDENT); + if (commentText) { + strcat(entry, commentText); strcat(entry, "\n"); + strcat(entry, C_INDENT); free(commentText); + } + strcat(entry, "{\""); + strcat(entry, name); + strcat(entry, "\","); + strcat(entry, C_INDENT); + strcat(entry, tesize); + strcat(entry, ","); + strcat(entry, C_INDENT); + strcat(entry, tyskelInd); + strcat(entry, ","); + strcat(entry, C_INDENT); + strcat(entry, neededness); + strcat(entry, ","); + strcat(entry, C_INDENT); + strcat(entry, "0,"); + strcat(entry, C_INDENT); + strcat(entry, precText); free(precText); + strcat(entry, ","); + strcat(entry, C_INDENT); + strcat(entry, fixityText); free(fixityText); + strcat(entry, "}"); + + return entry; +} + + +#define C_CONST_TAB_BEG \ +"//pervasive constant data table (array) \nPERV_ConstData PERV_constDataTab[PERV_CONST_NUM] = { \n //name, tesize, tst, neededness, UC, prec, fixity \n" +#define C_CONST_TAB_END "};\n\n" + +/* + //pervasive const data table (array) + PERV_ConstData PERV_constDataTab[PERV_CONST_NUM] = { \n body \n};\n +*/ +char* C_mkConstTab(char* body) +{ + size_t length = strlen(C_CONST_TAB_BEG) + strlen(C_CONST_TAB_END) + + strlen(body); + char* constTab = UTIL_mallocStr(length); + + strcpy(constTab, C_CONST_TAB_BEG); + strcat(constTab, body); + strcat(constTab, C_CONST_TAB_END); + + return constTab; +} + +//PERV_getConstData +#define C_GETCONSTDATA_DEF \ +"PERV_ConstData PERV_getConstData(int index) \n{ \n return PERV_constDataTab[index]; \n} \n\n" + +//PERV_copyConstDataTab +#define C_COPYCONSTDATATAB_DEF \ +"void PERV_copyConstDataTab(PERV_ConstData* dst) \n{ \n //this way of copy relies on the assumption that the pervasive kind data \n //has the same structure as that of the run-time kind symbol table entries.\n memcpy((void*)dst, (void*)PERV_constDataTab, \n sizeof(PERV_ConstData) * PERV_CONST_NUM); \n} \n\n" + +//PERV_isLogicSymb +#define C_ISLOGICSYMB_DEF \ +"Boolean PERV_isLogicSymb(int index) \n{ \n return ((index >= PERV_LSSTART) && (index <= PERV_LSEND)); \n}\n\n" + +//PERV_isPredSymb +#define C_ISPREDSYMB_DEF \ +"Boolean PERV_isPredSymb(int index) \n{ \n return ((index >= PERV_PREDSTART) && (index <= PERV_PREDEND)); \n}\n\n" + +//PERV_logicSymb +#define C_LOGICSYMB_DEF \ +"PERV_LogicSymbTypes PERV_logicSymb(int index) \n{ \n return ((PERV_LogicSymbTypes)(index - PERV_LSSTART)); \n}\n\n" + +//PERV_predBuiltin +#define C_PREDBUILTIN_DEF \ +"int PERV_predBuiltin(int index) \n{ \n return (index - PERV_PREDSTART); \n}\n\n" + +char* C_mkConstC(char* constTab) +{ + size_t length = strlen(C_CONST_COMMENTS) + strlen(constTab) + + strlen(C_GETCONSTDATA_DEF) + strlen(C_COPYCONSTDATATAB_DEF) + + strlen(C_ISLOGICSYMB_DEF) + strlen(C_ISPREDSYMB_DEF) + + strlen(C_LOGICSYMB_DEF) + strlen(C_PREDBUILTIN_DEF); + char* constC = UTIL_mallocStr(length); + + strcpy(constC, C_CONST_COMMENTS); + strcat(constC, constTab); + strcat(constC, C_GETCONSTDATA_DEF); + strcat(constC, C_COPYCONSTDATATAB_DEF); + strcat(constC, C_ISLOGICSYMB_DEF); + strcat(constC, C_ISPREDSYMB_DEF); + strcat(constC, C_LOGICSYMB_DEF); + strcat(constC, C_PREDBUILTIN_DEF); + + return constC; +} + +#define LOGICSYMBTYPE_DEC_BEG \ +"typedef enum PERV_LogicSymbTypes \n{\n" +#define LOGICSYMBTYPE_DEC_END "} PERV_LogicSymbTypes;\n\n" + +char* C_mkLSTypeDec(char* body) +{ + size_t length = strlen(LOGICSYMBTYPE_DEC_BEG) + strlen(LOGICSYMBTYPE_DEC_END) + + strlen(body); + char* text = UTIL_mallocStr(length); + + strcpy(text, LOGICSYMBTYPE_DEC_BEG); + strcat(text, body); + strcat(text, LOGICSYMBTYPE_DEC_END); + + return text; +} + +//PERV_LSSTART +#define LSSTART_BEG "#define PERV_LSSTART " +#define LSSTART_END " //begin of interpretable symbols\n" +#define LSEND_BEG "#define PERV_LSEND " +#define LSEND_END " //end of interpretable symbols\n" +char* C_mkLSRange(char* start, char* end) +{ + char* range; + char* startInd = C_mkIndexName(start); + char* endInd = C_mkIndexName(end); + size_t length = strlen(startInd) + strlen(LSSTART_BEG) + strlen(LSSTART_END) + + strlen(endInd) + strlen(LSEND_BEG) + strlen(LSEND_END) + 5; + + range = UTIL_mallocStr(length); + strcpy(range, LSSTART_BEG); + strcat(range, " "); + strcat(range, startInd); free(startInd); + strcat(range, LSSTART_END); + strcat(range, LSEND_BEG); + strcat(range, " "); + strcat(range, endInd); free(endInd); + strcat(range, LSEND_END); + strcat(range, "\n"); + + return range; +} + +//PERV_PREDSTART +#define PREDSTART_BEG "#define PERV_PREDSTART " +#define PREDSTART_END " //begin of predicate symbols\n" +#define PREDEND_BEG "#define PERV_PREDEND " +#define PREDEND_END " //end of predicate symbols\n" + +char* C_mkPredRange(char* start, char* end) +{ + char* range; + char* startInd = C_mkIndexName(start); + char* endInd = C_mkIndexName(end); + size_t length = strlen(startInd) + strlen(PREDSTART_BEG) + + strlen(PREDSTART_END) + strlen(endInd) + strlen(PREDEND_BEG) + + strlen(PREDEND_END) + 5; + + range = UTIL_mallocStr(length); + strcpy(range, PREDSTART_BEG); + strcat(range, " "); + strcat(range, startInd); free(startInd); + strcat(range, PREDSTART_END); + strcat(range, PREDEND_BEG); + strcat(range, " "); + strcat(range, endInd); free(endInd); + strcat(range, PREDEND_END); + strcat(range, "\n"); + + return range; +} + + +/*********************************************************************/ +/* fixed part of pervasives.h{c} */ +/*********************************************************************/ +#define C_COMMENTS_BEG_H \ +"/****************************************************************************/\n/* File pervasives.h. */ \n/****************************************************************************/\n\n" + + +#define C_COMPDEF_BEG_H "#ifndef PERVASIVES_H\n#define PERVASIVES_H\n\n" +#define C_COMPDEF_END_H "#endif //PERVASIVES_H\n" + +#define C_INCLUDE_H \ +"#include \"../simulator/mctypes.h\" //to be changed \n#include \"../simulator/dataformats.h\" //to be changed \n\n" + +char* C_mkFixedBegH() +{ + char* text = UTIL_mallocStr(strlen(C_COMMENTS_BEG_H) + + strlen(C_COMPDEF_BEG_H) + + strlen(C_INCLUDE_H)); + strcpy(text, C_COMMENTS_BEG_H); + strcat(text, C_COMPDEF_BEG_H); + strcat(text, C_INCLUDE_H); + return text; +} + +char* C_mkFixedEndH() +{ + char* text = strdup(C_COMPDEF_END_H); + return text; +} + +#define C_COMMENTS_BEG_C \ +"/***************************************************************************/ \n/* File pervasives.c. */ \n/***************************************************************************/\n\n" + +#define C_COMPDEF_BEG_C "#ifndef PERVASIVES_C\n#define PERVASIVES_C\n\n" +#define C_COMPDEF_END_C "#endif //PERVASIVES_C\n" + +#define C_INCLUDE_C \ +"#include \n#include \"pervasives.h\" \n#include \"../system/error.h\" //to be changed \n#include \"../system/operators.h\" //to be changed \n\n" + +char* C_mkFixedBegC() +{ + char* text = UTIL_mallocStr(strlen(C_COMMENTS_BEG_C) + + strlen(C_COMPDEF_BEG_C) + + strlen(C_INCLUDE_C)); + strcpy(text, C_COMMENTS_BEG_C); + strcat(text, C_COMPDEF_BEG_C); + strcat(text, C_INCLUDE_C); + return text; +} + +char* C_mkFixedEndC() +{ + char* text = strdup(C_COMPDEF_END_C); + return text; +} + diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/ccode.h b/src/runtime/c/teyjus/tables_gen/pervasives/ccode.h new file mode 100644 index 000000000..7d5a781bb --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/ccode.h @@ -0,0 +1,80 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +#include "types.h" +#include "op.h" + +/*******************************************************************/ +/* commen structures */ +/*******************************************************************/ +/* // */ +char* C_mkOneLineComments(char* comments); +/* // empty */ +char* C_mkEmptyComments(); +/* + //comments \n + PERV__INDEX = +*/ +char* C_mkIndex(char* name, char* indexNum, char* comments); +/* + PERV_ = +*/ +char* C_mkIndex2(char* name, char* indexNum); + +/******************************************************************/ +/* kind relevant components */ +/******************************************************************/ +char* C_mkNumKinds(char* num); +char* C_mkKindIndexType(char* body); +char* C_mkKindH(char* indexType, char* kindNum); + +char* C_mkKindTabEntry(char* name, char* arity, char* comments); +char* C_mkKindTab(char* body); +char* C_mkKindC(char* kindTab); + +/******************************************************************/ +/* type skeleton relevant components */ +/******************************************************************/ +char* C_mkNumTySkels(char* num); +char* C_mkTySkelsH(char* numTySkels); + +extern int C_totalSpace; +char* C_genTySkel(Type tyskel, char* comments); +char* C_mkTySkelTabInit(char* body, int space); +char* C_mkTySkelsC(char* tySkelTab); + +/******************************************************************/ +/* constant relevant components */ +/******************************************************************/ +char* C_mkNumConsts(char* num); +char* C_mkConstIndexType(char* body); +char* C_mkConstH(char* constIndexType, char* numConsts, char* property); + +char* C_mkConstTabEntry(char* name, char* tesize, OP_Prec prec, + OP_Fixity fixity, char* tyskelInd, char* neededness, + char* comments); +char* C_mkConstTab(char* body); +char* C_mkConstC(char* constTab); + + +char* C_mkLSTypeDec(char* body); +char* C_mkLSRange(char* start, char* end); +char* C_mkPredRange(char* start, char* end); + +char* C_mkFixedBegH(); +char* C_mkFixedEndH(); +char* C_mkFixedBegC(); +char* C_mkFixedEndC(); diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.c b/src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.c new file mode 100644 index 000000000..261d4dfab --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.c @@ -0,0 +1,1434 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* ocamlcode.c. */ +/* This file defines auxiliary functions in making pervasive.mli and */ +/* pervasive.ml. */ +/* Since space and time efficiency is not an important concern in the */ +/* system source code generation phase, the code here is structured in the */ +/* way for the convenience of making changes on pervasive.mli{ml}. */ +/***************************************************************************/ +#include +#include +#include + +#include "ocamlcode.h" + +/***************************************************************************/ +/* Functions for making various language constructs */ +/***************************************************************************/ +/* Make a string of form . */ +static char* OC_mkDotStr(char* first, char* second) +{ + size_t length = strlen(first) + strlen(second) + 1; + char* ptr = UTIL_mallocStr(length+1); + + strcpy(ptr, first); + strcat(ptr, "."); + strcat(ptr, second); + + return ptr; +} + +/* + (Some ) +*/ +char* OC_mkSome(char* info) +{ + size_t length = strlen(info) + 10; + char* rtptr = UTIL_mallocStr(length + 1); + + strcpy(rtptr, "(Some "); + strcat(rtptr, info); + strcat(rtptr, ")"); + + return rtptr; +} + +/* + (ref ) +*/ +char* OC_mkRef(char* info) +{ + size_t length = strlen(info) + 10; + char* rtptr = UTIL_mallocStr(length + 1); + + strcpy(rtptr, "(ref "); + strcat(rtptr, info); + strcat(rtptr, ")"); + + return rtptr; +} + + +/* Make a variable definition: + let = +*/ +static char* OC_mkVarDef(char* varName, char* defs) +{ + size_t length = strlen(varName) + strlen(defs) + 10; + char* vardef = UTIL_mallocStr(length + 1); + + strcpy(vardef, "let "); + strcat(vardef, varName); + strcat(vardef, " = "); + strcat(vardef, defs); + + return vardef; +} + +/* Make a variable declaration: + val : "\n" +*/ +static char* OC_mkVarDec(char* varName, char* varType) +{ + size_t length = strlen(varName) + strlen(varType) + 10; + char* vardec = UTIL_mallocStr(length + 1); + + strcpy(vardec, "val "); + strcat(vardec, varName); + strcat(vardec, " : "); + strcat(vardec, varType); + strcat(vardec, "\n"); + + return vardec; +} + +/* Make arrow type: + -> +*/ +static char* OC_mkArrowType(char* ty1, char* ty2) +{ + size_t length = strlen(ty1) + strlen(ty2) + 5; + char* arrowType = UTIL_mallocStr(length); + + strcpy(arrowType, ty1); + strcat(arrowType, " -> "); + strcat(arrowType, ty2); + return arrowType; +} + + +/**************************************************************************/ +/* Names from other modules */ +/**************************************************************************/ +/********************************************************/ +/* Fixities */ +/********************************************************/ +#define INFIX "Absyn.Infix" +#define INFIXL "Absyn.Infixl" +#define INFIXR "Absyn.Infixr" +#define PREFIX "Absyn.Prefix" +#define PREFIXR "Absyn.Prefixr" +#define POSTFIX "Absyn.Postfix" +#define POSTFIXL "Absyn.Postfixl" +#define NOFIXITY "Absyn.NoFixity" + +#define MAXPREC "maxPrec + 1" + +/********************************************************/ +/* module names */ +/********************************************************/ +#define ABSYN "Absyn" +#define SYMBOL "Symbol" +#define ERRORMSG "Errormsg" +#define TABLE "Table" + +/********************************************************/ +/* types */ +/********************************************************/ +//absyn +#define TY_KIND "akind" +#define TY_CONST "aconstant" +#define TY_TERM "aterm" +#define TY_TYABBREV "atypeabbrev" +//table +#define TY_SYMTAB "SymbolTable.t" + +/********************************************************/ +/* value constructors */ +/********************************************************/ +//absyn +#define VCTR_KIND "Kind" +#define VCTR_KINDTYPE "PervasiveKind" +#define VCTR_CONSTANT "Constant" +#define VCTR_PERVCONST "PervasiveConstant" +#define VCTR_TYSKEL "Skeleton" +#define VCTR_APPTYPE "ApplicationType" +#define VCTR_ARROWTYPE "ArrowType" +#define VCTR_SKELVARTYPE "SkeletonVarType" +#define VCTR_BUILTIN "Builtin" + +//errormsg +#define VCTR_NULLPOS "none" + +//symbol +#define VCTR_SYMBOL "symbol" +#define VCTR_SYMBOL_ALIAS "symbolAlias" + +//table +#define VCTR_EMPTYTAB "SymbolTable.empty" + +/********************************************************/ +/* functions */ +/********************************************************/ +//table +#define FUNC_ADD "add" +//absyn +#define FUNC_MAKETYSETVAR "makeTypeSetVariable" + +/***************************************************************************/ +/* Local names */ +/***************************************************************************/ +#define BUILDPERVKIND "buildPervasiveKinds" +#define BUILDPERVCONST "buildPervasiveConstants" + +#define PERVKIND "pervasiveKinds" +#define PERVCONST "pervasiveConstants" +#define PERVTYABBR "pervasiveTypeAbbrevs" + +#define KVAR_PREFIX "k" +#define CVAR_POSTFIX "Constant" +#define TSKVAR_PREFIX "tyskel" +#define TAB "t" + +#define IS "is" +#define SETVARIR "tysetvarIR" +#define SETVARIRS "tysetvarIRS" +#define OVERLOADTYSKEL1 "overloadTySkel1" +#define OVERLOADTYSKEL2 "overloadTySkel2" +#define OVERLOADTYSKEL3 "overloadTySkel3" + +/***************************************************************************/ +/* Functions for making program components */ +/***************************************************************************/ +/* + (Symbol.symbol "") +*/ +static char* OC_mkSymbol(char* name) +{ + char* symbolCtr = OC_mkDotStr(SYMBOL, VCTR_SYMBOL); + size_t length = strlen(symbolCtr) + strlen(name) + 10; + char* rtptr= UTIL_mallocStr(length + 1); + + strcpy(rtptr, "("); + strcat(rtptr, symbolCtr); free(symbolCtr); + strcat(rtptr, " \""); + strcat(rtptr, name); + strcat(rtptr, "\")"); + return rtptr; +} + +/* + (Symbol.symbolAlias "" "") +*/ +static char* OC_mkSymbolAlias(char *name, char *printName) +{ + char* symbolCtr = OC_mkDotStr(SYMBOL, VCTR_SYMBOL_ALIAS); + size_t length = strlen(symbolCtr) + strlen(name) + strlen(printName) + 10; + char* rtptr= UTIL_mallocStr(length + 1); + + strcpy(rtptr, "("); + strcat(rtptr, symbolCtr); free(symbolCtr); + strcat(rtptr, " \""); + strcat(rtptr, name); + strcat(rtptr, "\" \""); + strcat(rtptr, printName); + strcat(rtptr, "\")"); + return rtptr; +} + +/* let t = Table.add (Symbol.symbol "") t in\n + */ +char* OC_mkTabEntry(char* name, char* varName) +{ + char* entry; + char* tableAdd = OC_mkDotStr(TABLE, FUNC_ADD); + char* symbol = OC_mkSymbol(name); + size_t length = strlen(tableAdd) + strlen(symbol) + strlen(varName) + + strlen(TAB) + 15; + char* def = UTIL_mallocStr(length + 1); + + strcpy(def, tableAdd); free(tableAdd); + strcat(def, " "); + strcat(def, symbol); free(symbol); + strcat(def, " "); + strcat(def, varName); + strcat(def, " "); + strcat(def, TAB); + strcat(def, " in\n "); + + entry = OC_mkVarDef(TAB, def); free(def); + return entry; +} + +/* let t = Table.SymbolTable.empty in \n*/ +static char* OC_mkTabInit() +{ + char* init; + char* emptyTab = OC_mkDotStr(TABLE, VCTR_EMPTYTAB); + size_t length = strlen(emptyTab) + 10; + char* def = UTIL_mallocStr(length + 1); + + strcpy(def, emptyTab); free(emptyTab); + strcat(def, " in\n "); + + init = OC_mkVarDef(TAB, def); free(def); + + return init; +} + +/* let = function () ->\n + let t = Table.SymbolTable.empty in t\n\n */ +static char* OC_mkBuildTabFunc(char* funcName, char* entries) +{ + char* func; + char* inits = OC_mkTabInit(); + size_t length = strlen(entries) + strlen(TAB) + strlen(inits) + 30; + char* def = UTIL_mallocStr(length + 1); + + strcpy(def, "function () ->\n "); + strcat(def, inits); free(inits); + strcat(def, entries); + strcat(def, TAB); + strcat(def, "\n\n"); + + func = OC_mkVarDef(funcName, def); free(def); + + return func; +} + +/* let = ()\n\n */ +static char* OC_mkTab(char* tabName, char* buildFuncName) +{ + char* tab; + size_t length = strlen(buildFuncName) + 10; + char* def = UTIL_mallocStr(length + 1); + + strcpy(def, buildFuncName); + strcat(def, " ()\n\n"); + + tab = OC_mkVarDef(tabName, def); free(def); + + return tab; +} + +/* val = Absyn. Table.SymbolTable.t\n */ +static char* OC_mkTabDec(char* tabName, char* typeName) +{ + char* dec; + char* symbolTab = OC_mkDotStr(TABLE, TY_SYMTAB); + char* myType = OC_mkDotStr(ABSYN, typeName); + size_t length = strlen(symbolTab) + strlen(myType) + 5; + char* typedec = UTIL_mallocStr(length + 1); + + strcpy(typedec, myType); free(myType); + strcat(typedec, " "); + strcat(typedec, symbolTab); free(symbolTab); + strcat(typedec, "\n"); + + dec = OC_mkVarDec(tabName, typedec); free(typedec); + + return dec; +} + +/****************************************************************************/ +/* functions for making pervasive kind relevant components */ +/****************************************************************************/ +/* k */ +char* OC_mkKVarName(char* name) +{ + return UTIL_appendStr(KVAR_PREFIX, name); +} + +/* is */ +char* OC_mkIsKindFuncName(char* name) +{ + return UTIL_appendStr(IS, name); +} + +/* val : Absyn.akind \n*/ +char* OC_mkKindVarDec(char* kindVarName) +{ + char* kindType = OC_mkDotStr(ABSYN, TY_KIND); + char* dec = OC_mkVarDec(kindVarName, kindType); + free(kindType); + return dec; +} + +/* val : Absyn.akind -> bool */ +char* OC_mkIsKindFuncDec(char* funcName) +{ + char* kindType = OC_mkDotStr(ABSYN, TY_KIND); + char* arrowType = OC_mkArrowType(kindType, "bool"); + char* dec = OC_mkVarDec(funcName, arrowType); + free(kindType); free(arrowType); + return dec; +} + +/* let tm = tm == */ +char* OC_mkIsKindFuncDef(char* funcName, char* kindVarName) +{ + char* funchead = UTIL_mallocStr(strlen(funcName) + 3); + char* defbody = UTIL_mallocStr(strlen(kindVarName) + 10); + char* def; + + strcpy(funchead, funcName); + strcat(funchead, " tm"); + + strcpy(defbody, "(tm == "); + strcat(defbody, kindVarName); + strcat(defbody, ")"); + + def = OC_mkVarDef(funchead, defbody); free(funchead); free(defbody); + return def; +} + +/*Kind variable definition: + let = Absyn.PervasiveKind(Symbol.symbol "", + (Some ), ref offset, Errormsg.none) +*/ +char* OC_mkKindVar(char* varName, char* kindName, char* arity, char* offset) +{ + char* kindvar; + char* ctr = OC_mkDotStr(ABSYN, VCTR_KIND); + char* symbol = OC_mkSymbol(kindName); + char* nargs = OC_mkSome(arity); + char* index = OC_mkRef(offset); + char* ktype = OC_mkDotStr(ABSYN, VCTR_KINDTYPE); + char* pos = OC_mkDotStr(ERRORMSG, VCTR_NULLPOS); + size_t length = strlen(ctr) + strlen(symbol) + strlen(nargs) + + strlen(index) + strlen(ktype) + strlen(pos) + 10; + + char* def = UTIL_mallocStr(length + 1); + + strcpy(def, ctr); free(ctr); + strcat(def, "("); + strcat(def, symbol); free(symbol); + strcat(def, ", "); + strcat(def, nargs); free(nargs); + strcat(def, ", "); + strcat(def, index); free(index); + strcat(def, ", "); + strcat(def, ktype); free(ktype); + strcat(def, ", "); + strcat(def, pos); free(pos); + strcat(def, ")"); + + kindvar = OC_mkVarDef(varName, def); free(def); + return kindvar; +} + +/* let buildPervasiveKinds = + function () ->\n \n \n\n */ +char* OC_mkBuildKTabFunc(char* entries) +{ + return OC_mkBuildTabFunc(BUILDPERVKIND, entries); +} + +/****************************************************************************/ +/* functions for making pervasive type skeleton components */ +/****************************************************************************/ +/* Absyn.SkeletonVarType(ref ) + */ +static char* genTySkelVar(char* ind) +{ + char* ctr = OC_mkDotStr(ABSYN, VCTR_SKELVARTYPE); + char* ref = OC_mkRef(ind); + size_t length = strlen(ctr) + strlen(ref) + 5; + char* skelVar = UTIL_mallocStr(length + 1); + + strcpy(skelVar, ctr); free(ctr); + strcat(skelVar, "("); + strcat(skelVar, ref); free(ref); + strcat(skelVar, ")"); + + return skelVar; +} + +/* Absyn.ArrowType(, ) + */ +static char* genTySkelArrow(char* type1, char* type2) +{ + char* ctr = OC_mkDotStr(ABSYN, VCTR_ARROWTYPE); + size_t length = strlen(ctr) + strlen(type1) + strlen(type2) + 5; + char* arrowtype = UTIL_mallocStr(length + 1); + + strcpy(arrowtype, ctr); free(ctr); + strcat(arrowtype, "("); + strcat(arrowtype, type1); + strcat(arrowtype, ", "); + strcat(arrowtype, type2); + strcat(arrowtype, ")"); + + return arrowtype; +} + +/* Absyn.AppType(k, ) + */ +static char* genTySkelApp(char* sortName, char* args) +{ + char* ctr = OC_mkDotStr(ABSYN, VCTR_APPTYPE); + char* sortVar = OC_mkKVarName(sortName); + size_t length = strlen(ctr) + strlen(sortVar) + strlen(args) + 5; + char* apptype = UTIL_mallocStr(length + 1); + + strcpy(apptype, ctr); free(ctr); + strcat(apptype, "("); + strcat(apptype, sortVar); free(sortVar); + strcat(apptype, ", "); + strcat(apptype, args); + strcat(apptype, ")"); + + return apptype; +} + +/* Absyn.AppType(k, []) + */ +static char* genTySkelSort(char* sortName) +{ + return genTySkelApp(sortName, "[]"); +} + +//forward declaration +char* OC_genTySkel(Type args); + +static char* OC_genTySkelArgs(TypeList args) +{ + size_t length; + char* mytext1 = NULL; + char* mytext = NULL; + char* oneTypeText = NULL; + Type oneType = args -> oneType; + + args = args -> next; + mytext1 = OC_genTySkel(oneType); + + while (args) { + oneType = args -> oneType; + args = args -> next; + oneTypeText = OC_genTySkel(oneType); + + length = strlen(mytext1) + strlen(oneTypeText) + 5; + mytext = UTIL_mallocStr(length + 1); + strcpy(mytext, mytext1); free(mytext1); + strcat(mytext, " :: "); + strcat(mytext, oneTypeText); free(oneTypeText); + mytext1 = mytext; + } + length = strlen(mytext1) + 10; + mytext = UTIL_mallocStr(length + 1); + strcpy(mytext, "("); + strcat(mytext, mytext1); free(mytext1); + strcat(mytext, " :: [])"); + + return mytext; +} + +char* OC_genTySkel(Type tyskel) +{ + char* mytext1; + char* mytext2; + char* mytext3; + + switch(tyskel -> tag) { + case SORT: + { + mytext1 = genTySkelSort(tyskel -> data.sort); + return mytext1; + } + case SKVAR: + { + mytext1 = genTySkelVar(tyskel -> data.skvar); + return mytext1; + } + case STR: + { + mytext1 = OC_genTySkelArgs(tyskel -> data.str.args); + mytext2 = genTySkelApp((tyskel -> data.str.functor)->data.func.name, + mytext1); + free(mytext1); + return mytext2; + } + case ARROW: + { + mytext1 = OC_genTySkel(tyskel -> data.arrow.lop); + mytext2 = OC_genTySkel(tyskel -> data.arrow.rop); + mytext3 = genTySkelArrow(mytext1, mytext2); + free(mytext1); free(mytext2); + return mytext3; + } + default: + return strdup(""); + } +} + +/* tyskel */ +char* OC_mkTySkelVarName(char* number) +{ + return UTIL_appendStr(TSKVAR_PREFIX, number); +} + +/* Type Skeleton variable definition: + let = Some(Absyn.Skeleton(, ref None, ref false)) +*/ +char* OC_mkTYSkelVar(char* varName, char* tySkel) +{ + char* tyskelvar; + char* ctr = OC_mkDotStr(ABSYN, VCTR_TYSKEL); + char* index = OC_mkRef("None"); + char* adjust = OC_mkRef("false"); + size_t length = strlen(ctr) + strlen(index) + strlen(adjust) + + strlen(tySkel) + 15; + char* def = UTIL_mallocStr(length + 1); + char* somedef; + + strcpy(def, "("); + strcat(def, ctr); free(ctr); + strcat(def, "("); + strcat(def, tySkel); + strcat(def, ", "); + strcat(def, index); free(index); + strcat(def, ", "); + strcat(def, adjust); free(adjust); + strcat(def, "))"); + + somedef = OC_mkSome(def); free(def); + tyskelvar = OC_mkVarDef(varName, somedef); free(somedef); + + return tyskelvar; +} + + +static char* OC_mkTypeSetVar(char* defaultty, char* arglist, char* tyName) +{ + char* setVar; + char* func = OC_mkDotStr(ABSYN, FUNC_MAKETYSETVAR); + char* def = UTIL_mallocStr(strlen(func) + strlen(arglist) + strlen(defaultty) + 2); + strcpy(def, func); free(func); + strcat(def, " "); + strcat(def, defaultty); + strcat(def, " "); + strcat(def, arglist); + + setVar = OC_mkVarDef(tyName, def); free(def); + return setVar; +} + +/*********************************************/ +/* generate tyskels for overloaded constants */ +/*********************************************/ +static char* OC_mkTySkelRef(char* tySkel) +{ + char* ctr = OC_mkDotStr(ABSYN, VCTR_TYSKEL); + char* index = OC_mkRef("None"); + char* adjust = OC_mkRef("false"); + size_t length = strlen(ctr) + strlen(index) + strlen(adjust) + + strlen(tySkel) + 15; + char* def = UTIL_mallocStr(length + 1); + char* somedef; + char* ref; + + strcpy(def, "("); + strcat(def, ctr); free(ctr); + strcat(def, "("); + strcat(def, tySkel); + strcat(def, ", "); + strcat(def, index); free(index); + strcat(def, ", "); + strcat(def, adjust); free(adjust); + strcat(def, "))"); + + somedef = OC_mkSome(def); free(def); + ref = OC_mkRef(somedef); free(somedef); + return ref; +} + +char* OC_mkFixedTySkels(char* tySkels) +{ + char *text; + char* setvarIntReal = + OC_mkTypeSetVar("(Absyn.ApplicationType(kint,[]))", + "(Absyn.ApplicationType(kint,[]) :: Absyn.ApplicationType(kreal,[]) :: [])", SETVARIR); + char* setvarIntRealStr = + OC_mkTypeSetVar("(Absyn.ApplicationType(kint,[]))", + "(Absyn.ApplicationType(kint,[]) :: Absyn.ApplicationType(kreal,[]) :: Absyn.ApplicationType(kstring, []) :: [])", SETVARIRS); + char *tyskelBody, *tyskelBody2; + char *tyskel, *tyskelText; + + text = UTIL_appendStr(tySkels, setvarIntReal); free(setvarIntReal); + tySkels = UTIL_appendStr(text, "\n"); free(text); + + tyskelBody = genTySkelArrow(SETVARIR, SETVARIR); + tyskelText = OC_mkTySkelRef(tyskelBody); + tyskel = OC_mkVarDef(OVERLOADTYSKEL1, tyskelText); free(tyskelText); + text = UTIL_appendStr(tySkels, tyskel); free(tyskel); + tySkels = UTIL_appendStr(text, "\n"); free(text); + + tyskelBody2 = genTySkelArrow(SETVARIR, tyskelBody); free(tyskelBody); + tyskelText = OC_mkTySkelRef(tyskelBody2); free(tyskelBody2); + tyskel = OC_mkVarDef(OVERLOADTYSKEL2, tyskelText); free(tyskelText); + text = UTIL_appendStr(tySkels, tyskel); free(tyskel); + tySkels = UTIL_appendStr(text, "\n\n"); free(text); + + text = UTIL_appendStr(tySkels, setvarIntRealStr); free(setvarIntRealStr); + tySkels = UTIL_appendStr(text, "\n"); free(text); + + tyskelBody = genTySkelArrow(SETVARIRS, "Absyn.ApplicationType(kbool, [])"); + tyskelBody2 = genTySkelArrow(SETVARIRS, tyskelBody); free(tyskelBody); + tyskelText = OC_mkTySkelRef(tyskelBody2); free(tyskelBody2); + tyskel = OC_mkVarDef(OVERLOADTYSKEL3, tyskelText); free(tyskelText); + text = UTIL_appendStr(tySkels, tyskel); free(tyskel); + tySkels = UTIL_appendStr(text, "\n\n"); free(text); + + return tySkels; +} + +/****************************************************************************/ +/* functions for making pervasive constants components */ +/****************************************************************************/ +/* Constant */ +char* OC_mkCVarName(char* name) +{ + return UTIL_appendStr(name, CVAR_POSTFIX); +} +/* isConstant */ +char* OC_mkIsConstFuncName(char* name) +{ + return UTIL_appendStr(IS, name); +} + +/* val : Absyn.aconstant \n*/ +char* OC_mkConstVarDec(char* constVarName) +{ + char* constType = OC_mkDotStr(ABSYN, TY_CONST); + char* dec = OC_mkVarDec(constVarName, constType); + free(constType); + return dec; +} + +/* val : Absyn.aconstant -> bool */ +char* OC_mkIsConstFuncDec(char* funcName) +{ + char* constType = OC_mkDotStr(ABSYN, TY_CONST); + char* arrowType = OC_mkArrowType(constType, "bool"); + char* dec = OC_mkVarDec(funcName, arrowType); + free(constType); free(arrowType); + return dec; +} + + +/* let tm = tm == */ +char* OC_mkIsConstFuncDef(char* funcName, char* constVarName) +{ + char* funchead = UTIL_mallocStr(strlen(funcName) + 3); + char* defbody = UTIL_mallocStr(strlen(constVarName) + 10); + char* def; + + strcpy(funchead, funcName); + strcat(funchead, " tm"); + + strcpy(defbody, "(tm == "); + strcat(defbody, constVarName); + strcat(defbody, ")"); + + def = OC_mkVarDef(funchead, defbody); free(funchead); free(defbody); + return def; +} + +/* (ref fixity) */ +static char* OC_mkFixity(OP_Fixity fixity) +{ + switch (fixity){ + case OP_INFIX : return OC_mkRef(strdup(INFIX)); + case OP_INFIXL : return OC_mkRef(strdup(INFIXL)); + case OP_INFIXR : return OC_mkRef(strdup(INFIXR)); + case OP_PREFIX : return OC_mkRef(strdup(PREFIX)); + case OP_PREFIXR : return OC_mkRef(strdup(PREFIXR)); + case OP_POSTFIX : return OC_mkRef(strdup(POSTFIX)); + case OP_POSTFIXL : return OC_mkRef(strdup(POSTFIXL)); + case OP_NONE : return OC_mkRef(strdup(NOFIXITY)); + default : return OC_mkRef(strdup(NOFIXITY)); + } +} + +/* (ref prec) */ +static char* OC_mkPrec(OP_Prec prec) +{ + char* precNum; + char* precText; + if (OP_precIsMax(prec)) { + char* temp = OC_mkDotStr(ABSYN, MAXPREC); + precNum = UTIL_mallocStr(strlen(temp) + 2); + strcpy(precNum, "("); + strcat(precNum, temp); + strcat(precNum, ")"); + } else precNum = UTIL_itoa(prec.data.prec); + precText = OC_mkRef(precNum); free(precNum); + return precText; +} + +/* (ref true/false ) */ +static char* OC_mkRefBool(UTIL_Bool value) +{ + if (value) return OC_mkRef("true"); + else return OC_mkRef("false"); +} + +static char* OC_mkRefInt(int value) +{ + char* valueText = UTIL_itoa(value); + char* text = OC_mkRef(valueText); + free(valueText); + return text; +} + +static char* OC_mkCodeInfo(OP_Code codeInfo) +{ + char* code; + char* ref; + if (OP_codeInfoIsNone(codeInfo)) { + code = strdup("None"); + } else { + char* codeInd = UTIL_itoa(codeInfo); + char* ctr = OC_mkDotStr(ABSYN, VCTR_BUILTIN); + char* codeText = UTIL_mallocStr(strlen(codeInd) + strlen(ctr) + 10); + strcpy(codeText, "("); + strcat(codeText, ctr); free(ctr); + strcat(codeText, "("); + strcat(codeText, codeInd); free(codeInd); + strcat(codeText, "))"); + code = OC_mkSome(codeText); free(codeText); + } + ref = OC_mkRef(code); free(code); + return ref; +} + +static char* OC_mkConstCat(UTIL_Bool redef) +{ + char* ctr = OC_mkDotStr(ABSYN,VCTR_PERVCONST); + char* boolValue; + char* cat; + char* ref; + + if (redef) boolValue = strdup("true"); + else boolValue = strdup("false"); + + cat = UTIL_mallocStr(strlen(ctr) + strlen(boolValue) + 10); + strcpy(cat, "("); + strcat(cat, ctr); free(ctr); + strcat(cat, "("); + strcat(cat, boolValue); free(boolValue); + strcat(cat, "))"); + + ref = OC_mkRef(cat); free(cat); + return ref; +} + +static char* OC_mkSkelNeededness(int tyenvsize) +{ + char* length = UTIL_itoa(tyenvsize); + char* some; + char* ref; + char* init = UTIL_mallocStr(strlen(length) + 20); + strcpy(init, "(Array.make "); + strcat(init, length); free(length); + strcat(init, " true)"); + + some = OC_mkSome(init); free(init); + ref = OC_mkRef(some); free(some); + return ref; +} + +static char* OC_mkNeededness(int neededness, int tyenvsize) +{ + char* length = UTIL_itoa(tyenvsize); + char* init; + char* some; + char* ref; + + if (neededness == tyenvsize) { + init = UTIL_mallocStr(strlen(length) + 20); + strcpy(init, "(Array.make "); + strcat(init, length); free(length); + strcat(init, " true)"); + } else { + char* num = UTIL_itoa(neededness); + init = UTIL_mallocStr(strlen(length) + strlen(num) + 60); + strcpy(init, "(Array.init "); + strcat(init, length); free(length); + strcat(init, " (fun x -> if x >= "); + strcat(init, num); free(num); + strcat(init, " then false else true))"); + } + some = OC_mkSome(init); free(init); + ref = OC_mkRef(some); free(some); + return ref; +} + + +static char* OC_mkConstVarText(char* constName, char* fixity, char* prec, + char* typrev, char* tyskel, char* tyenvsize, + char* skelneededness, char* neededness, char* codeinfo, + char* constcat, char* varname, char* offset, + char* printName) +{ + char* constVar; + char* ctr = OC_mkDotStr(ABSYN, VCTR_CONSTANT); + char* symbol = OC_mkSymbolAlias(constName, printName); + char* refFalse = OC_mkRef("false"); + char* refTrue = OC_mkRef("true"); + char* index = OC_mkRef(offset); + char* pos = OC_mkDotStr(ERRORMSG, VCTR_NULLPOS); + + size_t length = strlen(ctr) + strlen(symbol) + strlen(fixity) + + strlen(prec) + strlen(typrev) + strlen(tyskel) + strlen(tyenvsize) + + strlen(skelneededness) + strlen(neededness) + strlen(codeinfo) + + strlen(constcat) + strlen(index) + strlen(pos) + strlen(refFalse) * 6 + 35; + char* def = UTIL_mallocStr(length); + + strcpy(def, ctr); free(ctr); + strcat(def, "("); + strcat(def, symbol); free(symbol); + strcat(def, ", "); + strcat(def, fixity); + strcat(def, ", "); + strcat(def, prec); + strcat(def, ", "); + strcat(def, refFalse); + strcat(def, ", "); + strcat(def, refFalse); + strcat(def, ", "); + strcat(def, refTrue); free(refTrue); /* no defs */ + strcat(def, ", "); + strcat(def, refFalse); + strcat(def, ", "); + strcat(def, typrev); + strcat(def, ", "); + strcat(def, refFalse); free(refFalse); + strcat(def, ", "); + strcat(def, tyskel); + strcat(def, ", "); + strcat(def, tyenvsize); + strcat(def, ", "); + strcat(def, skelneededness); + strcat(def, ", "); + strcat(def, neededness); + strcat(def, ", "); + strcat(def, codeinfo); + strcat(def, ", "); + strcat(def, constcat); + strcat(def, ", "); + strcat(def, index); free(index); + strcat(def, ", "); + strcat(def, pos); free(pos); + strcat(def, ")"); + + constVar = OC_mkVarDef(varname, def); free(def); + return constVar; +} + +/* Constant variable definition : + let = Absyn.Constant(Symbol.symbolAlias "" "", + ref , ref , ref false, ref false, ref false, ref false, + ref false, ref , ref false, ref , + ref , ref (Some ), + ref (Some ), ref , + ref , ref 0, Errormsg.none) +*/ +char* OC_mkConstVar(char* constName, OP_Fixity fixity, OP_Prec prec, + UTIL_Bool typrev, char* tySkel, int tyenvsize, + int neededness, OP_Code codeInfo, UTIL_Bool reDef, + char* varName, char* offset, char* printName) +{ + char* constVar; + char* fixityText = OC_mkFixity(fixity); + char* precText = OC_mkPrec(prec); + char* typrevText = OC_mkRefBool(typrev); + char* tySkelText = OC_mkRef(tySkel); + char* tyenvsizeText = OC_mkRefInt(tyenvsize); + char* skelneedednessText = OC_mkSkelNeededness(tyenvsize); + char* needednessText = OC_mkNeededness(neededness, tyenvsize); + char* codeInfoText = OC_mkCodeInfo(codeInfo); + char* constCatText = OC_mkConstCat(reDef); + + constVar = OC_mkConstVarText(constName, fixityText, precText, + typrevText, tySkelText, tyenvsizeText, + skelneedednessText, needednessText, codeInfoText, + constCatText, varName, offset, printName); + + free(fixityText); free(precText); free(typrevText); free(tySkelText); + free(tyenvsizeText); free(skelneedednessText); free(needednessText); + free(codeInfoText); free(constCatText); + + return constVar; +} + +#define GENERICAPPLY "genericApplyConstant" +#define OVERLOADUMINUS "overloadUMinusConstant" +#define OVERLOADABS "overloadAbsConstant" +#define OVERLOADPLUS "overloadPlusConstant" +#define OVERLOADMINUS "overloadMinusConstant" +#define OVERLOADTIME "overloadTimeConstant" +#define OVERLOADLT "overloadLTConstant" +#define OVERLOADGT "overloadGTConstant" +#define OVERLOADLE "overloadLEConstant" +#define OVERLOADGE "overloadGEConstant" + +static char* OC_mkOverLoadConstVar(char* name, char* fixity, char* prec, + char* tyskel, char* varName) +{ + char* constVar; + constVar = OC_mkConstVarText(name, fixity, prec, "ref true", tyskel, + "ref 0", "ref(Some(Array.make 0 true))", "ref None", "ref None", + "ref(Absyn.PervasiveConstant(false))", + varName, "0", name); + return constVar; +} + +/* generate fixed constants */ +char* OC_mkGenericConstVar(char* varList) +{ + char* text; + char* constVar; + + constVar = OC_mkConstVarText(" apply", "ref Absyn.Infixl", + "ref (Absyn.maxPrec + 2)", "ref false", + "ref(Some(Absyn.Skeleton(Absyn.ErrorType, ref None, ref false)))", + "ref 0", "ref(Some(Array.make 0 true))", "ref None", "ref None", + "ref(Absyn.PervasiveConstant(false))", GENERICAPPLY, "0", + " apply"); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + constVar = OC_mkOverLoadConstVar("~", "ref Absyn.Prefix", + "ref (Absyn.maxPrec + 1)", OVERLOADTYSKEL1, + OVERLOADUMINUS); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + + constVar = OC_mkConstVarText("abs", "ref Absyn.NoFixity", + "ref 0", "ref true", + OVERLOADTYSKEL1, + "ref 0", "ref(Some(Array.make 0 true))", + "ref None", "ref None", + "ref(Absyn.PervasiveConstant(true))", + OVERLOADABS, "0", "abs"); + + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + + constVar = OC_mkOverLoadConstVar("+", "ref Absyn.Infixl", "ref 150", + OVERLOADTYSKEL2, OVERLOADPLUS); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + constVar = OC_mkOverLoadConstVar("-", "ref Absyn.Infixl", "ref 150", + OVERLOADTYSKEL2, OVERLOADMINUS); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + constVar = OC_mkOverLoadConstVar("*", "ref Absyn.Infixl", "ref 160", + OVERLOADTYSKEL2, OVERLOADTIME); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + constVar = OC_mkOverLoadConstVar("<", "ref Absyn.Infix", "ref 130", + OVERLOADTYSKEL3, OVERLOADLT); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + constVar = OC_mkOverLoadConstVar(">", "ref Absyn.Infix", "ref 130", + OVERLOADTYSKEL3, OVERLOADGT); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + constVar = OC_mkOverLoadConstVar("<", "ref Absyn.Infix", "ref 130", + OVERLOADTYSKEL3, OVERLOADLE); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + + constVar = OC_mkOverLoadConstVar(">=", "ref Absyn.Infix", "ref 130", + OVERLOADTYSKEL3, OVERLOADGE); + text = UTIL_appendStr(varList, constVar); free(constVar); + varList = UTIL_appendStr(text, "\n\n"); free(text); + return varList; +} + +/* generate fixed constants decs */ +char* OC_mkGenericConstVarDec(char* decList) +{ + char* text; + char* dec; + + dec = OC_mkConstVarDec(GENERICAPPLY); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + dec = OC_mkConstVarDec(OVERLOADUMINUS); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + + dec = OC_mkConstVarDec(OVERLOADABS); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + + dec = OC_mkConstVarDec(OVERLOADPLUS); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + dec = OC_mkConstVarDec(OVERLOADMINUS); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + dec = OC_mkConstVarDec(OVERLOADTIME); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + dec = OC_mkConstVarDec(OVERLOADLT); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + dec = OC_mkConstVarDec(OVERLOADGT); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + dec = OC_mkConstVarDec(OVERLOADLE); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + dec = OC_mkConstVarDec(OVERLOADGE); + text = UTIL_appendStr(decList, dec); free(decList); free(dec); + decList = text; + + return decList; +} + + +/* generate fixed constants entry in buildConstant function */ +char* OC_mkGenericConstTabEntry(char* entries) +{ + char* text; + char* tabEntry; + + tabEntry = OC_mkTabEntry("~", OVERLOADUMINUS); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + + tabEntry = OC_mkTabEntry("abs", OVERLOADABS); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + + tabEntry = OC_mkTabEntry("+", OVERLOADPLUS); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + tabEntry = OC_mkTabEntry("-", OVERLOADMINUS); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + tabEntry = OC_mkTabEntry("*", OVERLOADTIME); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + tabEntry = OC_mkTabEntry("<", OVERLOADLT); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + tabEntry = OC_mkTabEntry(">", OVERLOADGT); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + tabEntry = OC_mkTabEntry("<=", OVERLOADLE); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + tabEntry = OC_mkTabEntry(">=", OVERLOADGE); + text = UTIL_appendStr(entries, tabEntry); + free(tabEntry); free(entries); + entries = text; + + return entries; +} + +/* let buildPervasiveKinds = + function () ->\n \n \n\n */ +char* OC_mkBuildCTabFunc(char* entries) +{ + return OC_mkBuildTabFunc(BUILDPERVCONST, entries); +} + +/* make generaic const is function decs */ +char* OC_mkGenericConstFuncDecs(char* funcDefs) +{ + char* funcName; + char* def; + char* text; + + funcName = OC_mkIsConstFuncName(GENERICAPPLY); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + funcName = OC_mkIsConstFuncName(OVERLOADUMINUS); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + + funcName = OC_mkIsConstFuncName(OVERLOADABS); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + + funcName = OC_mkIsConstFuncName(OVERLOADPLUS); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + funcName = OC_mkIsConstFuncName(OVERLOADMINUS); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + funcName = OC_mkIsConstFuncName(OVERLOADTIME); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + funcName = OC_mkIsConstFuncName(OVERLOADLT); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + funcName = OC_mkIsConstFuncName(OVERLOADGT); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + funcName = OC_mkIsConstFuncName(OVERLOADLE); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + funcName = OC_mkIsConstFuncName(OVERLOADGE); + def = OC_mkIsConstFuncDec(funcName); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = text; + + return funcDefs; +} + + +/* make generaic const is function defs */ +char* OC_mkGenericConstFuncDefs(char* funcDefs) +{ + char* funcName; + char* def; + char* text; + + funcName = OC_mkIsConstFuncName(GENERICAPPLY); + def = OC_mkIsConstFuncDef(funcName, GENERICAPPLY); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + + funcName = OC_mkIsConstFuncName(OVERLOADUMINUS); + def = OC_mkIsConstFuncDef(funcName, OVERLOADUMINUS); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + + funcName = OC_mkIsConstFuncName(OVERLOADABS); + def = OC_mkIsConstFuncDef(funcName, OVERLOADABS); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + + funcName = OC_mkIsConstFuncName(OVERLOADPLUS); + def = OC_mkIsConstFuncDef(funcName, OVERLOADPLUS); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + funcName = OC_mkIsConstFuncName(OVERLOADMINUS); + def = OC_mkIsConstFuncDef(funcName, OVERLOADMINUS); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + funcName = OC_mkIsConstFuncName(OVERLOADTIME); + def = OC_mkIsConstFuncDef(funcName, OVERLOADTIME); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + funcName = OC_mkIsConstFuncName(OVERLOADLT); + def = OC_mkIsConstFuncDef(funcName, OVERLOADLT); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + funcName = OC_mkIsConstFuncName(OVERLOADGT); + def = OC_mkIsConstFuncDef(funcName, OVERLOADGT); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + funcName = OC_mkIsConstFuncName(OVERLOADLE); + def = OC_mkIsConstFuncDef(funcName, OVERLOADLE); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + funcName = OC_mkIsConstFuncName(OVERLOADGE); + def = OC_mkIsConstFuncDef(funcName, OVERLOADGE); free(funcName); + text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs); + funcDefs = UTIL_appendStr(text, "\n\n"); free(text); + + return funcDefs; +} + +char* OC_mkCompare(char* name) +{ + char* text = UTIL_mallocStr(strlen(name) + 15); + strcpy(text, "(const == "); + strcat(text, name); + strcat(text, ")"); + return text; +} + + +char* OC_mkOr(char* operandl, char* operandr) +{ + char* text = UTIL_mallocStr(strlen(operandl) + strlen(operandr) + 5); + strcpy(text, operandl); + strcat(text, " || "); + strcat(text, operandr); + + return text; +} + + +#define PERV_REGCLOB_DEF_BEG "let regClobberingPerv const = \n if (" +#define PERV_REGCLOB_DEF_END ") then true else false \n\n" +char* OC_mkRegClobFunc(char* body) +{ + char* text = UTIL_mallocStr(strlen(PERV_REGCLOB_DEF_BEG) + strlen(body) + + strlen(PERV_REGCLOB_DEF_END)); + strcpy(text, PERV_REGCLOB_DEF_BEG); + strcat(text, body); + strcat(text, PERV_REGCLOB_DEF_END); + + return text; +} + +#define PERV_BCK_DEF_BEG "let backtrackablePerv const = \n if (" +#define PERV_BCK_DEF_END ") then true else false \n\n" +char* OC_mkBackTrackFunc(char* body) +{ + char* text = UTIL_mallocStr(strlen(PERV_BCK_DEF_BEG) + strlen(body) + + strlen(PERV_BCK_DEF_END)); + strcpy(text, PERV_BCK_DEF_BEG); + strcat(text, body); + strcat(text, PERV_BCK_DEF_END); + + return text; +} + + + +/*****************************************************************************/ +/* functions for making the fixed part of pervasive.mli */ +/*****************************************************************************/ +#define TERM_DECS \ +"val implicationTerm : Absyn.aterm\nval andTerm : Absyn.aterm\n" + +#define PERV_FUNC_DECS \ +"val isPerv : Absyn.aconstant -> bool \nval regClobberingPerv : Absyn.aconstant -> bool \nval backtrackablePerv : Absyn.aconstant -> bool\n" + +/* + val pervasiveKinds : Absyn.akind Table.SymbolTable.t + val pervasiveConstants : Absyn.aconstant Table.SymbolTable.t + val pervasiveTypeAbbrevs : Absyn.atypeabbrev Table.SymbolTable.t +*/ +char* OC_mkFixedMLI() +{ + char* kindDec = OC_mkTabDec(PERVKIND, TY_KIND); + char* constDec = OC_mkTabDec(PERVCONST, TY_CONST); + char* tyabbrDec = OC_mkTabDec(PERVTYABBR, TY_TYABBREV); + size_t length = strlen(kindDec) + strlen(constDec) + strlen(tyabbrDec) + + strlen(TERM_DECS) + strlen(PERV_FUNC_DECS) + 10; + char* decs = UTIL_mallocStr(length + 1); + + strcpy(decs, kindDec); free(kindDec); + strcat(decs, constDec); free(constDec); + strcat(decs, tyabbrDec); free(tyabbrDec); + strcat(decs, "\n"); + strcat(decs, TERM_DECS); + strcat(decs, "\n"); + strcat(decs, PERV_FUNC_DECS); + strcat(decs, "\n"); + + return decs; +} + +/*****************************************************************************/ +/* functions for making the fixed part of pervasive.ml */ +/*****************************************************************************/ +#define TERM_DEFS \ +"let andTerm = Absyn.ConstantTerm(andConstant, [], false, Errormsg.none) \nlet implicationTerm = Absyn.ConstantTerm(implConstant, [], false, Errormsg.none)\n" + +#define PERV_ISPERV_DEF \ +"let isPerv const = \n let constCat = Absyn.getConstantType(const) in \n match constCat with \n Absyn.PervasiveConstant(_) -> true \n | _ -> false \n" + +/* + let pervasiveKinds = buildPervasiveKinds () + let pervasiveConstants = buildPervasiveConstants () + let pervasiveTypeAbbrevs = Table.SymbolTable.empty +*/ +char* OC_mkFixedML() +{ + char* kindDef = OC_mkTab(PERVKIND, BUILDPERVKIND); + char* constDef = OC_mkTab(PERVCONST, BUILDPERVCONST); + char* emptyTab = OC_mkDotStr(TABLE, VCTR_EMPTYTAB); + char* tyabbrDef = OC_mkVarDef(PERVTYABBR, emptyTab); + size_t length = strlen(kindDef) + strlen(constDef) + strlen(tyabbrDef) + + strlen(TERM_DEFS) + strlen(PERV_ISPERV_DEF) + 10; + char* defs = UTIL_mallocStr(length + 1); + + free(emptyTab); + strcpy(defs, kindDef); free(kindDef); + strcat(defs, constDef); free(constDef); + strcat(defs, tyabbrDef); free(tyabbrDef); + strcat(defs, "\n\n"); + strcat(defs, TERM_DEFS); + strcat(defs, "\n"); + strcat(defs, PERV_ISPERV_DEF); + strcat(defs, "\n"); + + return defs; +} diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.h b/src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.h new file mode 100644 index 000000000..8b2ba062b --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/ocamlcode.h @@ -0,0 +1,152 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/***************************************************************************/ +/* ocamlcode.h{c}. */ +/* These files contain usful macros and auxiliary functions for generating */ +/* the pervasive.mli and pervasive.ml. */ +/* The parts of the ocaml files that are independent to the pervasives.in */ +/* also reside here. */ +/* The length macros for string macros defined here may be larger than the */ +/* extra lengthes of corresponding strings. This is ok because space and */ +/* time efficiency are not of concern in generating system files. */ +/***************************************************************************/ +#include "types.h" +#include "op.h" +#include "../util/util.h" + +/***************************************************************************/ +/* Functions for making program components */ +/***************************************************************************/ +/* let t = Table.add (Symbol.symbol "") t in\n +*/ +char* OC_mkTabEntry(char* name, char* varName); + + +/****************************************************************************/ +/* functions for making pervasive kind relevant components */ +/****************************************************************************/ +/* k */ +char* OC_mkKVarName(char* name); +/* is */ +char* OC_mkIsKindFuncName(char* name); +/* val : Absyn.akind \n*/ +char* OC_mkKindVarDec(char* kindVarName); +/* val : Absyn.akind -> bool */ +char* OC_mkIsKindFuncDec(char* funcName); +/* let tm = tm == */ +char* OC_mkIsKindFuncDef(char* funcName, char* kindVarName); + + +/* let = Absyn.PervasiveKind(Symbol.symbol "", + (Some ), ref offset, Errormsg.none) +*/ +char* OC_mkKindVar(char* varName, char* kindName, char* arity, char* offset); + +/* let buildPervasiveKinds = + function () ->\n \n \n\n */ +char* OC_mkBuildKTabFunc(char* entries); + +/****************************************************************************/ +/* functions for making pervasive type skeleton components */ +/****************************************************************************/ +/* generating code for type skeleton */ +char* OC_genTySkel(Type tyskel); + +/* tyskel */ +char* OC_mkTySkelVarName(char* number); + +/* Type Skeleton variable definition: + let = Some(Absyn.Skeleton(, ref None, ref false)) +*/ +char* OC_mkTYSkelVar(char* varName, char* tySkel); + +/* generate tyskels for overloaded constants */ +char* OC_mkFixedTySkels(char* tySkels); + + +/****************************************************************************/ +/* functions for making pervasive constants components */ +/****************************************************************************/ +/* Constant */ +char* OC_mkCVarName(char* name); +/* is */ +char* OC_mkIsConstFuncName(char* name); + +/* val : Absyn.aconstant \n*/ +char* OC_mkConstVarDec(char* constVarName); + +/* Constant variable definition : + let = Absyn.Constant(Symbol.symbolAlias "" "", + ref , + ref , ref false, ref false, ref false, ref false, + ref false, ref , ref false, ref , + ref , ref (Some ), ref , + ref , ref offset, Errormsg.none) +*/ +char* OC_mkConstVar(char* constName, OP_Fixity fixity, OP_Prec prec, + UTIL_Bool typrev, char* tySkel, int tyenvsize, + int neededness, OP_Code codeInfo, UTIL_Bool reDef, + char* varName, char* offset, char* printName); + +/* val : Absyn.aconstant -> bool */ +char* OC_mkIsConstFuncDec(char* funcName); + +/* let tm = tm == */ +char* OC_mkIsConstFuncDef(char* funcName, char* constVarName); + +/* generate fixed constants */ +char* OC_mkGenericConstVar(char* varList); +/* generate fixed constants decs */ +char* OC_mkGenericConstVarDec(char* decList); + +/* generate fixed constants entry in buildConstant function */ +char* OC_mkGenericConstTabEntry(char* entries); +/* let buildPervasiveKinds = + function () ->\n \n \n\n */ +char* OC_mkBuildCTabFunc(char* entries); + +/* make generaic const is function decs */ +char* OC_mkGenericConstFuncDecs(char* funcDefs); +/* make generaic const is function defs */ +char* OC_mkGenericConstFuncDefs(char* funcDefs); + + +char* OC_mkCompare(char* name); +char* OC_mkOr(char* operandl, char* operandr); + +char* OC_mkRegClobFunc(char* body); +char* OC_mkBackTrackFunc(char* body); + +/*****************************************************************************/ +/* functions for making the fixed part of pervasive.mli */ +/*****************************************************************************/ +/* + val pervasiveKinds : Absyn.akind Table.SymbolTable.t + val pervasiveConstants : Absyn.aconstant Table.SymbolTable.t + val pervasiveTypeAbbrevs : Absyn.atypeabbrev Table.SymbolTable.t +*/ +char* OC_mkFixedMLI(); + +/*****************************************************************************/ +/* functions for making the fixed part of pervasive.ml */ +/*****************************************************************************/ +/* + let pervasiveKinds = buildPervasiveKinds () + let pervasiveConstants = buildPervasiveConstants () + let pervasiveTypeAbbrevs = Table.SymbolTable.empty +*/ +char* OC_mkFixedML(); diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/op.c b/src/runtime/c/teyjus/tables_gen/pervasives/op.c new file mode 100644 index 000000000..583063e49 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/op.c @@ -0,0 +1,80 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +#include +#include +#include "../util/util.h" +#include "op.h" + +OP_Prec OP_mkPrecMin1() +{ + OP_Prec prec; + prec.cat = OP_PREC; + prec.data.prec = -1; + + return prec; +} + +OP_Prec OP_mkPrecMin2() +{ + OP_Prec prec; + prec.cat = OP_PREC; + prec.data.prec = -2; + + return prec; +} + +OP_Prec OP_mkPrec(int precedence) +{ + OP_Prec prec; + prec.cat = OP_PREC; + prec.data.prec = precedence ; + + return prec; +} + +OP_Prec OP_mkPrecMax() +{ + OP_Prec prec; + prec.cat = OP_PREC_NAME; + prec.data.name = strdup("MAX"); + return prec; +} + +int OP_precIsMax(OP_Prec prec) +{ + if ((prec.cat == OP_PREC_NAME) && (strcmp(prec.data.name, "MAX") == 0)) + return 1; + return 0; +} + + +OP_Code OP_mkCodeInfoNone() +{ + return -1; +} + +OP_Code OP_mkCodeInfo(int ind) +{ + return ind; +} + +int OP_codeInfoIsNone(OP_Code code) +{ + return (code < 0); +} + + diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/op.h b/src/runtime/c/teyjus/tables_gen/pervasives/op.h new file mode 100644 index 000000000..37456c897 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/op.h @@ -0,0 +1,58 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +#ifndef OP_H +#define OP_H + +//fixity type +typedef enum { + OP_INFIX, OP_INFIXL, OP_INFIXR, OP_PREFIX, OP_PREFIXR, OP_POSTFIX, + OP_POSTFIXL, OP_NONE +} OP_Fixity; + +typedef enum { + OP_PREC, OP_PREC_NAME +} OP_PrecTypeCat; + +//precedence type +typedef struct +{ + OP_PrecTypeCat cat; + union + { + int prec; + char* name; + } data; +} OP_Prec; + +OP_Prec OP_mkPrecMin1(); +OP_Prec OP_mkPrecMin2(); +OP_Prec OP_mkPrec(int prec); +OP_Prec OP_mkPrecMax(); + +int OP_precIsMax(OP_Prec prec); + + +//code info type +typedef int OP_Code; + +OP_Code OP_mkCodeInfoNone(); +OP_Code OP_mkCodeInfo(int ind); + +int OP_codeInfoIsNone(OP_Code code); + +#endif + diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.in b/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.in new file mode 100644 index 000000000..2a332da91 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.in @@ -0,0 +1,404 @@ +/% input file for pervasives files generation %/ + +/% section I: pervasive kinds %/ + /% number of pervasive kinds %/ + KIND 7 + /% kind data table %/ + /% index name index_name arity %/ + /* int */ + 0 int int 0 ;; + /* real */ + 1 real real 0 ;; + /* bool */ + 2 o bool 0 ;; + /* string */ + 3 string string 0 ;; + /* list type constructor */ + 4 list list 1 ;; + /* in_stream */ + 5 in_stream instream 0 ;; + /* out_stream */ + 6 out_stream outstream 0 + +/% section II: pervasive constants and their type skeletons %/ + /% section II.I : type skeletion and constant declarations %/ + + /% number of pervasive constants %/ + CONST 94 + /% number of type skeletons %/ + TYPE SKEL 42 + + /% type skeleton and constant data table %/ + /% type skeleton format: + [comments] + TYPE index type %/ + /% constant format: + index name indname tesize neededness typerv redef prec fixity codeinfo + %/ + + /* A */ + TYPE 0 #0 + /* for unnamed universal constants (Note: tesize should be 0)*/ + 85 univ 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + ;; + + /* (list A) */ + TYPE 1 (@ list 1 [#0]) + /* nil */ + 89 nil nil 0 1 0 TRUE FALSE 0 NOFIXITY NOCODE + ;; + + + /* A->(list A)->(list A) */ + TYPE 2 #0 -> (@ list 1 [#0]) -> (@ list 1 [#0]) + /* cons */ + 93 :: cons 0 1 0 TRUE FALSE 140 INFIXR NOCODE + ;; + + /* int */ + TYPE 3 int + /* integer constant */ + 90 intc 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + ;; + + /* real */ + TYPE 4 real + /* real constant */ + 91 realc 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + ;; + + /* string */ + TYPE 5 string + /* string constant */ + 92 strc 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + ;; + + /* o (type of proposition)*/ + TYPE 6 bool + /* true proposition */ + 4 true true 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + /* cut predicate */ + 5 ! cut 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + /* fail predicate */ + 6 fail fail 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + /* halt the system */ + 9 halt halt 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + /* return to top level */ + 10 stop stop 0 0 0 TRUE FALSE 0 NOFIXITY NOCODE + ;; + + /* int -> int */ + TYPE 7 int -> int + /* unary minus on integers */ + 56 %i~ intuminus 0 0 0 TRUE FALSE MAX PREFIX NOCODE - + /* modulus */ + 61 mod mod 0 0 0 TRUE TRUE 160 INFIXL NOCODE + /* integer abs */ + 63 %iabs iabs 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE abs + ;; + + /* int -> int -> int */ + TYPE 8 int -> int -> int + /* addition on integers */ + 57 %i+ intplus 0 0 0 TRUE FALSE 150 INFIXL NOCODE + + /* subtraction on integers */ + 58 %i- intminus 0 0 0 TRUE FALSE 150 INFIXL NOCODE - + /* mutiplication on integers */ + 59 %i* intmult 0 0 0 TRUE FALSE 160 INFIXL NOCODE * + /* integer division */ + 60 div intdiv 0 0 0 TRUE FALSE 160 INFIXL NOCODE + ;; + + /* int -> int -> o */ + TYPE 9 int -> int -> bool + /* less than on integers */ + 19 %i< intlss 0 0 0 TRUE FALSE 130 INFIX 4 < + /* greater than on integers */ + 20 %i> intgrt 0 0 0 TRUE FALSE 130 INFIX 5 > + /* less than or eq on integers */ + 21 %i<= intleq 0 0 0 TRUE FALSE 130 INFIX 6 <= + /* greater than or eq on integers*/ + 22 %i>= intgeq 0 0 0 TRUE FALSE 130 INFIX 7 >= + /* time predicate */ + 51 time time 0 0 0 TRUE TRUE 0 NOFIXITY 36 + ;; + + /* int -> real */ + TYPE 10 int -> real + /* coercion to real */ + 62 int_to_real itor 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* real -> int */ + TYPE 11 real -> int + /* floor function */ + 74 floor floor 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* ceiling function */ + 75 ceil ceil 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* truncation */ + 76 truncate trunc 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* real -> real */ + TYPE 12 real -> real + /* unary minus on real */ + 64 %r~ realuminus 0 0 0 TRUE FALSE MAX PREFIX NOCODE - + /* square root */ + 69 sqrt sqrt 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* sine */ + 70 sin sin 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* cosine */ + 71 cos cos 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* arc tan */ + 72 arctan arctan 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* natural log */ + 73 ln log 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* real abs */ + 77 %rabs rabs 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE rabs + ;; + + /* real -> string */ + TYPE 13 real -> string + /* real to string */ + 84 real_to_string rtos 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* real -> real -> real */ + TYPE 14 real -> real -> real + /* addition on reals */ + 65 %r+ realplus 0 0 0 TRUE FALSE 150 INFIXL NOCODE + + /* subtraction on reals */ + 66 %r- realminus 0 0 0 TRUE FALSE 150 INFIXL NOCODE - + /* multiplication on reals */ + 67 %r* realmult 0 0 0 TRUE FALSE 160 INFIXL NOCODE * + /* division */ + 68 / realdiv 0 0 0 TRUE FALSE 160 INFIXL NOCODE + ;; + + /* real -> real -> o */ + TYPE 15 real -> real -> bool + /* less than in reals */ + 23 %r< reallss 0 0 0 TRUE FALSE 130 INFIX 8 < + /* greater than on reals */ + 24 %r> realgrt 0 0 0 TRUE FALSE 130 INFIX 9 > + /* less than or eq on reals */ + 25 %r<= realleq 0 0 0 TRUE FALSE 130 INFIX 10 <= + /* greater than or eq on reals */ + 26 %r>= realgeq 0 0 0 TRUE FALSE 130 INFIX 11 >= + ;; + + /* string -> int */ + TYPE 16 string -> int + /* string length */ + 79 size slen 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* ord function */ + 81 string_to_int stoi 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* int -> string */ + TYPE 17 int -> string + /* chr function */ + 80 chr itochr 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* int to string */ + 83 int_to_string itostr 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* string -> string -> string */ + TYPE 18 string -> string -> string + /* string concatination */ + 78 ^ scat 0 0 0 TRUE TRUE 150 INFIXL NOCODE + ;; + + /* string -> string -> o */ + TYPE 19 string -> string -> bool + /* less than on strings */ + 27 %s< strlss 0 0 0 TRUE TRUE 130 INFIX 12 < + /* greater than on strings */ + 28 %s> strgrt 0 0 0 TRUE TRUE 130 INFIX 13 > + /* less than or eq on strings */ + 29 %s<= strleq 0 0 0 TRUE TRUE 130 INFIX 14 <= + /* greater than or eq on strings */ + 30 %s>= strgeq 0 0 0 TRUE TRUE 130 INFIX 15 >= + /* getenv predicate; needed? */ + 49 getenv getenv 0 0 0 TRUE TRUE 0 NOFIXITY 34 + ;; + + /* string -> int -> int -> string */ + TYPE 20 string -> int -> int -> string + /* substring */ + 82 substring substr 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* o -> o -> o */ + TYPE 21 bool -> bool -> bool + /* logical and */ + 0 , and 0 0 0 TRUE FALSE 110 INFIXL NOCODE + /* logical or */ + 1 ; or 0 0 0 TRUE FALSE 100 INFIXL NOCODE + /* another logical and */ + 8 & ampand 0 0 0 TRUE FALSE 120 INFIXR NOCODE + /* Prolog if; needed? */ + 11 :- colondash 0 0 0 TRUE FALSE 0 INFIXL NOCODE + /* implication; needed? */ + 12 => impl 0 0 0 TRUE FALSE 130 INFIXR NOCODE + ;; + + /* (A -> o) -> o */ + TYPE 22 (#0 -> bool) -> bool + /* existential quantifier */ + 2 sigma some 1 1 1 FALSE FALSE 0 NOFIXITY NOCODE + /* universal quantifier */ + 3 pi all 1 1 1 FALSE FALSE 0 NOFIXITY NOCODE + ;; + + /* A -> A -> o */ + TYPE 23 #0 -> #0 -> bool + /* is */ + 16 is is 1 1 1 FALSE FALSE 130 INFIX 1 + /* equality (unify) predicate */ + 18 = eq 1 1 1 FALSE FALSE 130 INFIX 3 + ;; + + /* in_stream */ + TYPE 24 instream + /* std_in */ + 86 std_in stdin 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* out_stream */ + TYPE 25 outstream + /* std_out */ + 87 std_out stdout 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + /* std_err */ + 88 std_err stderr 0 0 0 TRUE TRUE 0 NOFIXITY NOCODE + ;; + + /* string -> in_stream -> o */ + TYPE 26 string -> instream -> bool + /* open_in */ + 31 open_in openin 0 0 0 TRUE TRUE 0 NOFIXITY 16 + /* open_string */ + 36 open_string openstr 0 0 0 TRUE TRUE 0 NOFIXITY 21 + ;; + + /* string -> out_stream -> o */ + TYPE 27 string -> outstream -> bool + /* open_out */ + 32 open_out openout 0 0 0 TRUE TRUE 0 NOFIXITY 17 + /* open_append */ + 33 open_append openapp 0 0 0 TRUE TRUE 0 NOFIXITY 18 + ;; + + /* in_stream -> o */ + TYPE 28 instream -> bool + /* close_in */ + 34 close_in closein 0 0 0 TRUE TRUE 0 NOFIXITY 19 + /* eof */ + 41 eof eof 0 0 0 TRUE TRUE 0 NOFIXITY 26 + ;; + + /* out_stream -> o */ + TYPE 29 outstream -> bool + /* close_out */ + 35 close_out closeout 0 0 0 TRUE TRUE 0 NOFIXITY 20 + /* flush */ + 42 flush flush 0 0 0 TRUE TRUE 0 NOFIXITY 27 + ;; + + /* A -> string -> o */ + TYPE 30 #0 -> string -> bool + /* term_to_string */ + 46 term_to_string termtostr 1 1 0 FALSE TRUE 0 NOFIXITY 31 + ;; + + /* string -> A -> o */ + TYPE 31 string -> #0 -> bool + /* string_to_term */ + 47 string_to_term strtoterm 1 1 1 FALSE TRUE 0 NOFIXITY 32 + ;; + + /* out_stream -> string -> o */ + TYPE 32 outstream -> string -> bool + /* output */ + 38 output output 0 0 0 TRUE TRUE 0 NOFIXITY 23 + ;; + + /* in_stream -> int -> string -> o */ + TYPE 33 instream -> int -> string -> bool + /* input */ + 37 input input 0 0 0 TRUE TRUE 0 NOFIXITY 22 + ;; + + /* in_stream -> string -> o */ + TYPE 34 instream -> string -> bool + /* input_line */ + 39 input_line inputline 0 0 0 TRUE TRUE 0 NOFIXITY 24 + /* lookahead */ + 40 lookahead lookahead 0 0 0 TRUE TRUE 0 NOFIXITY 25 + ;; + + /* string -> o */ + TYPE 35 string -> bool + /* print */ + 43 print print 0 0 0 TRUE TRUE 0 NOFIXITY 28 + ;; + + /* A -> o */ + TYPE 36 #0 -> bool + /* read */ + 44 read read 1 1 1 FALSE TRUE 0 NOFIXITY 29 + ;; + + /* out_stream -> A -> o */ + TYPE 37 outstream -> #0 -> bool + /* printterm */ + 45 printterm printterm 1 1 0 FALSE TRUE 0 NOFIXITY 30 + ;; + + /* in_stream -> A -> o */ + TYPE 38 instream -> #0 -> bool + /* readterm */ + 48 readterm readterm 1 1 1 FALSE TRUE 0 NOFIXITY 33 + ;; + + /* o -> o */ + TYPE 39 bool -> bool + /* solve; used by code generator */ + 15 solve solve 0 0 0 TRUE FALSE 0 NOFIXITY 0 + /* not */ + 17 not not 0 0 0 TRUE FALSE 0 NOFIXITY 2 + ;; + + /* string -> int -> in_stream -> out_stream -> o */ + TYPE 40 string -> int -> instream -> outstream -> bool + /* open_socket predicate */ + 50 open_socket opensocket 0 0 0 FALSE TRUE 0 NOFIXITY 35 + ;; + + /* string -> int -> o */ + TYPE 41 string -> int -> bool + /* system predicate */ + 52 system system 0 0 0 FALSE TRUE 0 NOFIXITY 37 + + /% pervasive constant classification %/ + LOGIC SYMBOL 11 + LS_START and LS_END stop + /% logic symbol types %/ + 0 and + 1 or + 2 some + 3 all + 4 l_true + 5 cut + 6 fail + 7 eq + 8 ampand + 9 halt + 10 stop + + PRED SYMBOL 37 + PRED_START solve PRED_END system + + REGCL solve not getenv strtoterm readterm read is lookahead input inputline + + BACKTRACK eq diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.l b/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.l new file mode 100644 index 000000000..e046a63c0 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.l @@ -0,0 +1,96 @@ +%{ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// + +#include "../util/util.h" +#include "op.h" +#include "types.h" +#include "y.tab.h" +#include +#include + +static int commentLev = 0; +%} + +LETTER [A-Za-z] +DIGIT [0-9] +SYMBOL "_"|"+"|"-"|"*"|"/"|"!"|"~"|"@"|"$"|"%"|"^"|"&"|"*"|"<"|">"|"="|"'"|";"|":"|"," + +ID ({LETTER}|{SYMBOL})({LETTER}|{DIGIT}|{SYMBOL})* +NUM {DIGIT}+ +WSPACE [ \t]+ +STRING [^*/]+ + +%x COMMENT C_COMMENT + +/* Some versions of lex require an explicit positions argument */ +%p 10000 + +%% +"\n" {continue; } +"KIND" {return KIND; } +"CONST" {return CONST; } +"TYPE SKEL" {return TYSKEL; } +"TYPE" {return TYPE; } +"->" {return TYARROW; } +"@" {return TYAPP; } +"[" {return LBRACKET; } +"]" {return RBRACKET; } +"(" {return LPAREN; } +")" {return RPAREN; } +"t," {return COMMA; } +"#" {return POUND; } +";;" {return SEMICOLON; } +"INFIX" {return INFIX; } +"INFIXL" {return INFIXL; } +"INFIXR" {return INFIXR; } +"PREFIX" {return PREFIX; } +"PREFIXR" {return PREFIXR; } +"POSTFIX" {return POSTFIX; } +"POSTFIXL" {return POSTFIXL; } +"NOFIXITY" {return NOFIXITY; } +"MIN1" {return MIN1; } +"MIN2" {return MIN2; } +"MAX" {return MAX; } +"NOCODE" {return NOCODE; } +"LOGIC SYMBOL" {return LSSYMB; } +"LS_START" {return LSSTART; } +"LS_END" {return LSEND; } +"PRED SYMBOL" {return PREDSYMB; } +"PRED_START" {return PREDSTART; } +"PRED_END" {return PREDEND; } +"REGCL" {return REGCL; } +"BACKTRACK" {return BACKTRACK; } +"TRUE" {return TRUE; } +"FALSE" {return FALSE; } +{WSPACE} {continue; } +"/%" {commentLev = 1; BEGIN(COMMENT); continue; } +"/*" {BEGIN(C_COMMENT); continue; } +{ID} {yylval.name = strdup(yytext); return ID; } +{NUM} {yylval.isval.ival = atoi(yytext); + yylval.isval.sval = strdup(yytext); + return NUM; } + +"*/" {BEGIN(INITIAL); continue; } +{STRING} {yylval.text = strdup(yytext); return STRING; } + +[^%/\n]+ {continue; } +"/%" {commentLev++; continue; } +"%/" {commentLev--; + if (!commentLev) BEGIN(INITIAL); continue; } + +. {return ERROR; } diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.y b/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.y new file mode 100644 index 000000000..3b55e3aad --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/pervasives.y @@ -0,0 +1,351 @@ +%{ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// + +#include +#include +#include "../util/util.h" +#include "op.h" +#include "types.h" +#include "pervgen-c.h" +#include "pervgen-ocaml.h" +//#include "ops.h" + +extern int yylex(); + +int yywrap() {return 1;} + +void yyerror(const char* str) +{ + printf("Error: Unable to parse input: %s\n", str); +} + +static int tySkelInd = 0; + +%} + +%union +{ + char* name; + char* text; + OP_Fixity fixityType; + OP_Prec precType; + OP_Code codeType; + UTIL_Bool boolType; + struct + { + int ival; + char* sval; + } isval; + Type tyval; + TypeList tylistval; +} + +%token LBRACKET RBRACKET LPAREN RPAREN COMMA POUND SEMICOLON TRUE + FALSE + TYARROW TYAPP + INFIX INFIXL INFIXR PREFIX PREFIXR POSTFIX POSTFIXL NOFIXITY + MIN1 MIN2 MAX + NOCODE + LSSYMB LSSTART LSEND PREDSYMB PREDSTART PREDEND REGCL + BACKTRACK + KIND CONST EMPTY TYSKEL TYPE EMPTYTYPE ERROR + +%token ID +%token NUM +%token STRING + + +%start pervasives +%type comments +%type arrow_tyskel app_tyskel atomic_tyskel +%type tyskel_list +%type ty_index tesize neededness +%type const_name const_ind_name +%type fixity +%type prec +%type code_info +%type redef typrev +%% + +pervasives : kind const_tyskel + ; + +kind : kind_header kind_decls + { cgenKindH(); cgenKindC(); ocamlGenKinds(); } + ; + +kind_header : KIND NUM + { cgenKindInit($2.ival); cgenNumKinds($2.sval); + ocamlGenNumKinds($2.sval); + } + ; + +kind_decls : kind_decl SEMICOLON kind_decls + | kind_decl + ; + +kind_decl : NUM ID ID NUM + { cgenKindIndex($1.ival, $3, $1.sval, NULL); + cgenKindData($1.ival, $2, $4.sval, NULL); + ocamlGenKind($2, $3, $4.sval, $1.sval); } + | comments NUM ID ID NUM + { cgenKindIndex($2.ival, $4, $2.sval, $1); + cgenKindData($2.ival, $3, $5.sval, $1); + ocamlGenKind($3, $4, $5.sval, $2.sval); } + ; + +comments : STRING { $$ = $1;}; + ; + +const_tyskel : const_tyskel_header const_tyskel_decls const_property + { cgenTySkelsH(); cgenTySkelsC(); cgenConstProperty(); + cgenConstH(); cgenConstC(); + ocamlGenConsts(); + } + ; + + +const_tyskel_header : CONST NUM TYSKEL NUM + { cgenNumTySkels($4.sval); cgenTySkelInit($4.ival); + cgenNumConsts($2.sval); cgenConstInit($2.ival); + ocamlGenNumConsts($2.sval); + } + ; + +const_tyskel_decls : const_tyskel_decl SEMICOLON const_tyskel_decls + | const_tyskel_decl + ; + +const_tyskel_decl : tyskel_decl const_decls + ; + +tyskel_decl : TYPE NUM arrow_tyskel + {tySkelInd = $2.ival; + ocamlGenTySkel($2.sval, $3); + cgenTySkelTab($2.ival, $3, NULL); + } + | comments TYPE NUM arrow_tyskel + {tySkelInd = $3.ival; + ocamlGenTySkel($3.sval, $4); + cgenTySkelTab($3.ival, $4, $1); + } + ; + + +arrow_tyskel : app_tyskel TYARROW arrow_tyskel + { $$ = mkArrowType($1, $3); } + | app_tyskel + { $$ = $1; } + ; + +app_tyskel : LPAREN TYAPP ID NUM LBRACKET tyskel_list + RBRACKET RPAREN + {$$ = mkStrType(mkStrFuncType($3,$4.sval), $4.ival, $6);} + | atomic_tyskel + {$$ = $1; } + ; + +atomic_tyskel : ID + { $$ = mkSortType($1); } + | ty_index + { $$ = mkSkVarType($1.sval); } + | LPAREN arrow_tyskel RPAREN + { $$ = $2; } + ; + +tyskel_list : arrow_tyskel COMMA tyskel_list + { $$ = addItem($1, $3); } + | arrow_tyskel + { $$ = addItem($1, NULL); } + +ty_index : POUND NUM {$$ = $2;} + ; + +const_decls : const_decl const_decls + | const_decl + ; + +const_decl : NUM const_name const_ind_name tesize tesize neededness + typrev redef prec fixity code_info + { cgenConstIndex($1.ival, $3, $1.sval, NULL); + cgenConstData($1.ival, $2, $4.sval, $9, $10, tySkelInd, + $5.sval, NULL); + ocamlGenConst($1.sval, $2, $3, $10, $9, $7, $8, + $4.ival, tySkelInd, $6.ival, $11, + $1.sval, $2); + } + | NUM const_name const_ind_name tesize tesize neededness + typrev redef prec fixity code_info const_name + { cgenConstIndex($1.ival, $3, $1.sval, NULL); + cgenConstData($1.ival, $12, $4.sval, $9, $10, tySkelInd, + $5.sval, NULL); + ocamlGenConst($1.sval, $2, $3, $10, $9, $7, $8, + $4.ival, tySkelInd, $6.ival, $11, + $1.sval, $12); + } + | comments NUM const_name const_ind_name tesize tesize + neededness typrev redef prec fixity code_info + { cgenConstIndex($2.ival, $4, $2.sval, $1); + cgenConstData($2.ival, $3, $5.sval, $10, $11, + tySkelInd, $7.sval, $1); + ocamlGenConst($2.sval, $3, $4, $11, $10, $8, $9, + $5.ival, tySkelInd, $7.ival, $12, + $2.sval, $3); + } + | comments NUM const_name const_ind_name tesize tesize + neededness typrev redef prec fixity code_info const_name + { cgenConstIndex($2.ival, $4, $2.sval, $1); + cgenConstData($2.ival, $13, $5.sval, $10, $11, + tySkelInd, $7.sval, $1); + ocamlGenConst($2.sval, $3, $4, $11, $10, $8, $9, + $5.ival, tySkelInd, $7.ival, $12, + $2.sval, $13); + } + ; + +const_name : ID {$$ = $1;} + ; +const_ind_name : ID {$$ = $1;} + ; + +tesize : NUM {$$ = $1;} + ; +neededness : NUM {$$ = $1;} + ; + +typrev : TRUE {$$ = UTIL_TRUE;} + | FALSE {$$ = UTIL_FALSE;} + ; + +redef : TRUE {$$ = UTIL_TRUE;} + | FALSE {$$ = UTIL_FALSE;} + ; + +fixity : INFIX {$$ = OP_INFIX;} + | INFIXL {$$ = OP_INFIXL;} + | INFIXR {$$ = OP_INFIXR;} + | PREFIX {$$ = OP_PREFIX;} + | PREFIXR {$$ = OP_PREFIXR;} + | POSTFIX {$$ = OP_POSTFIX;} + | POSTFIXL {$$ = OP_POSTFIXL;} + | NOFIXITY {$$ = OP_NONE;} + ; + +prec : MIN1 {$$ = OP_mkPrecMin1();} + | MIN2 {$$ = OP_mkPrecMin2();} + | NUM {$$ = OP_mkPrec($1.ival);} + | MAX {$$ = OP_mkPrecMax();} + ; + +code_info : NOCODE {$$ = OP_mkCodeInfoNone();} + | NUM {$$ = OP_mkCodeInfo($1.ival);} + ; + +const_property : logic_symbol pred_symbol regclobber backtrackable + ; + +logic_symbol : ls_header ls_range ls_types + ; + +ls_header : LSSYMB NUM { cgenLogicSymbolInit($2.ival); } + ; + +ls_range : LSSTART const_ind_name LSEND const_ind_name + { cgenLSRange($2, $4);} + ; + +ls_types : ls_type ls_types + | ls_type + ; + +ls_type : NUM ID {cgenLogicSymbType($1.ival, $2, $1.sval);} + ; + +pred_symbol : pred_header pred_range + ; + +pred_header : PREDSYMB NUM + {if ($2.ival == 0) { + fprintf(stderr, + "The number of predicate symbols cannot be 0\n"); + exit(1); + } + } + ; + +pred_range : PREDSTART const_ind_name PREDEND const_ind_name + { cgenPREDRange($2, $4); } + ; + +regclobber : REGCL const_list { ocamlGenRC(); } + ; + +backtrackable : BACKTRACK const_list { ocamlGenBC(); } + ; + +const_list : ID const_list { ocamlCollectConsts($1, 0); } + | ID { ocamlCollectConsts($1, 1); } + ; + +%% + +extern FILE* yyin; + +int main(argc, argv) + int argc; + char * argv[]; +{ + int ret = 0; + char * root = NULL; + if(argc == 1) + { + //printf("No input file specified; using 'Pervasives.in'.\n"); + yyin = UTIL_fopenR("pervasives.in"); + } + else + { + yyin = UTIL_fopenR(argv[1]); + } + + if(argc > 2) + { + root = argv[2]; + } + else + { + //printf("Teyjus source root directory not specified; using '../../'.\n"); + root = "../../"; + } + + //printf("Generating pervasive files...\n"); + + ret = yyparse(); + UTIL_fclose(yyin); + + if(ret != 0) + { + printf("Generation failed.\n"); + return -1; + } + spitCPervasivesH(root); + spitCPervasivesC(root); + //spitOCPervasiveMLI(root); + //spitOCPervasiveML(root); + //printf("Done.\n"); + return 0; +} diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.c b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.c new file mode 100644 index 000000000..c3a4327ad --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.c @@ -0,0 +1,454 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* File pervgen-c.c. This files contains function definitions for generating */ +/* files pervasives.h and pervasives.c. */ +/*****************************************************************************/ +#include +#include +#include +#include "pervgen-c.h" +#include "ccode.h" +#include "../util/util.h" + +//dynamic string array type +typedef struct StringArray +{ + char **array; + int length; +} StringArray; + +//array initialization +static void arrayInit(char **array, int size) +{ + int i ; + for (i =0; i < size; i++) array[i] = NULL; +} + +//collect string in a StringArray into a single array +static char* collectStringArray(StringArray arr, char* emptyText) +{ + char *myText = NULL; + char *myText2 = NULL; + int i; + int length = 0; + + for (i = 0; i < arr.length; i++) { + char* text = arr.array[i]; + if (text == NULL) text = emptyText; + + if (myText) { + myText2 = UTIL_mallocStr(strlen(text) + strlen(myText)); + strcpy(myText2, myText); + strcat(myText2, text); + free(myText); + } else { + myText2 = UTIL_mallocStr(strlen(text)); + strcpy(myText2, text); + } + if (arr.array[i]) free(arr.array[i]); + myText = myText2; + } + free(arr.array); + + return myText; +} + +/****************************************************************************/ +/* kind relevant components */ +/****************************************************************************/ +/***********************************************************************/ +/* pervasives.h */ +/***********************************************************************/ +//number of pervasive kinds +static char* numKinds = NULL; + +void cgenNumKinds(char* num) +{ + numKinds = C_mkNumKinds(num); +} + +//pervasive kind indices declaration +static StringArray kindIndices; //kind indices declaration + +void cgenKindIndex(int index, char* name, char* indexT, char* comments) +{ + char* kindIndex; + char* kindIndexText; + + if (index >= kindIndices.length) { + fprintf(stderr, "kind index exceed total number of kinds\n"); + exit(1); + } + kindIndex = C_mkIndex(name, indexT, comments); + kindIndexText = UTIL_mallocStr(strlen(kindIndex) + 2); + strcpy(kindIndexText, kindIndex); free(kindIndex); + if (index != (kindIndices.length - 1)) strcat(kindIndexText, ","); + strcat(kindIndexText, "\n"); + + kindIndices.array[index] = kindIndexText; +} + +//pervasive kind relevant information in pervasives.h +static char* kindH; +void cgenKindH() +{ + char* emptyText = C_mkEmptyComments(); + + char* kindIndexBody = collectStringArray(kindIndices, emptyText); + char* kindIndexTypeDef = C_mkKindIndexType(kindIndexBody); + + kindH = C_mkKindH(kindIndexTypeDef, numKinds); + free(kindIndexBody); free(kindIndexTypeDef); free(numKinds); + free(emptyText); +} + +/***********************************************************************/ +/* pervasives.c */ +/***********************************************************************/ +//pervasive kind table entries +static StringArray kindData; +void cgenKindData(int index, char* name, char* arity, char* comments) +{ + char* oneKindData; + char* kindDataText; + + if (index >= kindData.length) { + fprintf(stderr, "kind index exceed total number of kinds\n"); + exit(1); + } + oneKindData = C_mkKindTabEntry(name, arity, comments); + kindDataText = UTIL_mallocStr(strlen(oneKindData) + 2); + strcpy(kindDataText, oneKindData); free(oneKindData); + if (index != kindData.length - 1) strcat(kindDataText, ","); + strcat(kindDataText, "\n"); + + kindData.array[index] = kindDataText; +} + +#define EMPTY_TEXT_KIND_TAB " //nothing \n {NULL, 0},\n" + +//pervasive kind relevant information in pervasives.c +static char* kindC; +void cgenKindC() +{ + char* kindTabBody = collectStringArray(kindData, EMPTY_TEXT_KIND_TAB); + char* kindTab = C_mkKindTab(kindTabBody); + + kindC = C_mkKindC(kindTab); + free(kindTabBody); free(kindTab); +} + +//kind indices info and kind table info initiation +void cgenKindInit(int length) +{ + kindIndices.length = length; + kindIndices.array = (char**)UTIL_malloc(sizeof(char*)*length); + arrayInit(kindIndices.array, length); + kindData.length = length; + kindData.array = (char**)UTIL_malloc(sizeof(char*)*length); + arrayInit(kindData.array, length); +} + +/****************************************************************************/ +/* type skeleton relevant components */ +/****************************************************************************/ +/***********************************************************************/ +/* pervasives.h */ +/***********************************************************************/ +//number of type skeletons for pervasive constants +static char* numTySkels = NULL; +void cgenNumTySkels(char* num) +{ + numTySkels = C_mkNumTySkels(num); +} + +//type skeleton relevant information in pervasives.h +static char* tySkelsH; +void cgenTySkelsH() +{ + tySkelsH = C_mkTySkelsH(numTySkels); + free(numTySkels); +} + +/***********************************************************************/ +/* pervasives.c */ +/***********************************************************************/ +//type skeleton creation code +static StringArray tySkels; +void cgenTySkelTab(int index, Type tyskel, char* comments) +{ + if (index >= tySkels.length){ + fprintf(stderr, + "type skeleton index exceed total number of type skeletons\n"); + exit(1); + } + tySkels.array[index] = C_genTySkel(tyskel, comments); +} + +//generate types skeleton initialization code +static char* cgenTySkelTabInit() +{ + char* body = collectStringArray(tySkels, ""); + char* text = C_mkTySkelTabInit(body, C_totalSpace); + + free(body); + return text; +} + +//type skeleton info initiation +void cgenTySkelInit(int length) +{ + if (length == 0) { + fprintf(stderr, "The number of type skeletons cannot be 0\n"); + exit(1); + } + tySkels.length = length; + tySkels.array = (char**)UTIL_malloc(sizeof(char*)*length); + arrayInit(tySkels.array, length); +} + +//type skeleton relevant information in pervasives.c +static char* tySkelsC; +void cgenTySkelsC() +{ + char* tySkelTab = cgenTySkelTabInit(); + tySkelsC = C_mkTySkelsC(tySkelTab); free(tySkelTab); +} + +/****************************************************************************/ +/* constant relevant components */ +/****************************************************************************/ +/***********************************************************************/ +/* pervasives.h */ +/***********************************************************************/ +//number of pervasive constants +static char* numConsts = NULL; +void cgenNumConsts(char* num) +{ + numConsts = C_mkNumConsts(num); +} + +//pervasive constant indices declaration +static StringArray constIndices; + +void cgenConstIndex(int index, char* name, char* indexT, char* comments) +{ + char* constIndex; + char* constIndexText; + + if (index >= constIndices.length) { + fprintf(stderr, "constant index exceed total number of constants\n"); + exit(1); + } + constIndex = C_mkIndex(name, indexT, comments); + constIndexText = UTIL_mallocStr(strlen(constIndex) + 2); + strcpy(constIndexText, constIndex); + if (index != (constIndices.length - 1)) strcat(constIndexText, ","); + strcat(constIndexText, "\n"); + + constIndices.array[index] = constIndexText; +} + +/***********************************************************************/ +/* constant property functions */ +/***********************************************************************/ +static StringArray logicSymbTypes; +//initiale logic symb types +void cgenLogicSymbolInit(int length) +{ + logicSymbTypes.length = length; + logicSymbTypes.array = (char**)UTIL_malloc(sizeof(char*)*length); + arrayInit(logicSymbTypes.array, length); +} + +//generate logic symbol types +void cgenLogicSymbType(int index, char* name, char* indexT) +{ + char* constIndex; + char* constIndexText; + + if (index >= logicSymbTypes.length) { + fprintf(stderr, "logic symbol type index exceed the total number of logic symbols\n"); + exit(1); + } + constIndex = C_mkIndex2(name, indexT); + constIndexText = UTIL_mallocStr(strlen(constIndex) + 2); + strcpy(constIndexText, constIndex); + if (index != (constIndices.length - 1)) strcat(constIndexText, ","); + strcat(constIndexText, "\n"); + + logicSymbTypes.array[index] = constIndexText; +} + +static char* lsRange = NULL; +//generate logic symbol start/end position +void cgenLSRange(char* start, char* end) +{ + lsRange = C_mkLSRange(start, end); +} + + +static char* predRange = NULL; +//generate predicate symbol start/end position +void cgenPREDRange(char* start, char* end) +{ + predRange = C_mkPredRange(start, end); +} + + +static char* constProperty = NULL; +void cgenConstProperty() +{ + char* emptyText = C_mkEmptyComments(); + char* logicSymbTypeBody = collectStringArray(logicSymbTypes, emptyText); + char* logicSymbTypeDec = C_mkLSTypeDec(logicSymbTypeBody); + + constProperty = UTIL_mallocStr(strlen(logicSymbTypeDec) + strlen(lsRange) + + strlen(predRange)); + strcpy(constProperty, lsRange); + strcat(constProperty, predRange); + strcat(constProperty , logicSymbTypeDec); + + free(emptyText); free(logicSymbTypeBody); free(logicSymbTypeDec); + free(lsRange); free(predRange); +} + + +//pervasive kind relevant information in pervasives.h +static char* constH; +void cgenConstH() +{ + char* emptyText = C_mkEmptyComments(); + char* constIndexBody = collectStringArray(constIndices, emptyText); + char* constIndexTypeDef = C_mkConstIndexType(constIndexBody); + + constH = C_mkConstH(constIndexTypeDef, numConsts, constProperty); + free(constIndexBody); free(constIndexTypeDef); + free(emptyText); free(constProperty); +} + +/***********************************************************************/ +/* pervasives.c */ +/***********************************************************************/ +//pervasive const table entries +static StringArray constData; +void cgenConstData(int index, char* name, char* tesize, OP_Prec prec, + OP_Fixity fixity, int tySkelInd, char* neededness, + char* comments) +{ + char* oneConstData; + char* constDataText; + char* tySkelIndText = UTIL_itoa(tySkelInd); + + if (index >= constData.length) { + fprintf(stderr, "const index exceed total number of consts\n"); + exit(1); + } + oneConstData = C_mkConstTabEntry(name, tesize, prec, fixity, tySkelIndText, + neededness, comments); + free(tySkelIndText); + constDataText = UTIL_mallocStr(strlen(oneConstData) + 2); + strcpy(constDataText, oneConstData); free(oneConstData); + if (index != constData.length - 1) strcat(constDataText, ","); + strcat(constDataText, "\n"); + + constData.array[index] = constDataText; +} + +#define EMPTY_TEXT_CONST_TAB \ +" //nothing\n {NULL, 0, 0, 0, 0, OP_NONE },\n" + +//pervasive const relevant information in pervasives.c +static char* constC; +void cgenConstC() +{ + char* constTabBody = collectStringArray(constData, EMPTY_TEXT_CONST_TAB); + char* constTab = C_mkConstTab(constTabBody); + + constC = C_mkConstC(constTab); + free(constTabBody); free(constTab); +} + + +//const indices info and const table info initiation +void cgenConstInit(int length) +{ + constIndices.length = length; + constIndices.array = (char**)UTIL_malloc(sizeof(char*)*length); + arrayInit(constIndices.array, length); + constData.length = length; + constData.array = (char**)UTIL_malloc(sizeof(char*)*length); + arrayInit(constData.array, length); +} + + +/****************************************************************************/ +/* Writing files */ +/****************************************************************************/ +static char* pervBegH; +static char* pervEndH; +static void cgenFixedH() +{ + pervBegH = C_mkFixedBegH(); + pervEndH = C_mkFixedEndH(); +} + +static char* pervBegC; +static char* pervEndC; +static void cgenFixedC() +{ + pervBegC = C_mkFixedBegC(); + pervEndC = C_mkFixedEndC(); +} + +/* dump peravsives.h */ +void spitCPervasivesH(char * root) +{ + FILE* outFile; + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "tables/pervasives.h"); + + outFile = UTIL_fopenW(filename); + cgenFixedH(); + fprintf(outFile, "%s\n", pervBegH); free(pervBegH); + fprintf(outFile, "%s\n", kindH); free(kindH); + fprintf(outFile, "%s\n", tySkelsH); free(tySkelsH); + fprintf(outFile, "%s\n", constH); free(constH); + fprintf(outFile, "%s\n", pervEndH); free(pervEndH); + UTIL_fclose(outFile); + free(filename); +} + +/* dump pervasives.c */ +void spitCPervasivesC(char * root) +{ + FILE* outFile; + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "tables/pervasives.c"); + outFile = UTIL_fopenW(filename); + cgenFixedC(); + fprintf(outFile, "%s\n", pervBegC); free(pervBegC); + fprintf(outFile, "%s\n", kindC); free(kindC); + fprintf(outFile, "%s\n", tySkelsC); free(tySkelsC); + fprintf(outFile, "%s\n", constC); free(constC); + fprintf(outFile, "%s\n", pervEndC); free(pervEndC); + UTIL_fclose(outFile); + free(filename); +} diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.h b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.h new file mode 100644 index 000000000..294d1e6bf --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-c.h @@ -0,0 +1,95 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* File pervgen-c.h. This files contains function definitions for generating */ +/* files pervasives.h and pervasives.c. */ +/*****************************************************************************/ +#include "types.h" +#include "op.h" + +/****************************************************************************/ +/* kind relevant components */ +/****************************************************************************/ +//kind indices info and kind table info initiation +void cgenKindInit(int size); + +//number of pervasive kinds +void cgenNumKinds(char* num); +//pervasive kind indices declaration +void cgenKindIndex(int index, char* name, char* indexT, char* comments); +//pervasive kind relevant information in pervasives.h +void cgenKindH(); + +//pervasive kind table entries +void cgenKindData(int index, char* name, char* arity, char* comments); +//pervasive kind relevant information in pervasives.c +void cgenKindC(); + +/****************************************************************************/ +/* type skeleton relevant components */ +/****************************************************************************/ +//number of type skeletons for pervasive constants +void cgenNumTySkels(char* num); +//type skeleton relevant information in pervasives.h +void cgenTySkelsH(); + +//type skeleton creation code +void cgenTySkelTab(int index, Type tyskel, char* comments); +//type skeleton info initiation +void cgenTySkelInit(int length); +//type skeleton relevant information in pervasives.c +void cgenTySkelsC(); + + +/****************************************************************************/ +/* constant relevant components */ +/****************************************************************************/ +//const indices info and const table info initiation +void cgenConstInit(int length); + +//number of pervasive constants +void cgenNumConsts(char* num); +//pervasive constant indices declaration +void cgenConstIndex(int index, char* name, char* indexT, char* comments); +//pervasive constant relevant information in pervasives.h +void cgenConstH(); + + +//pervasive constant table entries +void cgenConstData(int index, char* name, char* tesize, OP_Prec prec, + OP_Fixity fixity, int tySkelInd, char* neededness, + char* comments); +//pervasive const relevant information in pervasives.c +void cgenConstC(); + +//initiale logic symb types +void cgenLogicSymbolInit(int length); +//generate logic symbol types +void cgenLogicSymbType(int index, char* name, char* indexText); +//generate logic symbol start/end position +void cgenLSRange(char* start, char* end); +//generate predicate symbol start/end position +void cgenPREDRange(char* start, char* end); +void cgenConstProperty(); + +/****************************************************************************/ +/* Writing files */ +/****************************************************************************/ +/* dump files pervasives.h */ +void spitCPervasivesH(char * root); +/* dump files pervasives.c */ +void spitCPervasivesC(char * root); diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.c b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.c new file mode 100644 index 000000000..5bd932ffb --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.c @@ -0,0 +1,350 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* File pervgen-ocaml.c. This files contains function definitions for */ +/* generating files pervasive.mli and pervasive.ml. */ +/*****************************************************************************/ +#include +#include +#include +#include "pervgen-ocaml.h" +#include "ocamlcode.h" + + +static char* addLine(char* str, char* addOn) +{ + size_t length = (str ? strlen(str) : 0) + strlen(addOn) + 2; + char* newStr = UTIL_mallocStr(length); + + if (str) { + strcpy(newStr, str); + strcat(newStr, addOn); + } else strcpy(newStr, addOn); + strcat(newStr, "\n\n"); + return newStr; +} + +static char* addStr(char* str, char* addOn) +{ + size_t length = (str ? strlen(str) : 0) + strlen(addOn); + char* newStr = UTIL_mallocStr(length); + + if (str) { + strcpy(newStr, str); + strcat(newStr, addOn); + } else strcpy(newStr, addOn); + return newStr; +} + +/**************************************************************************/ +/* generating pervasive kind relevant part */ +/**************************************************************************/ +static char* numKindsML = NULL; +static char* numKindsMLI = NULL; + +void ocamlGenNumKinds(char* number) +{ + numKindsMLI = strdup("val numberPervasiveKinds : int"); + numKindsML = addStr("let numberPervasiveKinds = ", number); +} + +static char* kindVarList = NULL; //kind variable definitions +static char* buildPervKindBody = NULL; //buildPervKind function defs +static char* kindVarDecs = NULL; //kind vars in signature +static char* isKindFuncDecs = NULL; //is kind function decs +static char* isKindFuncDefs = NULL; //is kind function defs +void ocamlGenKind(char* kindName, char* kVarName, char* arity, char* offset) +{ + char* kindVarName = OC_mkKVarName(kVarName); + char* funcName = OC_mkIsKindFuncName(kindVarName); + char* kindVar = OC_mkKindVar(kindVarName, kindName, arity, offset); + char* kindTabEntry = OC_mkTabEntry(kindName, kindVarName); + char* kindVarDec = OC_mkKindVarDec(kindVarName); + char* funcDec = OC_mkIsKindFuncDec(funcName); + char* funcDef = OC_mkIsKindFuncDef(funcName, kindVarName); + char *myKindVarList, *myBuildPervKindBody, *myKindVarDecs, + *myisKindFuncDecs, *myisKindFuncDefs; + + free(kindVarName); + + myKindVarList = addLine(kindVarList, kindVar); + free(kindVarList); free(kindVar); + kindVarList = myKindVarList; + + myBuildPervKindBody = addStr(buildPervKindBody, kindTabEntry); + free(buildPervKindBody); free(kindTabEntry); + buildPervKindBody = myBuildPervKindBody; + + myKindVarDecs = addStr(kindVarDecs, kindVarDec); + free(kindVarDecs); free(kindVarDec); + kindVarDecs = myKindVarDecs; + + myisKindFuncDecs = addStr(isKindFuncDecs, funcDec); + free(isKindFuncDecs); free(funcDec); + isKindFuncDecs = myisKindFuncDecs; + + myisKindFuncDefs = addLine(isKindFuncDefs, funcDef); + free(isKindFuncDefs); free(funcDef); + isKindFuncDefs = myisKindFuncDefs; +} + +static char* kindML = NULL; //kind relevant code in pervasive.ml +static char* kindMLI = NULL; //kind relevant code in pervasive.mli + +void ocamlGenKinds() +{ + char* buildTabFunc = OC_mkBuildKTabFunc(buildPervKindBody); + size_t length = strlen(kindVarList) + strlen(buildTabFunc) + + strlen(isKindFuncDefs) + strlen(numKindsML) + 4; + + kindML = UTIL_mallocStr(length); + strcpy(kindML, kindVarList); + strcat(kindML, "\n"); + strcat(kindML, numKindsML); + strcat(kindML, "\n\n"); + strcat(kindML, buildTabFunc); + strcat(kindML, "\n"); + strcat(kindML, isKindFuncDefs); + + free(buildPervKindBody); free(buildTabFunc); free(kindVarList); + free(isKindFuncDefs); free(numKindsML); + + length = strlen(kindVarDecs) + strlen(isKindFuncDecs) + + strlen(numKindsMLI) + 4; + kindMLI = UTIL_mallocStr(length); + strcpy(kindMLI, kindVarDecs); + strcat(kindMLI, "\n\n"); + strcat(kindMLI, numKindsMLI); + strcat(kindMLI, "\n\n"); + strcat(kindMLI, isKindFuncDecs); + free(kindVarDecs); free(isKindFuncDecs); free(numKindsMLI); +} + +/**************************************************************************/ +/* generating pervasive type skeleton relevant part */ +/**************************************************************************/ +static char* tySkelVarList = NULL; //type skel vars + +void ocamlGenTySkel(char* ind, Type tySkel) +{ + char* varName = OC_mkTySkelVarName(ind); + char* tySkelText = OC_genTySkel(tySkel); + char* tySkelVarDef = OC_mkTYSkelVar(varName, tySkelText); + size_t length = (tySkelVarList ? strlen(tySkelVarList) : 0) + + strlen(tySkelVarDef) + 1; + char* mytySkelVarList = UTIL_mallocStr(length + 1); + + free(varName); free(tySkelText); + + mytySkelVarList = addLine(tySkelVarList, tySkelVarDef); + free(tySkelVarList); free(tySkelVarDef); + tySkelVarList = mytySkelVarList; +} + +/**************************************************************************/ +/* generating pervasive constants relevant part */ +/**************************************************************************/ +static char* numConstsML = NULL; +static char* numConstsMLI = NULL; + +void ocamlGenNumConsts(char* number) +{ + numConstsMLI = strdup("val numberPervasiveConstants : int"); + numConstsML = addStr("let numberPervasiveConstants = ", number); +} + +static char* constVarList = NULL; //constant vars +static char* buildPervConstBody = NULL; //buildPervConst function defs +static char* constVarDecs = NULL; //constant vars in signature +static char* isConstFuncDecs = NULL; //is constant function decs +static char* isConstFuncDefs = NULL; //is constant function defs + +void ocamlGenConst(char* ind, char* name, char* cVarName, OP_Fixity fixity, + OP_Prec prec, UTIL_Bool tyPrev, UTIL_Bool redef, int tesize, + int tyskelInd, int neededness, OP_Code codeInfo, + char* offset, char *printName) +{ + char* constVarName = OC_mkCVarName(cVarName); + char* funcName = OC_mkIsConstFuncName(constVarName); + char* tyskelText = UTIL_itoa(tyskelInd); + char* tyskelName = OC_mkTySkelVarName(tyskelText); + + char* constVar = OC_mkConstVar(name, fixity, prec, tyPrev, tyskelName, + tesize, neededness, codeInfo, redef, + constVarName, offset, printName); + char* constTabEntry = OC_mkTabEntry(name, constVarName); + char* constVarDec = OC_mkConstVarDec(constVarName); + char* funcDec = OC_mkIsConstFuncDec(funcName); + char* funcDef = OC_mkIsConstFuncDef(funcName, constVarName); + + char *myConstVarList, *myBuildPervConstBody, *myConstVarDecs, + *myisConstFuncDecs, *myisConstFuncDefs; + + free(constVarName); free(funcName); free(tyskelName); free(tyskelText); + + myConstVarList = addLine(constVarList, constVar); + free(constVarList); free(constVar); + constVarList = myConstVarList; + + myBuildPervConstBody = addStr(buildPervConstBody, constTabEntry); + free(buildPervConstBody); free(constTabEntry); + buildPervConstBody = myBuildPervConstBody; + + myConstVarDecs = addStr(constVarDecs, constVarDec); + free(constVarDecs); free(constVarDec); + constVarDecs = myConstVarDecs; + + myisConstFuncDecs = addStr(isConstFuncDecs, funcDec); + free(isConstFuncDecs); free(funcDec); + isConstFuncDecs = myisConstFuncDecs; + + myisConstFuncDefs = addLine(isConstFuncDefs, funcDef); + free(isConstFuncDefs); free(funcDef); + isConstFuncDefs = myisConstFuncDefs; +} + +static char* constMLI = NULL; //const relevant code in pervasive.mli +static char* constML = NULL; //const relevant code in pervasive.ml + +void ocamlGenConsts() +{ + char* tyskels = OC_mkFixedTySkels(tySkelVarList); + char* varDefs = OC_mkGenericConstVar(constVarList); + char* varDecs = OC_mkGenericConstVarDec(constVarDecs); + char* buildFuncBody = OC_mkGenericConstTabEntry(buildPervConstBody); + char* buildTabFunc = OC_mkBuildCTabFunc(buildFuncBody); + char* funcDefs = OC_mkGenericConstFuncDefs(isConstFuncDefs); + char* funcDecs = OC_mkGenericConstFuncDecs(isConstFuncDecs); + + + size_t length = strlen(varDefs) + strlen(buildTabFunc) + strlen(funcDefs) + + strlen(numConstsML) + 4; + + tySkelVarList = tyskels; + + constML = UTIL_mallocStr(length); + strcpy(constML, varDefs); free(varDefs); + strcat(constML, "\n"); + strcat(constML, numConstsML); free(numConstsML); + strcat(constML, "\n\n"); + strcat(constML, buildTabFunc); free(buildTabFunc); free(buildFuncBody); + strcat(constML, "\n"); + strcat(constML, funcDefs); free(funcDefs); + + length = strlen(varDecs) + strlen(funcDecs) + strlen(numConstsMLI) + 4; + constMLI = UTIL_mallocStr(length); + + strcpy(constMLI, varDecs); free(varDecs); + strcat(constMLI, "\n\n"); + strcat(constMLI, numConstsMLI); free(numConstsMLI); + strcat(constMLI, "\n\n"); + strcat(constMLI, funcDecs); free(funcDecs); +} + +static char* constProperty = NULL; +void ocamlCollectConsts(char* name, int last) +{ + char* constName = OC_mkCVarName(name); + char* cond = OC_mkCompare(constName); + char* body; + + free(constName); + if (last) body = cond; + else { + if (constProperty) { + body = OC_mkOr(cond, constProperty); + free(constProperty); + free(cond); + } else body = cond; + } + constProperty = body; +} + +static char* regClob = NULL; +void ocamlGenRC() +{ + regClob = OC_mkRegClobFunc(constProperty); + free(constProperty); + constProperty = NULL; +} + +static char* backTrack = NULL; +void ocamlGenBC() +{ + backTrack = OC_mkBackTrackFunc(constProperty); + free(constProperty); + constProperty = NULL; +} + +/**************************************************************************/ +/* generating fixed part of pervasive.ml and pervasive.mli */ +/**************************************************************************/ +static char* fixedML = NULL; //fixed part of pervasive.ml +static char* fixedMLI = NULL; //fixed part of pervasive.mli + +static void ocamlGenFixedML() +{ + fixedML = OC_mkFixedML(); +} +static void ocamlGenFixedMLI() +{ + fixedMLI = OC_mkFixedMLI(); +} + +/***************************************************************************/ +/* Dump code into pervasive.ml and pervasive.mli */ +/***************************************************************************/ +/* dump peravsive.ml */ +void spitOCPervasiveML(char * root) +{ + FILE* outFile; + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "compiler/pervasive.ml"); + outFile = UTIL_fopenW(filename); + + ocamlGenFixedML(); + fprintf(outFile, "%s\n\n", kindML); free(kindML); + fprintf(outFile, "%s\n\n", tySkelVarList); free(tySkelVarList); + fprintf(outFile, "%s\n\n", constML); free(constML); + fprintf(outFile, "%s\n\n", fixedML); free(fixedML); + fprintf(outFile, "%s\n\n", regClob); free(regClob); + fprintf(outFile, "%s\n\n", backTrack); free(backTrack); + + + UTIL_fclose(outFile); + free(filename); +} + +/* dump peravsive.mli */ +void spitOCPervasiveMLI(char * root) +{ + FILE* outFile; + char * filename = malloc(strlen(root) + 32); + strcpy(filename, root); + strcat(filename, "compiler/pervasive.mli"); + outFile = UTIL_fopenW(filename); + + ocamlGenFixedMLI(); + fprintf(outFile, "%s\n\n", kindMLI); free(kindMLI); + fprintf(outFile, "%s\n\n", constMLI); free(constMLI); + fprintf(outFile, "%s\n\n", fixedMLI); free(fixedMLI); + UTIL_fclose(outFile); + free(filename); +} + + diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.h b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.h new file mode 100644 index 000000000..4acc4d6cb --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/pervgen-ocaml.h @@ -0,0 +1,60 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/*****************************************************************************/ +/* File pervgen-ocaml.c. This files contains function definitions for */ +/* generating files pervasive.mli and pervasive.ml. */ +/*****************************************************************************/ +#include "op.h" +#include "types.h" +#include "../util/util.h" + +/**************************************************************************/ +/* generating pervasive kind relevant part */ +/**************************************************************************/ +void ocamlGenNumKinds(char* number); +void ocamlGenKind(char* kindName, char* kVarName, char* arity, char* offset); +void ocamlGenKinds(); + +/**************************************************************************/ +/* generating pervasive type skeleton relevant part */ +/**************************************************************************/ +void ocamlGenTySkel(char* ind, Type tySkel); + +/**************************************************************************/ +/* generating pervasive constants relevant part */ +/**************************************************************************/ +void ocamlGenNumConsts(char* number); +void ocamlGenConst(char* ind, char* name, char* cVarName, OP_Fixity fixity, + OP_Prec prec, UTIL_Bool tyPrev, UTIL_Bool redef, int tesize, + int tyskelInd, int neededness, OP_Code codeInfo, + char* offset, char* printName); + +void ocamlGenConsts(); + +void ocamlCollectConsts(char* name, int last); + +void ocamlGenRC(); +void ocamlGenBC(); +/***************************************************************************/ +/* Dump code into pervasive.ml and pervasive.mli */ +/***************************************************************************/ +/* dump peravsive.ml */ +void spitOCPervasiveML(char * root); +/* dump peravsive.mli */ +void spitOCPervasiveMLI(char * root); + + diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/types.c b/src/runtime/c/teyjus/tables_gen/pervasives/types.c new file mode 100644 index 000000000..9418992c1 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/types.c @@ -0,0 +1,114 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* File types.c. This file contains "abstract syntax" representation of */ +/* type skeletons that is used for parsing those in pervasives.in. */ +/****************************************************************************/ +#include +#include "types.h" +#include "../util/util.h" + +Type mkSortType(char* name) +{ + Type rtPtr = (Type)UTIL_malloc(sizeof(Type_)); + rtPtr -> tag = SORT; + rtPtr -> data.sort = name; + return rtPtr; +} + +Type mkSkVarType(char* index) +{ + Type rtPtr = (Type)UTIL_malloc(sizeof(Type_)); + rtPtr -> tag = SKVAR; + rtPtr -> data.skvar = index; + return rtPtr; +} + +Type mkStrFuncType(char* name, char* arity) +{ + Type rtPtr = (Type)UTIL_malloc(sizeof(Type_)); + rtPtr -> tag = FUNC; + rtPtr -> data.func.name = name; + rtPtr -> data.func.arity = arity; + return rtPtr; +} + + +Type mkStrType(Type func, int arity, TypeList args) +{ + Type rtPtr = (Type)UTIL_malloc(sizeof(Type_)); + rtPtr -> tag = STR; + rtPtr -> data.str.functor = func; + rtPtr -> data.str.arity = arity; + rtPtr -> data.str.args = args; + return rtPtr; +} + +Type mkArrowType(Type lop, Type rop) +{ + Type rtPtr = (Type)UTIL_malloc(sizeof(Type_)); + rtPtr -> tag = ARROW; + rtPtr -> data.arrow.lop = lop; + rtPtr -> data.arrow.rop = rop; + return rtPtr; + +} + +void freeType(Type ty) +{ + if (ty -> tag == SORT) free(ty->data.sort); + else if (ty -> tag == SKVAR) free(ty->data.skvar); + else if (ty -> tag == FUNC) { + free(ty->data.func.name); + free(ty->data.func.arity); + } + free(ty); +} + + +TypeList addItem(Type data, TypeList typeList) +{ + TypeList new = (TypeList)UTIL_malloc(sizeof(TypeList_)); + new -> oneType = data; + if (typeList) new -> next = typeList; + else new -> next = NULL; + typeList = new; + return typeList; +} + +TypeList addItemToEnd(TypeList typeList, Type data) +{ + TypeList new = (TypeList)UTIL_malloc(sizeof(TypeList_)); + new -> oneType = data; + new -> next = NULL; + if (typeList) { + TypeList temp = typeList; + while (temp -> next) temp = temp -> next; + temp -> next = new; + } else typeList = new; + return typeList; +} + +TypeList append(TypeList typeList1, TypeList typeList2) +{ + if (typeList1) { + TypeList temp = typeList1; + while (temp -> next) temp = temp -> next; + temp -> next = typeList2; + } else typeList1 = typeList2; + return typeList1; +} diff --git a/src/runtime/c/teyjus/tables_gen/pervasives/types.h b/src/runtime/c/teyjus/tables_gen/pervasives/types.h new file mode 100644 index 000000000..4aae0fc56 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/pervasives/types.h @@ -0,0 +1,92 @@ +////////////////////////////////////////////////////////////////////////////// +// 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 . // +////////////////////////////////////////////////////////////////////////////// +/****************************************************************************/ +/* File types.h. This file contains "abstract syntax" representation of */ +/* type skeletons that is used for parsing those in pervasives.in. */ +/****************************************************************************/ +#ifndef TYPES_H +#define TYPES_H + +typedef struct Type_ *Type; +typedef struct TypeList_ *TypeList; + +//type arrow information +typedef struct ArrowInfo +{ + Type lop; + Type rop; +} ArrowInfo; + +//structure functor information +typedef struct FuncInfo +{ + char *name; + char *arity; +} FuncInfo; + +//type structure information +typedef struct StrInfo +{ + Type functor; + int arity; + TypeList args; +} StrInfo; + +//type skeleton category +typedef enum { + SORT, SKVAR, ARROW, STR, FUNC +} TypeCats; + +//type representation +typedef struct Type_ +{ + TypeCats tag; + union + { + char* sort; + char* skvar; + FuncInfo func; + ArrowInfo arrow; + StrInfo str; + } data; +} Type_; + +//type list representation +typedef struct TypeList_ +{ + Type oneType; + TypeList next; +} TypeList_; + + +Type mkSortType(char* name); +Type mkSkVarType(char* index); +Type mkStrFuncType(char* name, char* arity); +Type mkStrType(Type name, int arity, TypeList args); +Type mkArrowType(Type lop, Type rop); +void freeType(Type ty); + + +TypeList addItem(Type data, TypeList typeList); +TypeList addItemToEnd(TypeList typeList, Type data); +TypeList append(TypeList typeList1, TypeList typeList2); + +#endif //TYPES_H + + + + diff --git a/src/runtime/c/teyjus/tables_gen/util/util.c b/src/runtime/c/teyjus/tables_gen/util/util.c new file mode 100644 index 000000000..502bfa68f --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/util/util.c @@ -0,0 +1,135 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +#include +#include +#include +#include "util.h" + + +/**************************************************************************/ +/* Space allocation */ +/**************************************************************************/ +/* allocate space of n bytes*/ +void* UTIL_malloc(size_t n) +{ + void* ptr = (void*)malloc(n); + if (ptr) return ptr; + printf("Error : cannot allocate space\n"); + exit(1); + +} + + +/* allocate space for a string of given size */ +char* UTIL_mallocStr(size_t size) +{ + char* ptr = (char*)malloc(sizeof(char)*(size + 1)); + if (ptr) return ptr; + + printf("Error : cannot allocate space\n"); + exit(1); +} + + +/**************************************************************************/ +/* string operation */ +/**************************************************************************/ +/* Append two strings */ +char* UTIL_appendStr(char* str1, char* str2) +{ + size_t length = strlen(str1) + strlen(str2); + char* ptr = UTIL_mallocStr(length + 1); + + strcpy(ptr, str1); + strcat(ptr, str2); + + return ptr; +} + + +//convert lower case letters in a string to upper case ones +char* UTIL_upperCase(char* str) +{ + char *newstr, *tmp; + newstr = strdup(str); + tmp = newstr; + while ((*tmp) != '\0'){ + if ((97 <= (int)*tmp) && ((int)*tmp <= 122)) + *tmp = (char)((int)*tmp - 32); + tmp++; + } + return newstr; +} + +//convert to lower cases +char* UTIL_lowerCase(char* str) +{ + char *newstr, *tmp; + newstr = strdup(str); + tmp = newstr; + while ((*tmp) != '\0'){ + if ((65 <= (int)*tmp) && ((int)*tmp) <= 90) + *tmp = (char)((int)*tmp + 32); + tmp++; + } + return newstr; +} + +//covert an non-negtive integer to string +char* UTIL_itoa(int num) +{ + char *str = UTIL_mallocStr(33); + sprintf(str, "%d", num); + return str; +} + + +/**************************************************************************/ +/* file operation */ +/**************************************************************************/ + +/* open file in read mode */ +FILE* UTIL_fopenR(char* filename) +{ + FILE* filePtr = fopen(filename, "r"); + if (filePtr) return filePtr; + + printf("Error : cannot open input file %s\n", filename); + exit(1); +} + + +/* open file in write mode */ +FILE* UTIL_fopenW(char* filename) +{ + FILE* filePtr = fopen(filename, "w"); + if (filePtr) return filePtr; + + printf("Error : cannot open output file %s\n", filename); + exit(1); +} + +/* close file */ +void UTIL_fclose(FILE* file) +{ + fclose(file); +} + diff --git a/src/runtime/c/teyjus/tables_gen/util/util.h b/src/runtime/c/teyjus/tables_gen/util/util.h new file mode 100644 index 000000000..4cc6a8a11 --- /dev/null +++ b/src/runtime/c/teyjus/tables_gen/util/util.h @@ -0,0 +1,71 @@ +////////////////////////////////////////////////////////////////////////////// +//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 . // +////////////////////////////////////////////////////////////////////////////// + +/**************************************************************************/ +/* util.h{c}. */ +/* Auxiliary functions needed for generating source files. */ +/**************************************************************************/ +#ifndef UTIL_H +#define UTIL_H +#include + + +/**************************************************************************/ +/* Space allocation */ +/**************************************************************************/ +/* allocate space */ +void* UTIL_malloc(size_t size); + +/* allocate space for a string of given size */ +char* UTIL_mallocStr(size_t size); + +/**************************************************************************/ +/* string operation */ +/**************************************************************************/ +/* append two strings */ +char* UTIL_appendStr(char* str1, char* str2); +/* capitalizing */ +char* UTIL_upperCase(char* str); +/* to lower cases */ +char* UTIL_lowerCase(char* str); +/* covert a non-negative integer to string */ +char* UTIL_itoa(int num); + +/**************************************************************************/ +/* file operation */ +/**************************************************************************/ +/* open file in read mode */ +FILE* UTIL_fopenR(char* filename); + +/* open file in write mode */ +FILE* UTIL_fopenW(char* filename); + +/* close file */ +void UTIL_fclose(FILE* file); + + +/* bool type */ +typedef enum { + UTIL_FALSE, UTIL_TRUE +} UTIL_Bool; + +#endif + +