diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

This commit was generated by cvs2svn to compensate for changes in r4,

Browse Source 
which included commits to RCS files with non-trunk default branches.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@5 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
2001-04-09 19:54:03 +00:00
parent 9a8ee05f1f
commit e5f4633c39
457 changed files with 189536 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10045
C/absmi.c Normal file
View File

File diff suppressed because it is too large Load Diff

555
C/adtdefs.c Normal file
View File

@@ -0,0 +1,555 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: adtdefs.c *
* Last rev: *
* mods: *
* comments: abstract machine definitions *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#define ADTDEFS_C
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include <stdio.h>
#if HAVE_STRING_H
#include <string.h>
#endif
/* this routine must be run at least having a read lock on ae */
static Prop
GetFunctorProp(AtomEntry *ae, unsigned int arity)
{ /* look property list of atom a for kind */
FunctorEntry *pp;
pp = RepFunctorProp(ae->PropOfAE);
while (!EndOfPAEntr(pp) &&
(!IsFunctorProperty(pp->KindOfPE) ||
pp->ArityOfFE != arity))
pp = RepFunctorProp(pp->NextOfPE);
return (AbsFunctorProp(pp));
}
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
static inline Functor
InlinedUnlockedMkFunctor(AtomEntry *ae, unsigned int arity)
{
FunctorEntry *p;
Prop p0;
p0 = GetFunctorProp(ae, arity);
if (p0 != NIL) {
return ((Functor) RepProp(p0));
}
p = (FunctorEntry *) AllocAtomSpace(sizeof(*p));
p->KindOfPE = FunctorProperty;
p->NameOfFE = AbsAtom(ae);
p->ArityOfFE = arity;
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsProp((PropEntry *) p);
return ((Functor) p);
}
Functor
UnlockedMkFunctor(AtomEntry *ae, unsigned int arity)
{
return(InlinedUnlockedMkFunctor(ae, arity));
}
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
Functor
MkFunctor(Atom ap, unsigned int arity)
{
AtomEntry *ae = RepAtom(ap);
Functor f;
WRITE_LOCK(ae->ARWLock);
f = InlinedUnlockedMkFunctor(ae, arity);
WRITE_UNLOCK(ae->ARWLock);
return (f);
}
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
void
MkFunctorWithAddress(Atom ap, unsigned int arity, FunctorEntry *p)
{
AtomEntry *ae = RepAtom(ap);
WRITE_LOCK(ae->ARWLock);
p->KindOfPE = FunctorProperty;
p->NameOfFE = ap;
p->ArityOfFE = arity;
p->NextOfPE = RepAtom(ap)->PropOfAE;
ae->PropOfAE = AbsProp((PropEntry *) p);
WRITE_UNLOCK(ae->ARWLock);
}
inline static Atom
SearchInInvisible(char *atom)
{
AtomEntry *chain;
READ_LOCK(INVISIBLECHAIN.AERWLock);
chain = RepAtom(INVISIBLECHAIN.Entry);
while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom) != 0) {
chain = RepAtom(chain->NextOfAE);
}
READ_UNLOCK(INVISIBLECHAIN.AERWLock);
if (EndOfPAEntr(chain))
return (NIL);
else
return(AbsAtom(chain));
}
static inline Atom
SearchAtom(unsigned char *p, Atom a) {
AtomEntry *ae;
/* search atom in chain */
while (a != NIL) {
ae = RepAtom(a);
if (strcmp(ae->StrOfAE, (const char *)p) == 0) {
return(a);
}
a = ae->NextOfAE;
}
return(NIL);
}
Atom
LookupAtom(char *atom)
{ /* lookup atom in atom table */
register CELL hash;
register unsigned char *p;
Atom a;
AtomEntry *ae;
/* compute hash */
p = (unsigned char *)atom;
HashFunction(p, hash);
WRITE_LOCK(HashChain[hash].AERWLock);
a = HashChain[hash].Entry;
/* search atom in chain */
a = SearchAtom((unsigned char *)atom, a);
if (a != NIL) {
WRITE_UNLOCK(HashChain[hash].AERWLock);
return(a);
}
/* add new atom to start of chain */
ae = (AtomEntry *) AllocAtomSpace((sizeof *ae) + strlen(atom));
a = AbsAtom(ae);
ae->NextOfAE = HashChain[hash].Entry;
HashChain[hash].Entry = a;
ae->PropOfAE = NIL;
if (ae->StrOfAE != atom)
strcpy(ae->StrOfAE, atom);
INIT_RWLOCK(ae->ARWLock);
WRITE_UNLOCK(HashChain[hash].AERWLock);
return (a);
}
Atom
FullLookupAtom(char *atom)
{ /* lookup atom in atom table */
Atom t;
if ((t = SearchInInvisible(atom)) != NIL) {
return (t);
}
return(LookupAtom(atom));
}
void
LookupAtomWithAddress(char *atom, AtomEntry *ae)
{ /* lookup atom in atom table */
register CELL hash;
register unsigned char *p;
Atom a;
/* compute hash */
p = (unsigned char *)atom;
HashFunction(p, hash);
/* ask for a WRITE lock because it is highly unlikely we shall find anything */
WRITE_LOCK(HashChain[hash].AERWLock);
a = HashChain[hash].Entry;
/* search atom in chain */
if (SearchAtom(p, a) != NIL) {
Error(FATAL_ERROR,TermNil,"repeated initialisation for atom %s", ae);
WRITE_UNLOCK(HashChain[hash].AERWLock);
return;
}
/* add new atom to start of chain */
ae->NextOfAE = a;
HashChain[hash].Entry = AbsAtom(ae);
ae->PropOfAE = NIL;
strcpy(ae->StrOfAE, atom);
INIT_RWLOCK(ae->ARWLock);
WRITE_UNLOCK(HashChain[hash].AERWLock);
}
void
ReleaseAtom(Atom atom)
{ /* Releases an atom from the hash chain */
register Int hash;
register unsigned char *p;
AtomEntry *inChain;
AtomEntry *ap = RepAtom(atom);
char *name = ap->StrOfAE;
/* compute hash */
p = (unsigned char *)name;
HashFunction(p, hash);
WRITE_LOCK(HashChain[hash].AERWLock);
if (HashChain[hash].Entry == atom) {
HashChain[hash].Entry = ap->NextOfAE;
WRITE_UNLOCK(HashChain[hash].AERWLock);
return;
}
/* else */
inChain = RepAtom(HashChain[hash].Entry);
while (inChain->NextOfAE != atom)
inChain = RepAtom(inChain->NextOfAE);
WRITE_LOCK(inChain->ARWLock);
inChain->NextOfAE = ap->NextOfAE;
WRITE_UNLOCK(inChain->ARWLock);
WRITE_UNLOCK(HashChain[hash].AERWLock);
}
static Prop
StaticLockedGetAProp(AtomEntry *ae, PropFlags kind)
{ /* look property list of atom a for kind */
PropEntry *pp;
pp = RepProp(ae->PropOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != kind)
pp = RepProp(pp->NextOfPE);
return (AbsProp(pp));
}
Prop
LockedGetAProp(AtomEntry *ae, PropFlags kind)
{ /* look property list of atom a for kind */
return (StaticLockedGetAProp(ae,kind));
}
Prop
GetAProp(Atom a, PropFlags kind)
{ /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
Prop out;
READ_LOCK(ae->ARWLock);
out = StaticLockedGetAProp(ae, kind);
READ_UNLOCK(ae->ARWLock);
return (out);
}
Prop
GetPredProp(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; */
{
Prop p0;
AtomEntry *ae = RepAtom(ap);
PredEntry *p;
READ_LOCK(ae->ARWLock);
p = RepPredProp(p0 = ae->PropOfAE);
while (p0 && (p->KindOfPE != PEProp || p->ArityOfPE != arity ||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
p = RepPredProp(p0 = p->NextOfPE);
READ_UNLOCK(ae->ARWLock);
return (p0);
}
Prop
LockedGetPredProp(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; */
{
Prop p0;
AtomEntry *ae = RepAtom(ap);
PredEntry *p;
p = RepPredProp(p0 = ae->PropOfAE);
while (p0 && (p->KindOfPE != PEProp || p->ArityOfPE != arity ||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
p = RepPredProp(p0 = p->NextOfPE);
return (p0);
}
/* get expression entry for at/arity; */
Prop
GetExpProp(Atom at, unsigned int arity)
{
Prop p0;
AtomEntry *ae = RepAtom(at);
ExpEntry *p;
READ_LOCK(ae->ARWLock);
p = RepExpProp(p0 = ae->PropOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE);
READ_UNLOCK(ae->ARWLock);
return (p0);
}
/* get expression entry for at/arity, at is already locked; */
Prop
LockedGetExpProp(AtomEntry *ae, unsigned int arity)
{
Prop p0;
ExpEntry *p;
p = RepExpProp(p0 = ae->PropOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE);
return (p0);
}
Prop
PredProp(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(ap);
PredEntry *p;
WRITE_LOCK(ae->ARWLock);
p = RepPredProp(p0 = RepAtom(ap)->PropOfAE);
while (p0 && (p->KindOfPE != 0 || p->ArityOfPE != arity ||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
p = RepPredProp(p0 = p->NextOfPE);
if (p0 != NIL) {
WRITE_UNLOCK(ae->ARWLock);
return (p0);
}
p = (PredEntry *) AllocAtomSpace(sizeof(*p));
INIT_RWLOCK(p->PRWLock);
p->KindOfPE = PEProp;
p->ArityOfPE = arity;
p->FirstClause = p->LastClause = NIL;
p->PredFlags = 0L;
p->StateOfPred = 0;
p->OwnerFile = AtomNil;
p->OpcodeOfPred = UNDEF_OPCODE;
p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred));
p->ModuleOfPred = CurrentModule;
INIT_LOCK(p->StatisticsForPred.lock);
p->StatisticsForPred.NOfEntries = 0;
p->StatisticsForPred.NOfHeadSuccesses = 0;
p->StatisticsForPred.NOfRetries = 0;
#ifdef TABLING
p->TableOfPred = NULL;
#endif /* TABLING */
/* careful that they don't cross MkFunctor */
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = p0 = AbsPredProp(p);
if (arity == 0)
p->FunctorOfPred = (Functor) ap;
else {
p->FunctorOfPred = InlinedUnlockedMkFunctor(ae, arity);
}
WRITE_UNLOCK(ae->ARWLock);
return (p0);
}
Term
GetValue(Atom a)
{
Prop p0 = GetAProp(a, ValProperty);
Term out;
if (p0 == NIL)
return (TermNil);
READ_LOCK(RepValProp(p0)->VRWLock);
out = RepValProp(p0)->ValueOfVE;
READ_UNLOCK(RepValProp(p0)->VRWLock);
return (out);
}
void
PutValue(Atom a, Term v)
{
AtomEntry *ae = RepAtom(a);
Prop p0;
ValEntry *p;
WRITE_LOCK(ae->ARWLock);
p0 = LockedGetAProp(ae, ValProperty);
if (p0 != NIL) {
p = RepValProp(p0);
WRITE_LOCK(p->VRWLock);
WRITE_UNLOCK(ae->ARWLock);
} else {
p = (ValEntry *) AllocAtomSpace(sizeof(ValEntry));
p->NextOfPE = RepAtom(a)->PropOfAE;
RepAtom(a)->PropOfAE = AbsValProp(p);
p->KindOfPE = ValProperty;
/* take care that the lock for the property will be inited even
if someone else searches for the property */
INIT_RWLOCK(p->VRWLock);
WRITE_LOCK(p->VRWLock);
WRITE_UNLOCK(ae->ARWLock);
}
if (IsFloatTerm(v)) {
/* store a float in code space, so that we can access the property */
union {
Float f;
CELL ar[sizeof(Float) / sizeof(CELL)];
} un;
CELL *pt, *iptr;
unsigned int i;
un.f = FloatOfTerm(v);
if (p0 != NIL && IsApplTerm(p->ValueOfVE))
pt = RepAppl(p->ValueOfVE);
else {
pt = (CELL *) AllocAtomSpace(sizeof(CELL)*(1 + 2*sizeof(Float)/sizeof(CELL)));
}
pt[0] = (CELL)FunctorDouble;
iptr = pt+1;
for (i = 0; i < sizeof(Float) / sizeof(CELL); i++) {
*iptr++ = MkIntTerm(un.ar[i]/65536);
*iptr++ = MkIntTerm(un.ar[i]%65536);
}
p->ValueOfVE = AbsAppl(pt);
} else if (IsLongIntTerm(v)) {
CELL *pt;
Int val = LongIntOfTerm(v);
if (p0 != NIL && IsApplTerm(p->ValueOfVE)) {
pt = RepAppl(p->ValueOfVE);
} else {
pt = (CELL *) AllocAtomSpace(3 * sizeof(CELL));
}
pt[0] = (CELL)FunctorLongInt;
pt[1] = MkIntTerm(val/65536);
pt[2] = MkIntTerm(val%65536);
p->ValueOfVE = AbsAppl(pt);
} else {
if (p0 != NIL && IsApplTerm(p->ValueOfVE)) {
/* recover space */
FreeCodeSpace((char *) (RepAppl(p->ValueOfVE)));
}
p->ValueOfVE = v;
}
WRITE_UNLOCK(p->VRWLock);
}
Term
StringToList(char *s)
{
register Term t;
register unsigned char *cp = (unsigned char *)s + strlen(s);
t = MkAtomTerm(AtomNil);
while (cp > (unsigned char *)s) {
t = MkPairTerm(MkIntTerm(*--cp), t);
}
return (t);
}
Term
StringToListOfAtoms(char *s)
{
register Term t;
char so[2];
register unsigned char *cp = (unsigned char *)s + strlen(s);
so[1] = '\0';
t = MkAtomTerm(AtomNil);
while (cp > (unsigned char *)s) {
so[0] = *--cp;
t = MkPairTerm(MkAtomTerm(LookupAtom(so)), t);
}
return (t);
}
Term
ArrayToList(register Term *tp, int nof)
{
register Term *pt = tp + nof;
register Term t;
t = MkAtomTerm(AtomNil);
while (pt > tp) {
Term tm = *--pt;
#if SBA
if (tm == 0)
t = MkPairTerm((CELL)pt, t);
else
#endif
t = MkPairTerm(tm, t);
}
return (t);
}
int
GetName(char *s, Term t)
{
register Term Head;
register Int i;
if (IsVarTerm(t) || !IsPairTerm(t))
return (FALSE);
while (IsPairTerm(t)) {
Head = HeadOfTerm(t);
if (!IsNumTerm(Head))
return (FALSE);
i = IntOfTerm(Head);
if (i < 0 || i > 255)
return (FALSE);
*s++ = i;
t = TailOfTerm(t);
}
*s = '\0';
return (TRUE);
}
#ifdef SFUNC
Term
MkSFTerm(Functor f, int n, Term *a, empty_value)
{
Term t, p = AbsAppl(H);
int i;
*H++ = f;
RESET_VARIABLE(H);
++H;
for (i = 1; i <= n; ++i) {
t = Derefa(a++);
if (t != empty_value) {
*H++ = i;
*H++ = t;
}
}
*H++ = 0;
return (p);
}
CELL *
ArgsOfSFTerm(Term t)
{
CELL *p = RepAppl(t) + 1;
while (*p != (CELL) p)
p = CellPtr(*p) + 1;
return (p + 1);
}
#endif

935
C/alloc.c Normal file
View File

@@ -0,0 +1,935 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: alloc.c *
* Last rev: *
* mods: *
* comments: allocating space *
* version:$Id: alloc.c,v 1.1.1.1 2001-04-09 19:53:30 vsc Exp $ *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "alloc.h"
#include "yapio.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#if HAVE_MEMORY_H
#include <memory.h>
#endif
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#include <stdlib.h>
#include <stdio.h>
#if __simplescalar__
#ifdef USE_MMAP
#undef USE_MMAP
#endif
#ifdef USE_SBRK
#undef USE_SBRK
#endif
#endif
STATIC_PROTO(void FreeBlock, (BlockHeader *));
STATIC_PROTO(BlockHeader *GetBlock, (unsigned int));
STATIC_PROTO(char *AllocHeap, (unsigned int));
STATIC_PROTO(void RemoveFromFreeList, (BlockHeader *));
STATIC_PROTO(void AddToFreeList, (BlockHeader *));
#ifdef LIGHT
#include <stdlib.h>
#endif
#define K ((Int) 1024)
#define MinHGap 256*K
/************************************************************************/
/* Yap workspace management */
int
SizeOfBlock(CODEADDR p)
{
BlockHeader *b = (BlockHeader *) (p - sizeof(YAP_SEG_SIZE));
YAP_SEG_SIZE s = (b->b_size) & ~InUseFlag;
return ((s - 1) * sizeof(YAP_SEG_SIZE));
}
static void
RemoveFromFreeList(BlockHeader *b)
{
BlockHeader *p;
p = b->b_next_size;
LOCK(HeapUsedLock);
HeapUsed += (b->b_size + 1) * sizeof(YAP_SEG_SIZE);
UNLOCK(HeapUsedLock);
if (p && b->b_size == p->b_size) {
b = b->b_next;
p->b_next = b;
if (b)
b->b_next_size = p;
}
else {
BlockHeader **q = (BlockHeader **) &FreeBlocks;
while ((*q) != b)
q = &((*q)->b_next_size);
if (b->b_next) {
p = b->b_next;
*q = p;
p->b_next_size = b->b_next_size;
}
else {
*q = b->b_next_size;
}
}
}
static void
AddToFreeList(BlockHeader *b)
{
BlockHeader **q, *p;
YAP_SEG_SIZE *sp;
/* insert on list of free blocks */
q = (BlockHeader **) &FreeBlocks;
sp = &(b->b_size) + b->b_size;
*sp = b->b_size;
LOCK(HeapUsedLock);
HeapUsed -= (b->b_size + 1) * sizeof(YAP_SEG_SIZE);
UNLOCK(HeapUsedLock);
while ((p = *q) && p->b_size < b->b_size)
q = &p->b_next_size;
if (p && p->b_size == b->b_size) {
b->b_next = p;
b->b_next_size = p->b_next_size;
p->b_next_size = b;
}
else {
b->b_next = NIL;
b->b_next_size = p;
}
*q = b;
}
long int call_counter;
static void
FreeBlock(BlockHeader *b)
{
BlockHeader *p;
YAP_SEG_SIZE *sp;
/* sanity check */
sp = &(b->b_size) + (b->b_size & ~InUseFlag);
if (*sp != b->b_size) {
#if !SHORT_INTS
YP_fprintf(YP_stderr, "** sanity check failed in FreeBlock %p %x %x\n",
b, b->b_size, Unsigned(*sp));
#else
YP_fprintf(YP_stderr, "** sanity check failed in FreeBlock %p %lx %lx\n",
b, b->b_size, *sp);
#endif
return;
}
b->b_size &= ~InUseFlag;
LOCK(FreeBlocksLock);
LOCK(GLOBAL_LOCKS_alloc_block);
/* check if we can collapse with other blocsks */
/* check previous */
sp = &(b->b_size) - 1;
if (!(*sp & InUseFlag)) { /* previous block is free */
p = (BlockHeader *) (sp - *sp);
RemoveFromFreeList(p);
p->b_size += b->b_size + 1;
b = p;
}
/* check following */
sp = &(b->b_size) + b->b_size + 1;
if (!(*sp & InUseFlag)) { /* following block is free */
p = (BlockHeader *) sp;
RemoveFromFreeList(p);
b->b_size += p->b_size + 1;
}
/* insert on list of free blocks */
AddToFreeList(b);
UNLOCK(GLOBAL_LOCKS_alloc_block);
UNLOCK(FreeBlocksLock);
}
static BlockHeader *
GetBlock(unsigned int n)
{ /* get free block with size at least n */
register BlockHeader **p, *b, *r;
if (FreeBlocks == NIL)
return (NIL);
p = (BlockHeader **) &FreeBlocks;
while (((b = *p) != NIL) && b->b_size < n)
p = &b->b_next_size;
if (b == NIL || b->b_size < n)
return (NIL);
if ((r = b->b_next) == NIL)
*p = b->b_next_size;
else {
r->b_next_size = b->b_next_size;
*p = r;
}
LOCK(HeapUsedLock);
HeapUsed += (b->b_size + 1) * sizeof(YAP_SEG_SIZE);
if (HeapUsed > HeapMax)
HeapMax = HeapUsed;
UNLOCK(HeapUsedLock);
return (b);
}
static char *
AllocHeap(unsigned int size)
{
BlockHeader *b, *n;
YAP_SEG_SIZE *sp;
#if SIZEOF_INT_P==4
size = (((size + 7) & 0xffffff8) >> 2) + 2; /* size in dwords + 2 */
#endif
#if SIZEOF_INT_P==8
size = (((size + 7) & 0xffffff8) >> 3) + 2; /* size in dwords + 2 */
#endif
if (size < 6)
size = 6;
LOCK(FreeBlocksLock);
LOCK(GLOBAL_LOCKS_alloc_block);
if ((b = GetBlock(size))) {
if (b->b_size >= size + 6 + 1) {
n = (BlockHeader *) (((YAP_SEG_SIZE *) b) + size + 1);
n->b_size = b->b_size - size - 1;
b->b_size = size;
AddToFreeList(n);
}
sp = &(b->b_size) + b->b_size;
*sp = b->b_size | InUseFlag;
b->b_size |= InUseFlag;
UNLOCK(GLOBAL_LOCKS_alloc_block);
UNLOCK(FreeBlocksLock);
return (Addr(b) + sizeof(YAP_SEG_SIZE));
}
UNLOCK(FreeBlocksLock);
if (!HEAPTOP_OWNER(worker_id)) {
LOCK(HeapTopLock);
}
b = (BlockHeader *) HeapTop;
HeapTop += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
LOCK(HeapUsedLock);
HeapUsed += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
#ifdef YAPOR
if (HeapTop > Addr(GlobalBase) - MinHeapGap) {
abort_optyap("No heap left in function AllocHeap");
}
#else
if (HeapTop > Addr(AuxSp) - MinHeapGap) {
HeapTop -= size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
HeapUsed -= size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
if (HeapTop > Addr(AuxSp)) {
UNLOCK(HeapUsedLock);
if (!HEAPTOP_OWNER(worker_id)) {
UNLOCK(HeapTopLock);
}
/* we destroyed the stack */
Abort("Stack Crashed against Heap...");
return(NULL);
} else {
if (HeapTop + size * sizeof(CELL) + sizeof(YAP_SEG_SIZE) < Addr(AuxSp)) {
/* small allocations, we can wait */
HeapTop += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
HeapUsed += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
UNLOCK(HeapUsedLock);
if (!HEAPTOP_OWNER(worker_id)) {
UNLOCK(HeapTopLock);
}
CreepFlag = Unsigned(LCL0) - Unsigned(H0);
} else {
if (size > SizeOfOverflow)
SizeOfOverflow = size*sizeof(CELL) + sizeof(YAP_SEG_SIZE);
/* big allocations, the caller must handle the problem */
UNLOCK(HeapUsedLock);
if (!HEAPTOP_OWNER(worker_id)) {
UNLOCK(HeapTopLock);
}
return(NULL);
}
}
}
#endif /* YAPOR */
*((YAP_SEG_SIZE *) HeapTop) = InUseFlag;
if (HeapUsed > HeapMax)
HeapMax = HeapUsed;
HeapPlus = HeapTop + MinHGap / CellSize;
UNLOCK(GLOBAL_LOCKS_alloc_block);
UNLOCK(HeapUsedLock);
b->b_size = size | InUseFlag;
sp = &(b->b_size) + size;
*sp = b->b_size;
if (!HEAPTOP_OWNER(worker_id)) {
UNLOCK(HeapTopLock);
}
return (Addr(b) + sizeof(YAP_SEG_SIZE));
}
/* If you need to dinamically allocate space from the heap, this is
* the macro you should use */
ADDR
PreAllocCodeSpace(void)
{
LOCK(HeapTopLock);
HEAPTOP_OWN(worker_id);
return (Addr(HeapTop) + sizeof(YAP_SEG_SIZE));
}
#if defined(YAPOR) || defined(THREADS)
/* Grabbing the HeapTop is an excellent idea for a sequential system,
but does work as well in parallel systems. Anyway, this will do for now */
void
ReleasePreAllocCodeSpace(ADDR ptr)
{
HEAPTOP_DISOWN(worker_id);
UNLOCK(HeapTopLock);
}
#endif
/* If you need to dinamically allocate space from the heap, this is
* the macro you should use */
void
FreeCodeSpace(char *p)
{
FreeBlock(((BlockHeader *) (p - sizeof(YAP_SEG_SIZE))));
}
char *
AllocAtomSpace(unsigned int size)
{
return (AllocHeap(size));
}
void
FreeAtomSpace(char *p)
{
FreeCodeSpace(p);
}
char *
AllocCodeSpace(unsigned int size)
{
if (size < SmallSize + 2 * OpCodeSize + 3 * CellSize)
return (AllocHeap(SmallSize + 2 * OpCodeSize + 3 * CellSize));
return (AllocHeap(size));
}
/************************************************************************/
/* Workspace allocation */
/* */
/* We provide four alternatives for workspace allocation. */
/* - use 'mmap' */
/* - use 'shmat' */
/* - use 'sbrk' and provide a replacement to the 'malloc' library */
/* - use 'malloc' */
/* */
/* In any of the alternatives the interface is through the following */
/* functions: */
/* void *InitWorkSpace(int s) - initial workspace allocation */
/* int ExtendWorkSpace(int s) - extend workspace */
/* int FreeWorkSpace() - release workspace */
/************************************************************************/
#ifdef _WIN32
#include "windows.h"
#define BASE_ADDRESS ((LPVOID) MMAP_ADDR)
#define MAX_WORKSPACE 0x20000000L
static LPVOID brk;
int
ExtendWorkSpace(Int s)
{
LPVOID b;
s = ((s-1)/page_size+1)*page_size;
b = VirtualAlloc(brk, s, MEM_COMMIT, PAGE_READWRITE);
if (b) {
brk = (LPVOID) ((Int) brk + s);
return TRUE;
}
return FALSE;
}
MALLOC_T
InitWorkSpace(Int s)
{
SYSTEM_INFO si;
LPVOID b;
GetSystemInfo(&si);
page_size = si.dwPageSize;
b = VirtualAlloc(BASE_ADDRESS, MAX_WORKSPACE, MEM_RESERVE, PAGE_NOACCESS);
if (b==NULL) {
YP_fprintf(YP_stderr,"[ Warning: YAP reserving space at a variable address ]\n");
b = VirtualAlloc(0x0, MAX_WORKSPACE, MEM_RESERVE, PAGE_NOACCESS);
if (b == NULL) {
YP_fprintf(YP_stderr,"[ FATAL ERROR: YAP failed to reserve space ]\n");
exit(1);
}
}
brk = BASE_ADDRESS;
if (ExtendWorkSpace(s)) {
return BASE_ADDRESS;
} else {
YP_fprintf(YP_stderr,"[ FATAL ERROR: YAP failed to reserve space ]\n");
exit(1);
}
}
int
FreeWorkSpace(void)
{
return TRUE;
}
#elif USE_MMAP
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_SYS_MMAN_H
#include <sys/mman.h>
#endif
#if HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#if HAVE_FCNTL_H
#include <fcntl.h>
#endif
#ifdef MMAP_ADDR
#define USE_FIXED 1
#endif
static MALLOC_T WorkSpaceTop;
MALLOC_T
InitWorkSpace(Int s)
{
MALLOC_T a;
#if !defined(_AIX) && !defined(__APPLE__) && !__hpux
int fd;
#endif
#if defined(_AIX)
a = mmap(0, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE | MAP_ANONYMOUS | MAP_VARIABLE, -1, 0);
#elif __hpux
a = mmap(((void *)MMAP_ADDR), (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED, -1, 0);
#elif defined(__APPLE__)
a = mmap(0, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE | MAP_ANON, -1, 0);
#else
fd = open("/dev/zero", O_RDWR);
if (fd < 0) {
#if HAVE_MKSTEMP
char file[256];
strncpy(file,"/tmp/YAP.TMPXXXXXX", 256);
if (mkstemp(file) == -1) {
#if HAVE_STRERROR
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s (%s)", file, strerror(errno));
#else
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s", file);
#endif
return FALSE;
}
#else
#if HAVE_TMPNAM
char *file = tmpnam(NULL);
#else
char file[YAP_FILENAME_MAX];
strcpy(file,"/tmp/mapfile");
itos(getpid(), &file[12]);
#endif /* HAVE_TMPNAM */
#endif /* HAVE_MKSTEMP */
fd = open(file, O_CREAT|O_RDWR);
if (fd < 0) {
Error(SYSTEM_ERROR, TermNil, "mmap could not open %s", file);
return FALSE;
}
if (lseek(fd, s, SEEK_SET) < 0) {
Error(SYSTEM_ERROR, TermNil, "mmap could not lseek in mmapped file %s", file);
return FALSE;
}
if (write(fd, "", 1) < 0) {
Error(SYSTEM_ERROR, TermNil, "mmap could not write in mmapped file %s", file);
return FALSE;
}
if (unlink(file) < 0) {
Error(SYSTEM_ERROR,TermNil, "mmap could not unlink mmapped file %s", file);
return FALSE;
}
}
#if USE_FIXED
a = mmap(((void *)MMAP_ADDR), (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE | MAP_FIXED, fd, 0);
#else
a = mmap(0, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE, fd, 0);
if ((CELL)a & YAP_PROTECTED_MASK) {
close(fd);
Error(FATAL_ERROR, TermNil, "mmapped address %p collides with YAP tags ***", a);
}
if (close(fd) == -1) {
Error(SYSTEM_ERROR, TermNil, "while closing mmaped file ***");
return FALSE;
}
#endif
#endif
if
#ifdef MMAP_FAILED
(a == (MALLOC_T) MMAP_FAILED)
#else
(a == (MALLOC_T) - 1)
#endif
{
Error(FATAL_ERROR, TermNil, "mmap cannot allocate memory ***");
return(NULL);
}
WorkSpaceTop = (char *) a + s;
return (void *) a;
}
int
ExtendWorkSpace(Int s)
{
#ifdef YAPOR
abort_optyap("function ExtendWorkSpace called");
#else
MALLOC_T a;
#if defined(_AIX) || defined(__hpux)
a = mmap(WorkSpaceTop, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
#elif defined(__APPLE__)
a = mmap(WorkSpaceTop, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE | MAP_ANON, -1, 0);
#else
int fd;
fd = open("/dev/zero", O_RDWR);
if (fd < 0) {
#if HAVE_MKSTEMP
char file[256];
strncpy(file,"/tmp/YAP.TMPXXXXXX",256);
if (mkstemp(file) == -1) {
#if HAVE_STRERROR
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s (%s)", file, strerror(errno));
#else
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s", file);
#endif
return FALSE;
}
#else
#if HAVE_TMPNAM
char *file = tmpnam(NULL);
#else
char file[YAP_FILENAME_MAX];
strcpy(file,"/tmp/mapfile");
itos(getpid(), &file[12]);
#endif /* HAVE_TMPNAM */
#endif /* HAVE_MKSTEMP */
fd = open(file, O_CREAT|O_RDWR);
if (fd < 0) {
Error(SYSTEM_ERROR, TermNil, "mmap could not open %s", file);
return FALSE;
}
if (lseek(fd, s, SEEK_SET) < 0) {
Error(SYSTEM_ERROR, TermNil, "mmap could not lseek in mmapped file %s", file);
return FALSE;
}
if (write(fd, "", 1) < 0) {
Error(SYSTEM_ERROR, TermNil, "mmap could not write in mmapped file %s", file);
return FALSE;
}
if (unlink(file) < 0) {
Error(SYSTEM_ERROR, TermNil, "mmap could not unlink mmapped file %s", file);
return FALSE;
}
}
a = mmap(WorkSpaceTop, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_PRIVATE | MAP_FIXED, fd, 0);
if (close(fd) == -1) {
#if HAVE_STRERROR
Error(SYSTEM_ERROR, TermNil, "mmap could not close file (%s) ]\n", strerror(errno));
#else
Error(SYSTEM_ERROR, TermNil, "mmap could not close file ]\n");
#endif
return FALSE;
}
#endif
if (a == (MALLOC_T) - 1) {
#if HAVE_STRERROR
Error(SYSTEM_ERROR, TermNil, "could not allocate %d bytes (%s)", (int)s, strerror(errno));
#else
Error(SYSTEM_ERROR, TermNil, "could not allocate %d bytes", (int)s);
#endif
return FALSE;
}
WorkSpaceTop = (char *) a + s;
#endif /* YAPOR */
return TRUE;
}
int
FreeWorkSpace(void)
{
return 1;
}
#elif USE_SHM
#if HAVE_SYS_SHM_H
#include <sys/shm.h>
#endif
#ifndef MMAP_ADDR
#define MMAP_ADDR 0x0L
#endif
static MALLOC_T WorkSpaceTop;
MALLOC_T
InitWorkSpace(Int s)
{
MALLOC_T ptr;
int shm_id;
/* mapping heap area */
if((shm_id = shmget(IPC_PRIVATE, (size_t)s, SHM_R|SHM_W)) == -1) {
Error(FATAL_ERROR, TermNil, "could not shmget %d bytes", s);
return(NULL);
}
if((ptr = (MALLOC_T)shmat(shm_id, (void *) MMAP_ADDR, 0)) == (MALLOC_T) -1) {
Error(FATAL_ERROR, TermNil, "could not shmat at %p", MMAP_ADDR);
return(NULL);
}
if (shmctl(shm_id, IPC_RMID, 0) != 0) {
Error(FATAL_ERROR, TermNil, "could not remove shm segment", shm_id);
return(NULL);
}
WorkSpaceTop = (char *) ptr + s;
return(ptr);
}
int
ExtendWorkSpace(Int s)
{
MALLOC_T ptr;
int shm_id;
/* mapping heap area */
if((shm_id = shmget(IPC_PRIVATE, (size_t)s, SHM_R|SHM_W)) == -1) {
Error(SYSTEM_ERROR, TermNil, "could not shmget %d bytes", s);
return(FALSE);
}
if((ptr = (MALLOC_T)shmat(shm_id, WorkSpaceTop, 0)) == (MALLOC_T) -1) {
Error(SYSTEM_ERROR, TermNil, "could not shmat at %p", MMAP_ADDR);
return(FALSE);
}
if (shmctl(shm_id, IPC_RMID, 0) != 0) {
Error(SYSTEM_ERROR, TermNil, "could not remove shm segment", shm_id);
return(FALSE);
}
WorkSpaceTop = (char *) ptr + s;
return(TRUE);
}
int
FreeWorkSpace(void)
{
return TRUE;
}
#elif USE_SBRK
/***********************************************************************\
* Worspace allocation based on 'sbrk' *
* We have to provide a replacement for the 'malloc' functions. *
* The situation is further complicated by the need to provide *
* temporary 'malloc' space when restoring a previously saved state. *
\***********************************************************************/
#ifdef _AIX
char *STD_PROTO(sbrk, (int));
#endif
int in_limbo; /* non-zero when restoring a saved state */
#ifndef LIMBO_SIZE
#define LIMBO_SIZE 32*K
#endif
static char limbo_space[LIMBO_SIZE]; /* temporary malloc space */
static char *limbo_p = limbo_space, *limbo_pp = 0;
MALLOC_T
InitWorkSpace(Int s)
{
MALLOC_T ptr = (MALLOC_T)sbrk(s);
if (ptr == ((MALLOC_T) - 1)) {
Error(FATAL_ERROR, TermNil, "could not allocate %d bytes", s);
return(NULL);
}
return(ptr);
}
int
ExtendWorkSpace(Int s)
{
MALLOC_T ptr = (MALLOC_T)sbrk(s);
if (ptr == ((MALLOC_T) - 1)) {
Error(SYSTEM_ERROR, TermNil, "could not expand stacks over %d bytes", s);
return(FALSE);
}
return TRUE;
}
int
FreeWorkSpace(void)
{
return TRUE;
}
MALLOC_T
malloc(size_t size)
{
if (in_limbo) {
limbo_pp = limbo_p;
limbo_p += (size + 7) & 0xffff8;
if (limbo_p >= &limbo_space[LIMBO_SIZE])
return(NULL);
return (limbo_pp);
}
else {
CODEADDR codep = (CODEADDR)AllocCodeSpace(size + 2*sizeof(void *));
if (codep == NIL)
return(NIL);
else
return(codep + 2*sizeof(void *));
}
}
void
free(MALLOC_T ptr)
{
BlockHeader *b = (BlockHeader *) (((char *) ptr) - 2*sizeof(void *) - sizeof(YAP_SEG_SIZE));
if (ptr == limbo_pp) {
limbo_p = limbo_pp;
return;
}
if (!ptr)
return;
if ((char *) ptr < HeapBase || (char *) ptr > HeapTop)
return;
if (!(b->b_size & InUseFlag))
return;
FreeCodeSpace((char *) ptr - 2*sizeof(void *));
}
MALLOC_T
realloc(MALLOC_T ptr, size_t size)
{
MALLOC_T new = malloc(size);
if (ptr)
memcpy(new, ptr, size);
free(ptr);
return (new);
}
MALLOC_T
calloc(size_t n, size_t e)
{
unsigned k = n * e;
MALLOC_T p = malloc(k);
memset(p, 0, k);
return (p);
}
#ifdef M_MXFAST
int
mallopt(cmd, value)
{
return (value);
}
static struct mallinfo xmall;
struct mallinfo
mallinfo(void)
{
return (xmall);
}
#endif
#else
/* use malloc to initiliase memory */
/* user should ask for a lot of memory first */
static int total_space;
MALLOC_T
InitWorkSpace(Int s)
{
MALLOC_T ptr = (MALLOC_T)malloc(s);
total_space = s;
if (ptr == ((MALLOC_T) - 1)) {
Error(FATAL_ERROR, TermNil, "could not allocate %d bytes", s);
return(NULL);
}
return(ptr);
}
int
ExtendWorkSpace(Int s)
{
MALLOC_T ptr;
total_space += s;
ptr = (MALLOC_T)realloc((void *)HeapBase, total_space);
if (ptr == ((MALLOC_T) - 1)) {
Error(SYSTEM_ERROR, TermNil, "could not expand stacks %d bytes", s);
return(FALSE);
}
if (ptr != (MALLOC_T)HeapBase) {
Error(SYSTEM_ERROR, TermNil, "could not expand contiguous stacks %d bytes", s);
return(FALSE);
}
return TRUE;
}
int
FreeWorkSpace(void)
{
return TRUE;
}
#endif
void
YAP_InitHeap(void *heap_addr)
{
/* allocate space */
HeapBase = heap_addr;
/* reserve space for specially allocated functors and atoms so that
their values can be known statically */
HeapTop = HeapBase + AdjustSize(sizeof(all_heap_codes));
HeapMax = HeapUsed = HeapTop-HeapBase;
*((YAP_SEG_SIZE *) HeapTop) = InUseFlag;
HeapTop = HeapTop + sizeof(YAP_SEG_SIZE);
*((YAP_SEG_SIZE *) HeapTop) = InUseFlag;
HeapPlus = HeapTop + MinHGap / CellSize;
FreeBlocks = NIL;
HEAPTOP_DISOWN(worker_id);
#if defined(YAPOR) || defined(TABLING)
#ifdef USE_HEAP
/* Try to make the system to crash */
BaseAllocArea = NULL;
TopAllocArea = BaseAllocArea;
#else
BaseAllocArea = AllocCodeSpace(OPT_CHUNK_SIZE);
TopAllocArea = BaseAllocArea;
#endif
LOCAL = REMOTE; /* point to the first area */
#endif
}
void
InitMemory(int Trail, int Heap, int Stack)
{
Int pm, sa, ta;
Trail = AdjustPageSize(Trail * K);
Stack = AdjustPageSize(Stack * K);
Heap = AdjustPageSize(Heap * K);
pm = (Trail + Heap + Stack); /* memory to be
* requested */
sa = Stack; /* stack area size */
ta = Trail; /* trail area size */
YAP_InitHeap(InitWorkSpace(pm));
TrailTop = HeapBase + pm;
LocalBase = TrailTop - ta;
TrailBase = LocalBase + sizeof(CELL);
GlobalBase = LocalBase - sa;
AuxTop = GlobalBase - CellSize; /* avoid confusions while
* * restoring */
AuxSp = (CELL *) AuxTop;
#ifdef DEBUG
#if SIZEOF_INT_P!=SIZEOF_INT
if (output_msg) {
YP_fprintf(YP_stderr, "HeapBase = %p GlobalBase = %p\n LocalBase = %p TrailTop = %p\n",
HeapBase, GlobalBase, LocalBase, TrailTop);
#else
if (output_msg) {
YP_fprintf(YP_stderr, "HeapBase = %x GlobalBase = %x\n LocalBase = %x TrailTop = %x\n",
(UInt) HeapBase, (UInt) GlobalBase,
(UInt) LocalBase, (UInt) TrailTop);
#endif
#if !SHORT_INTS
YP_fprintf(YP_stderr, "Heap+Aux: %d\tLocal+Global: %d\tTrail: %d\n",
pm - sa - ta, sa, ta);
#else /* SHORT_INTS */
YP_fprintf(YP_stderr, "Heap+Aux: %ld\tLocal+Global: %ld\tTrail: %ld\n",
pm - sa - ta, sa, ta);
#endif /* SHORT_INTS */
}
#endif /* DEBUG */
}

2516
C/amasm.c Normal file
View File

File diff suppressed because it is too large Load Diff

823
C/analyst.c Normal file
View File

@@ -0,0 +1,823 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: analyst.c *
* Last rev: *
* mods: *
* comments: Tracing the abstract machine *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#ifdef ANALYST
#include "Yatom.h"
#include "yapio.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
STATIC_PROTO(Int p_reset_op_counters, (void));
STATIC_PROTO(Int p_show_op_counters, (void));
STATIC_PROTO(Int p_show_ops_by_group, (void));
int opcount[_std_top + 1];
static char *op_names[_std_top + 1] =
{
#define OPCODE(OP,TYPE) #OP
#include "YapOpcodes.h"
#undef OPCODE
};
static Int
p_reset_op_counters()
{
int i;
for (i = 0; i <= _std_top; ++i)
opcount[i] = 0;
return (TRUE);
}
static void
print_instruction(int inst)
{
int j;
YP_fprintf(YP_stderr, "%s", op_names[inst]);
for (j = strlen(op_names[inst]); j < 25; j++)
YP_putc(' ', YP_stderr);
j = opcount[inst];
if (j < 100000000) {
YP_putc(' ', YP_stderr);
if (j < 10000000) {
YP_putc(' ', YP_stderr);
if (j < 1000000) {
YP_putc(' ', YP_stderr);
if (j < 100000) {
YP_putc(' ', YP_stderr);
if (j < 10000) {
YP_putc(' ', YP_stderr);
if (j < 1000) {
YP_putc(' ', YP_stderr);
if (j < 100) {
YP_putc(' ', YP_stderr);
if (j < 10) {
YP_putc(' ', YP_stderr);
}
}
}
}
}
}
}
}
YP_fprintf(YP_stderr, "%d\n", opcount[inst]);
}
static Int
p_show_op_counters()
{
int i;
char *program;
Term t1 = Deref(ARG1);
if (IsVarTerm(t1) || !IsAtomTerm(t1))
return (FALSE);
else
program = RepAtom(AtomOfTerm(t1))->StrOfAE;
YP_fprintf(YP_stderr, "\n Instructions Executed in %s \n", program);
for (i = 0; i <= _std_top; ++i)
print_instruction(i);
YP_fprintf(YP_stderr, "\n Control Instructions \n");
print_instruction(_op_fail);
print_instruction(_execute);
print_instruction(_dexecute);
print_instruction(_call);
print_instruction(_fcall);
print_instruction(_call_cpred);
print_instruction(_call_c_wfail);
print_instruction(_procceed);
print_instruction(_allocate);
print_instruction(_deallocate);
YP_fprintf(YP_stderr, "\n Choice Point Manipulation Instructions\n");
print_instruction(_try_me);
print_instruction(_retry_me);
print_instruction(_trust_me);
print_instruction(_try_me0);
print_instruction(_retry_me0);
print_instruction(_trust_me0);
print_instruction(_try_me1);
print_instruction(_retry_me1);
print_instruction(_trust_me1);
print_instruction(_try_me2);
print_instruction(_retry_me2);
print_instruction(_trust_me2);
print_instruction(_try_me3);
print_instruction(_retry_me3);
print_instruction(_trust_me3);
print_instruction(_try_me4);
print_instruction(_retry_me4);
print_instruction(_trust_me4);
print_instruction(_try_clause);
print_instruction(_try_in);
print_instruction(_retry);
print_instruction(_trust_in);
print_instruction(_trust);
print_instruction(_retry_first);
print_instruction(_trust_first_in);
print_instruction(_trust_first);
print_instruction(_retry_tail);
print_instruction(_trust_tail_in);
print_instruction(_trust_tail);
print_instruction(_retry_head);
print_instruction(_trust_head_in);
print_instruction(_trust_head);
YP_fprintf(YP_stderr, "\n Disjunction Instructions\n");
print_instruction(_either);
print_instruction(_or_else);
print_instruction(_or_last);
print_instruction(_jump);
print_instruction(_move_back);
YP_fprintf(YP_stderr, "\n Dynamic Predicates Choicepoint Instructions\n");
print_instruction(_try_and_mark);
print_instruction(_retry_and_mark);
YP_fprintf(YP_stderr, "\n C Predicates Choicepoint Instructions\n");
print_instruction(_try_c);
print_instruction(_retry_c);
YP_fprintf(YP_stderr, "\n Indexing Instructions\n");
YP_fprintf(YP_stderr, "\n Switch on Type\n");
print_instruction(_switch_on_type);
print_instruction(_switch_on_nonv);
print_instruction(_switch_last);
print_instruction(_switch_on_head);
print_instruction(_switch_list_nl);
print_instruction(_switch_list_nl_prefetch);
print_instruction(_switch_nv_list);
print_instruction(_switch_l_list);
YP_fprintf(YP_stderr, "\n Switch on Value\n");
print_instruction(_if_cons);
print_instruction(_go_on_cons);
print_instruction(_switch_on_cons);
print_instruction(_if_func);
print_instruction(_go_on_func);
print_instruction(_switch_on_func);
YP_fprintf(YP_stderr, "\n Other Switches\n");
print_instruction(_if_not_then);
YP_fprintf(YP_stderr, "\n Get Instructions\n");
print_instruction(_get_x_var);
print_instruction(_get_y_var);
print_instruction(_get_x_val);
print_instruction(_get_y_val);
print_instruction(_get_atom);
print_instruction(_get_list);
print_instruction(_get_struct);
YP_fprintf(YP_stderr, "\n Optimised Get Instructions\n");
print_instruction(_glist_valx);
print_instruction(_glist_valy);
print_instruction(_gl_void_varx);
print_instruction(_gl_void_vary);
print_instruction(_gl_void_valx);
print_instruction(_gl_void_valy);
YP_fprintf(YP_stderr, "\n Unify Read Instructions\n");
print_instruction(_unify_x_var);
print_instruction(_unify_x_var2);
print_instruction(_unify_y_var);
print_instruction(_unify_x_val);
print_instruction(_unify_y_val);
print_instruction(_unify_x_loc);
print_instruction(_unify_y_loc);
print_instruction(_unify_atom);
print_instruction(_unify_n_atoms);
print_instruction(_unify_n_voids);
print_instruction(_unify_list);
print_instruction(_unify_struct);
YP_fprintf(YP_stderr, "\n Unify Last Read Instructions\n");
print_instruction(_unify_l_x_var);
print_instruction(_unify_l_x_var2);
print_instruction(_unify_l_y_var);
print_instruction(_unify_l_x_val);
print_instruction(_unify_l_y_val);
print_instruction(_unify_l_x_loc);
print_instruction(_unify_l_y_loc);
print_instruction(_unify_l_atom);
print_instruction(_unify_l_n_voids);
print_instruction(_unify_l_list);
print_instruction(_unify_l_struc);
YP_fprintf(YP_stderr, "\n Unify Write Instructions\n");
print_instruction(_unify_x_var_write);
print_instruction(_unify_x_var2_write);
print_instruction(_unify_y_var_write);
print_instruction(_unify_x_val_write);
print_instruction(_unify_y_val_write);
print_instruction(_unify_x_loc_write);
print_instruction(_unify_y_loc_write);
print_instruction(_unify_atom_write);
print_instruction(_unify_n_atoms_write);
print_instruction(_unify_n_voids_write);
print_instruction(_unify_list_write);
print_instruction(_unify_struct_write);
YP_fprintf(YP_stderr, "\n Unify Last Read Instructions\n");
print_instruction(_unify_l_x_var_write);
print_instruction(_unify_l_x_var2_write);
print_instruction(_unify_l_y_var_write);
print_instruction(_unify_l_x_val_write);
print_instruction(_unify_l_y_val_write);
print_instruction(_unify_l_x_loc_write);
print_instruction(_unify_l_y_loc_write);
print_instruction(_unify_l_atom_write);
print_instruction(_unify_l_n_voids_write);
print_instruction(_unify_l_list_write);
print_instruction(_unify_l_struc_write);
YP_fprintf(YP_stderr, "\n Put Instructions\n");
print_instruction(_put_x_var);
print_instruction(_put_y_var);
print_instruction(_put_x_val);
print_instruction(_put_y_val);
print_instruction(_put_unsafe);
print_instruction(_put_atom);
print_instruction(_put_list);
print_instruction(_put_struct);
YP_fprintf(YP_stderr, "\n Write Instructions\n");
print_instruction(_write_x_var);
print_instruction(_write_y_var);
print_instruction(_write_x_val);
print_instruction(_write_y_val);
print_instruction(_write_x_loc);
print_instruction(_write_y_loc);
print_instruction(_write_atom);
print_instruction(_write_n_atoms);
print_instruction(_write_n_voids);
print_instruction(_write_list);
print_instruction(_write_struct);
YP_fprintf(YP_stderr, "\n Last Write Instructions\n");
print_instruction(_write_l_list);
print_instruction(_write_l_struc);
YP_fprintf(YP_stderr, "\n Miscellaneous Instructions\n");
print_instruction(_cut);
print_instruction(_cut_t);
print_instruction(_cut_e);
print_instruction(_skip);
print_instruction(_pop);
print_instruction(_pop_n);
print_instruction(_trust_fail);
print_instruction(_index_pred);
print_instruction(_save_b_x);
print_instruction(_save_b_y);
print_instruction(_save_pair_x);
print_instruction(_save_pair_y);
print_instruction(_save_pair_x_write);
print_instruction(_save_pair_y_write);
print_instruction(_save_appl_x);
print_instruction(_save_appl_y);
print_instruction(_save_appl_x_write);
print_instruction(_save_appl_y_write);
print_instruction(_Ystop);
print_instruction(_Nstop);
return (TRUE);
}
typedef struct {
int nxvar, nxval, nyvar, nyval, ncons, nlist, nstru, nmisc;
} uopcount;
typedef struct {
int ncalls, nexecs, nproceeds, ncallbips, ncuts, nallocs, ndeallocs;
} copcount;
typedef struct {
int ntries, nretries, ntrusts;
} ccpcount;
static Int
p_show_ops_by_group(void)
{
uopcount c_get, c_unify, c_put, c_write;
copcount c_control;
ccpcount c_cp;
int gets, unifies, puts, writes, controls, choice_pts, indexes, misc,
total;
char *program;
Term t1;
t1 = Deref(ARG1);
if (IsVarTerm(t1) || !IsAtomTerm(t1))
return (FALSE);
else
program = RepAtom(AtomOfTerm(t1))->StrOfAE;
c_get.nxvar =
opcount[_get_x_var];
c_get.nyvar =
opcount[_get_y_var];
c_get.nxval =
opcount[_get_x_val];
c_get.nyval =
opcount[_get_y_val];
c_get.ncons =
opcount[_get_atom];
c_get.nlist =
opcount[_get_list] +
opcount[_glist_valx] +
opcount[_glist_valy] +
opcount[_gl_void_varx] +
opcount[_gl_void_vary] +
opcount[_gl_void_valx] +
opcount[_gl_void_valy];
c_get.nstru =
opcount[_get_struct];
gets = c_get.nxvar + c_get.nyvar + c_get.nxval + c_get.nyval +
c_get.ncons + c_get.nlist + c_get.nstru;
c_unify.nxvar =
opcount[_unify_x_var] +
opcount[_unify_void] +
opcount[_unify_n_voids] +
2 * opcount[_unify_x_var2] +
2 * opcount[_gl_void_varx] +
opcount[_gl_void_vary] +
opcount[_gl_void_valx] +
opcount[_unify_l_x_var] +
opcount[_unify_l_void] +
opcount[_unify_l_n_voids] +
2 * opcount[_unify_l_x_var2] +
opcount[_unify_x_var_write] +
opcount[_unify_void_write] +
opcount[_unify_n_voids_write] +
2 * opcount[_unify_x_var2_write] +
opcount[_unify_l_x_var_write] +
opcount[_unify_l_void_write] +
opcount[_unify_l_n_voids_write] +
2 * opcount[_unify_l_x_var2_write];
c_unify.nyvar =
opcount[_unify_y_var] +
opcount[_gl_void_vary] +
opcount[_unify_l_y_var] +
opcount[_unify_y_var_write] +
opcount[_unify_l_y_var_write];
c_unify.nxval =
opcount[_unify_x_val] +
opcount[_unify_x_loc] +
opcount[_glist_valx] +
opcount[_gl_void_valx] +
opcount[_unify_l_x_val] +
opcount[_unify_l_x_loc] +
opcount[_unify_x_val_write] +
opcount[_unify_x_loc_write] +
opcount[_unify_l_x_val_write] +
opcount[_unify_l_x_loc_write];
c_unify.nyval =
opcount[_unify_y_val] +
opcount[_unify_y_loc] +
opcount[_glist_valy] +
opcount[_gl_void_valy] +
opcount[_unify_l_y_val] +
opcount[_unify_l_y_loc] +
opcount[_unify_y_val_write] +
opcount[_unify_y_loc_write] +
opcount[_unify_l_y_val_write] +
opcount[_unify_l_y_loc_write];
c_unify.ncons =
opcount[_unify_atom] +
opcount[_unify_n_atoms] +
opcount[_unify_l_atom] +
opcount[_unify_atom_write] +
opcount[_unify_n_atoms_write] +
opcount[_unify_l_atom_write];
c_unify.nlist =
opcount[_unify_list] +
opcount[_unify_l_list] +
opcount[_unify_list_write] +
opcount[_unify_l_list_write];
c_unify.nstru =
opcount[_unify_struct] +
opcount[_unify_l_struc] +
opcount[_unify_struct_write] +
opcount[_unify_l_struc_write];
c_unify.nmisc =
opcount[_pop] +
opcount[_pop_n];
unifies = c_unify.nxvar + c_unify.nyvar + c_unify.nxval + c_unify.nyval +
c_unify.ncons + c_unify.nlist + c_unify.nstru + c_unify.nmisc;
c_put.nxvar =
opcount[_put_x_var];
c_put.nyvar =
opcount[_put_y_var];
c_put.nxval =
opcount[_put_x_val];
c_put.nyval =
opcount[_put_y_val];
c_put.ncons =
opcount[_put_atom];
c_put.nlist =
opcount[_put_list];
c_put.nstru =
opcount[_put_struct];
puts = c_put.nxvar + c_put.nyvar + c_put.nxval + c_put.nyval +
c_put.ncons + c_put.nlist + c_put.nstru;
c_write.nxvar =
opcount[_write_x_var] +
opcount[_write_void] +
opcount[_write_n_voids];
c_write.nyvar =
opcount[_write_y_var];
c_write.nxval =
opcount[_write_x_val];
c_write.nyval =
opcount[_write_y_val];
c_write.ncons =
opcount[_write_atom];
c_write.nlist =
opcount[_write_list];
c_write.nstru =
opcount[_write_struct];
writes = c_write.nxvar + c_write.nyvar + c_write.nxval + c_write.nyval +
c_write.ncons + c_write.nlist + c_write.nstru;
c_control.nexecs =
opcount[_execute] +
opcount[_dexecute];
c_control.ncalls =
opcount[_call] +
opcount[_fcall];
c_control.nproceeds =
opcount[_procceed];
c_control.ncallbips =
opcount[_call_cpred] +
opcount[_call_c_wfail] +
opcount[_try_c] +
opcount[_retry_c] +
opcount[_op_fail] +
opcount[_trust_fail] +
opcount[_p_atom_x] +
opcount[_p_atom_y] +
opcount[_p_atomic_x] +
opcount[_p_atomic_y] +
opcount[_p_compound_x] +
opcount[_p_compound_y] +
opcount[_p_float_x] +
opcount[_p_float_y] +
opcount[_p_integer_x] +
opcount[_p_integer_y] +
opcount[_p_nonvar_x] +
opcount[_p_nonvar_y] +
opcount[_p_number_x] +
opcount[_p_number_y] +
opcount[_p_var_x] +
opcount[_p_var_y] +
opcount[_p_db_ref_x] +
opcount[_p_db_ref_y] +
opcount[_p_cut_by_x] +
opcount[_p_cut_by_y] +
opcount[_p_primitive_x] +
opcount[_p_primitive_y] +
opcount[_p_equal] +
opcount[_p_plus_vv] +
opcount[_p_plus_vc] +
opcount[_p_plus_y_vv] +
opcount[_p_plus_y_vc] +
opcount[_p_minus_vv] +
opcount[_p_minus_cv] +
opcount[_p_minus_y_vv] +
opcount[_p_minus_y_cv] +
opcount[_p_times_vv] +
opcount[_p_times_vc] +
opcount[_p_times_y_vv] +
opcount[_p_times_y_vc] +
opcount[_p_div_vv] +
opcount[_p_div_vc] +
opcount[_p_div_cv] +
opcount[_p_div_y_vv] +
opcount[_p_div_y_vc] +
opcount[_p_div_y_cv] +
opcount[_p_or_vv] +
opcount[_p_or_vc] +
opcount[_p_or_y_vv] +
opcount[_p_or_y_vc] +
opcount[_p_and_vv] +
opcount[_p_and_vc] +
opcount[_p_and_y_vv] +
opcount[_p_and_y_vc] +
opcount[_p_sll_vv] +
opcount[_p_sll_vc] +
opcount[_p_sll_y_vv] +
opcount[_p_sll_y_vc] +
opcount[_p_slr_vv] +
opcount[_p_slr_vc] +
opcount[_p_slr_y_vv] +
opcount[_p_slr_y_vc] +
opcount[_p_dif] +
opcount[_p_eq] +
opcount[_p_arg] +
opcount[_p_functor];
c_control.ncuts =
opcount[_cut] +
opcount[_cut_t] +
opcount[_cut_e] +
opcount[_comit_b_x] +
opcount[_comit_b_y];
c_control.nallocs =
opcount[_allocate] +
opcount[_fcall];
c_control.ndeallocs =
opcount[_dexecute] +
opcount[_deallocate];
controls =
c_control.nexecs +
c_control.ncalls +
c_control.nproceeds +
c_control.ncuts +
c_control.nallocs +
c_control.ndeallocs +
opcount[_jump] +
opcount[_move_back] +
opcount[_try_in];
c_cp.ntries =
opcount[_try_me] +
opcount[_try_me0] +
opcount[_try_me1] +
opcount[_try_me2] +
opcount[_try_me3] +
opcount[_try_me4] +
opcount[_try_and_mark] +
opcount[_try_c] +
opcount[_try_clause] +
opcount[_either];
c_cp.nretries =
opcount[_retry_me] +
opcount[_retry_me0] +
opcount[_retry_me1] +
opcount[_retry_me2] +
opcount[_retry_me3] +
opcount[_retry_me4] +
opcount[_retry_and_mark] +
opcount[_retry_c] +
opcount[_retry] +
opcount[_trust_in] +
opcount[_retry_first] +
opcount[_trust_first_in] +
opcount[_retry_tail] +
opcount[_trust_tail_in] +
opcount[_retry_head] +
opcount[_trust_head_in] +
opcount[_or_else];
c_cp.ntrusts =
opcount[_trust_me] +
opcount[_trust_me0] +
opcount[_trust_me1] +
opcount[_trust_me2] +
opcount[_trust_me3] +
opcount[_trust_me4] +
opcount[_trust] +
opcount[_trust_first] +
opcount[_trust_tail] +
opcount[_trust_head] +
opcount[_or_last];
choice_pts =
c_cp.ntries +
c_cp.nretries +
c_cp.ntrusts;
indexes =
opcount[_jump_if_var] +
opcount[_switch_on_type] +
opcount[_switch_on_nonv] +
opcount[_switch_last] +
opcount[_switch_on_head] +
opcount[_switch_list_nl] +
opcount[_switch_list_nl_prefetch] +
opcount[_switch_nv_list] +
opcount[_switch_l_list] +
opcount[_switch_on_cons] +
opcount[_go_on_cons] +
opcount[_if_cons] +
opcount[_switch_on_func] +
opcount[_go_on_func] +
opcount[_if_func] +
opcount[_if_not_then];
misc =
c_control.ncallbips +
opcount[_Ystop] +
opcount[_Nstop] +
opcount[_index_pred] +
opcount[_save_b_x] +
opcount[_save_b_y] +
opcount[_undef_p] +
opcount[_spy_pred] +
opcount[_spy_or_trymark] +
opcount[_save_pair_x] +
opcount[_save_pair_y] +
opcount[_save_pair_x_write] +
opcount[_save_pair_y_write] +
opcount[_save_appl_x] +
opcount[_save_appl_y] +
opcount[_save_appl_x_write] +
opcount[_save_appl_y_write];
total = gets + unifies + puts + writes + controls + choice_pts + indexes + misc;
/* for (i = 0; i <= _std_top; ++i)
* print_instruction(i);
*/
YP_fprintf(YP_stderr, "\n Instructions Executed in %s\n", program);
YP_fprintf(YP_stderr, "Groups are\n\n");
YP_fprintf(YP_stderr, " GET instructions: %8d (%3d%%)\n", gets,
(gets * 100) / total);
YP_fprintf(YP_stderr, " UNIFY instructions: %8d (%3d%%)\n", unifies,
(unifies * 100) / total);
YP_fprintf(YP_stderr, " PUT instructions: %8d (%3d%%)\n", puts,
(puts * 100) / total);
YP_fprintf(YP_stderr, " WRITE instructions: %8d (%3d%%)\n", writes,
(writes * 100) / total);
YP_fprintf(YP_stderr, " CONTROL instructions: %8d (%3d%%)\n", controls,
(controls * 100) / total);
YP_fprintf(YP_stderr, " CHOICE POINT instructions: %8d (%3d%%)\n", choice_pts,
(choice_pts * 100) / total);
YP_fprintf(YP_stderr, " INDEXING instructions: %8d (%3d%%)\n", indexes,
(indexes * 100) / total);
YP_fprintf(YP_stderr, " MISCELLANEOUS instructions: %8d (%3d%%)\n", misc,
(misc * 100) / total);
YP_fprintf(YP_stderr, "_______________________________________________\n");
YP_fprintf(YP_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
(total * 100) / total);
YP_fprintf(YP_stderr, "\n Analysis of Unification Instructions in %s \n", program);
YP_fprintf(YP_stderr, " XVAR, YVAR, XVAL, YVAL, CONS, LIST, STRUCT\n");
YP_fprintf(YP_stderr, " GET: %8d %8d %8d %8d %8d %8d %8d\n",
c_get.nxvar,
c_get.nyvar,
c_get.nxval,
c_get.nyval,
c_get.ncons,
c_get.nlist,
c_get.nstru);
YP_fprintf(YP_stderr, "UNIFY: %8d %8d %8d %8d %8d %8d %8d\n",
c_unify.nxvar,
c_unify.nyvar,
c_unify.nxval,
c_unify.nyval,
c_unify.ncons,
c_unify.nlist,
c_unify.nstru);
YP_fprintf(YP_stderr, " PUT: %8d %8d %8d %8d %8d %8d %8d\n",
c_put.nxvar,
c_put.nyvar,
c_put.nxval,
c_put.nyval,
c_put.ncons,
c_put.nlist,
c_put.nstru);
YP_fprintf(YP_stderr, "WRITE: %8d %8d %8d %8d %8d %8d %8d\n",
c_write.nxvar,
c_write.nyvar,
c_write.nxval,
c_write.nyval,
c_write.ncons,
c_write.nlist,
c_write.nstru);
YP_fprintf(YP_stderr, " ___________________________________________________\n");
YP_fprintf(YP_stderr, "TOTAL: %8d %8d %8d %8d %8d %8d %8d\n",
c_get.nxvar + c_unify.nxvar + c_put.nxvar + c_write.nxvar,
c_get.nyvar + c_unify.nyvar + c_put.nyvar + c_write.nyvar,
c_get.nxval + c_unify.nxval + c_put.nxval + c_write.nxval,
c_get.nyval + c_unify.nyval + c_put.nyval + c_write.nyval,
c_get.ncons + c_unify.ncons + c_put.ncons + c_write.ncons,
c_get.nlist + c_unify.nlist + c_put.nlist + c_write.nlist,
c_get.nstru + c_unify.nstru + c_put.nstru + c_write.nstru
);
YP_fprintf(YP_stderr, "\n Analysis of Unification Instructions in %s \n", program);
YP_fprintf(YP_stderr, " XVAR, YVAR, XVAL, YVAL, CONS, LIST, STRUCT\n");
YP_fprintf(YP_stderr, " GET: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_get.nxvar) * 100) / total,
(((double) c_get.nyvar) * 100) / total,
(((double) c_get.nxval) * 100) / total,
(((double) c_get.nyval) * 100) / total,
(((double) c_get.ncons) * 100) / total,
(((double) c_get.nlist) * 100) / total,
(((double) c_get.nstru) * 100) / total);
YP_fprintf(YP_stderr, "UNIFY: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_unify.nxvar) * 100) / total,
(((double) c_unify.nyvar) * 100) / total,
(((double) c_unify.nxval) * 100) / total,
(((double) c_unify.nyval) * 100) / total,
(((double) c_unify.ncons) * 100) / total,
(((double) c_unify.nlist) * 100) / total,
(((double) c_unify.nstru) * 100) / total);
YP_fprintf(YP_stderr, " PUT: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_put.nxvar) * 100) / total,
(((double) c_put.nyvar) * 100) / total,
(((double) c_put.nxval) * 100) / total,
(((double) c_put.nyval) * 100) / total,
(((double) c_put.ncons) * 100) / total,
(((double) c_put.nlist) * 100) / total,
(((double) c_put.nstru) * 100) / total);
YP_fprintf(YP_stderr, "WRITE: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_write.nxvar) * 100) / total,
(((double) c_write.nyvar) * 100) / total,
(((double) c_write.nxval) * 100) / total,
(((double) c_write.nyval) * 100) / total,
(((double) c_write.ncons) * 100) / total,
(((double) c_write.nlist) * 100) / total,
(((double) c_write.nstru) * 100) / total);
YP_fprintf(YP_stderr, " ___________________________________________________\n");
YP_fprintf(YP_stderr, "TOTAL: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
(((double) c_get.nxvar + c_unify.nxvar + c_put.nxvar + c_write.nxvar) * 100) / total,
(((double) c_get.nyvar + c_unify.nyvar + c_put.nyvar + c_write.nyvar) * 100) / total,
(((double) c_get.nxval + c_unify.nxval + c_put.nxval + c_write.nxval) * 100) / total,
(((double) c_get.nyval + c_unify.nyval + c_put.nyval + c_write.nyval) * 100) / total,
(((double) c_get.ncons + c_unify.ncons + c_put.ncons + c_write.ncons) * 100) / total,
(((double) c_get.nlist + c_unify.nlist + c_put.nlist + c_write.nlist) * 100) / total,
(((double) c_get.nstru + c_unify.nstru + c_put.nstru + c_write.nstru) * 100) / total
);
YP_fprintf(YP_stderr, "\n Control Instructions Executed in %s \n", program);
YP_fprintf(YP_stderr, "Grouped as\n\n");
YP_fprintf(YP_stderr, " CALL instructions: %8d (%3d%%)\n",
c_control.ncalls, (c_control.ncalls * 100) / total);
YP_fprintf(YP_stderr, " PROCEED instructions: %8d (%3d%%)\n",
c_control.nproceeds, (c_control.nproceeds * 100) / total);
YP_fprintf(YP_stderr, " EXECUTE instructions: %8d (%3d%%)\n",
c_control.nexecs, (c_control.nexecs * 100) / total);
YP_fprintf(YP_stderr, " CUT instructions: %8d (%3d%%)\n",
c_control.ncuts, (c_control.ncuts * 100) / total);
YP_fprintf(YP_stderr, " CALL_BIP instructions: %8d (%3d%%)\n",
c_control.ncallbips, (c_control.ncallbips * 100) / total);
YP_fprintf(YP_stderr, " ALLOCATE instructions: %8d (%3d%%)\n",
c_control.nallocs, (c_control.nallocs * 100) / total);
YP_fprintf(YP_stderr, " DEALLOCATE instructions: %8d (%3d%%)\n",
c_control.ndeallocs, (c_control.ndeallocs * 100) / total);
YP_fprintf(YP_stderr, "_______________________________________________\n");
YP_fprintf(YP_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
(total * 100) / total);
YP_fprintf(YP_stderr, "\n Choice Point Manipulation Instructions Executed in %s \n", program);
YP_fprintf(YP_stderr, "Grouped as\n\n");
YP_fprintf(YP_stderr, " TRY instructions: %8d (%3d%%)\n",
c_cp.ntries, (c_cp.ntries * 100) / total);
YP_fprintf(YP_stderr, " RETRY instructions: %8d (%3d%%)\n",
c_cp.nretries, (c_cp.nretries * 100) / total);
YP_fprintf(YP_stderr, " TRUST instructions: %8d (%3d%%)\n",
c_cp.ntrusts, (c_cp.ntrusts * 100) / total);
YP_fprintf(YP_stderr, "_______________________________________________\n");
YP_fprintf(YP_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
(total * 100) / total);
return (TRUE);
}
void
InitAnalystPreds(void)
{
InitCPred("reset_op_counters", 0, p_reset_op_counters, SafePredFlag |SyncPredFlag);
InitCPred("show_op_counters", 1, p_show_op_counters, SafePredFlag|SyncPredFlag);
InitCPred("show_ops_by_group", 1, p_show_ops_by_group, SafePredFlag |SyncPredFlag);
}
#endif /* ANALYST */

227
C/arith0.c Normal file
View File

@@ -0,0 +1,227 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: eval.c *
* Last rev: *
* mods: *
* comments: arithmetical expression evaluation *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This file implements arithmetic operations
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "eval.h"
#define E_FUNC blob_type
#define E_ARGS arith_retptr o
#define RINT(v) (o)->Int = v; return(long_int_e)
#define RFLOAT(v) (o)->dbl = v; return(double_e)
#define RERROR() return(db_ref_e)
#ifndef PI
#ifdef M_PI
#define PI M_PI
#else
#define PI 3.14159265358979323846
#endif
#endif
static E_FUNC
p_pi(E_ARGS)
{
RFLOAT(PI);
}
#ifndef M_E
#define M_E 2.7182818284590452354
#endif
static E_FUNC
p_e(E_ARGS)
{
RFLOAT(M_E);
}
#ifndef INFINITY
#define INFINITY (1.0/0.0)
#endif
static E_FUNC
p_inf(E_ARGS)
{
#ifdef _MSC_VER /* Microsoft's Visual C++ Compiler */
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
P = (yamop *)FAILCODE;
RERROR();
#else
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {/* iso */
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(INFINITY);
}
#endif
}
#ifndef NAN
#define NAN (0.0/0.0)
#endif
static E_FUNC
p_nan(E_ARGS)
{
#ifdef _MSC_VER /* Microsoft's Visual C++ Compiler */
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
P = (yamop *)FAILCODE;
RERROR();
#else
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {/* iso */
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating not-a-number");
P = (yamop *)FAILCODE;
RERROR();
} else {
RFLOAT(NAN);
}
#endif
}
static E_FUNC
p_random(E_ARGS)
{
RFLOAT(yap_random());
}
static E_FUNC
p_cputime(E_ARGS)
{
RFLOAT((Float)cputime()/1000.0);
}
static E_FUNC
p_heapused(E_ARGS)
{
RINT(HeapUsed);
}
static E_FUNC
p_localsp(E_ARGS)
{
#if SBA
RINT((Int)ASP);
#else
RINT(LCL0 - ASP);
#endif
}
static E_FUNC
p_b(E_ARGS)
{
#if SBA
RINT((Int)B);
#else
RINT(LCL0 - (CELL *)B);
#endif
}
static E_FUNC
p_globalsp(E_ARGS)
{
#if SBA
RINT((Int)H);
#else
RINT(H - H0);
#endif
}
static E_FUNC
p_stackfree(E_ARGS)
{
RINT(Unsigned(ASP) - Unsigned(H));
}
typedef blob_type (*f_constexp)(arith_retptr);
typedef struct init_const_eval {
char *OpName;
f_constexp f;
} InitConstEntry;
static InitConstEntry InitConstTab[] = {
{"pi", p_pi},
{"e", p_e},
{"inf", p_inf},
{"nan", p_nan},
{"random", p_random},
{"cputime", p_cputime},
{"heapused", p_heapused},
{"local_sp", p_localsp},
{"global_sp", p_globalsp},
{"$last_choice_pt", p_b},
{"stackfree", p_stackfree},
};
void
InitConstExps(void)
{
unsigned int i;
ExpEntry *p;
for (i = 0; i < sizeof(InitConstTab)/sizeof(InitConstEntry); ++i) {
AtomEntry *ae = RepAtom(LookupAtom(InitConstTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if (LockedGetExpProp(ae, 0)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
p = (ExpEntry *) AllocAtomSpace(sizeof(ExpEntry));
p->KindOfPE = ExpProperty;
p->ArityOfEE = 0;
p->ENoOfEE = 0;
p->FOfEE.constant = InitConstTab[i].f;
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsExpProp(p);
WRITE_UNLOCK(ae->ARWLock);
}
}
/* This routine is called from Restore to make sure we have the same arithmetic operators */
int
ReInitConstExps(void)
{
unsigned int i;
Prop p;
for (i = 0; i < sizeof(InitConstTab)/sizeof(InitConstEntry); ++i) {
AtomEntry *ae = RepAtom(FullLookupAtom(InitConstTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if ((p = LockedGetExpProp(ae, 0)) == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return(FALSE);
}
RepExpProp(p)->FOfEE.constant = InitConstTab[i].f;
WRITE_UNLOCK(ae->ARWLock);
}
return(TRUE);
}

2046
C/arith1.c Normal file
View File

File diff suppressed because it is too large Load Diff

1753
C/arith2.c Normal file
View File

File diff suppressed because it is too large Load Diff

1525
C/arithi2.c Normal file
View File

File diff suppressed because it is too large Load Diff

1562
C/arrays.c Normal file
View File

File diff suppressed because it is too large Load Diff

552
C/attvar.c Normal file
View File

@@ -0,0 +1,552 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: attvar.c *
* Last rev: *
* mods: *
* comments: YAP support for attributed vars *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[]="%W% %G%";
#endif
#include "Yap.h"
#ifdef COROUTINING
#include "Yatom.h"
#include "Heap.h"
#include "heapgc.h"
#include "attvar.h"
#ifndef NULL
#define NULL (void *)0
#endif
STATIC_PROTO(Int InitVarTime, (void));
STATIC_PROTO(Int CurrentTime, (void));
static CELL *
AddToQueue(attvar_record *attv)
{
Term t[2];
sus_record *WGs;
sus_record *new;
t[0] = (CELL)&(attv->Done);
t[1] = attv->Value;
/* follow the chain */
WGs = (sus_record *)ReadTimedVar(WokenGoals);
new = (sus_record *)H;
H = (CELL *)(new+1);
new->NR = (sus_record *)(&(new->NR));
new->SG = MkApplTerm(FunctorAttGoal, 2, t);
new->NS = new;
if ((Term)WGs == TermNil) {
UpdateTimedVar(WokenGoals, (CELL)new);
/* from now on, we have to start waking up goals */
if (CreepFlag != Unsigned(LCL0) - Unsigned(H0))
CreepFlag = Unsigned(LCL0);
} else {
/* add to the end of the current list of suspended goals */
CELL *where_to = (CELL *)Deref((CELL)WGs);
Bind_Global(where_to, (CELL)new);
}
return(RepAppl(new->SG)+2);
}
static CELL *
AddFailToQueue(void)
{
sus_record *WGs;
sus_record *new;
/* follow the chain */
WGs = (sus_record *)ReadTimedVar(WokenGoals);
new = (sus_record *)H;
H = (CELL *)(new+1);
new->NR = (sus_record *)(&(new->NR));
new->SG = MkAtomTerm(AtomFail);
new->NS = new;
if ((Term)WGs == TermNil) {
UpdateTimedVar(WokenGoals, (CELL)new);
/* from now on, we have to start waking up goals */
if (CreepFlag != Unsigned(LCL0) - Unsigned(H0))
CreepFlag = Unsigned(LCL0);
} else {
/* add to the end of the current list of suspended goals */
CELL *where_to = (CELL *)Deref((CELL)WGs);
Bind_Global(where_to, (CELL)new);
}
return(RepAppl(new->SG)+2);
}
static int
CopyAttVar(Term orig, CELL ***to_visit_ptr)
{
register attvar_record *attv = (attvar_record *)orig;
register attvar_record *newv;
CELL **to_visit = *to_visit_ptr;
Term ttime;
Term time = InitVarTime();
Int j;
/* add a new attributed variable */
newv = (attvar_record *)ReadTimedVar(DelayedVars);
if (H0 - (CELL *)newv < 1024+(2*NUM_OF_ATTS))
return(FALSE);
RESET_VARIABLE(&(newv->Done));
newv->sus_id = attvars_ext;
RESET_VARIABLE(&(newv->Value));
newv->NS = UpdateTimedVar(AttsMutableList, (CELL)&(newv->Done));
ttime = MkIntegerTerm(time);
for (j = 0; j < NUM_OF_ATTS; j++) {
newv->Atts[2*j] = ttime;
to_visit[0] = attv->Atts+2*j;
to_visit[1] = attv->Atts+2*j+1;
to_visit[2] = newv->Atts+2*j+1;
to_visit += 3;
}
*to_visit_ptr = to_visit;
UpdateTimedVar(DelayedVars, (CELL)(newv->Atts+2*j));
return(TRUE);
}
static void
WakeAttVar(CELL* pt1, CELL reg2)
{
/* if bound to someone else, follow until we find the last one */
attvar_record *attv = (attvar_record *)pt1;
CELL *myH = H;
CELL *bind_ptr;
if (!IsVarTerm(attv->Value) || !IsUnboundVar(attv->Value)) {
/* oops, our goal is on the queue to be woken */
if (!unify(attv->Value, reg2)) {
AddFailToQueue();
}
return;
}
if (IsVarTerm(reg2)) {
if (IsAttachedTerm(reg2)) {
attvar_record *susp2 = (attvar_record *)VarOfTerm(reg2);
/* binding two suspended variables, be careful */
if (susp2->sus_id != attvars_ext) {
/* joining two different kinds of suspensions */
Error(SYSTEM_ERROR, TermNil, "joining two different suspensions not implemented");
return;
}
if (susp2 >= attv) {
if (susp2 == attv) return;
if (!IsVarTerm(susp2->Value) || !IsUnboundVar(susp2->Value)) {
/* oops, our goal is on the queue to be woken */
if (!unify(susp2->Value, (CELL)pt1)) {
AddFailToQueue();
}
}
Bind_Global(&(susp2->Value), (CELL)pt1);
AddToQueue(susp2);
return;
}
} else {
Bind(VarOfTerm(reg2), (CELL)pt1);
return;
}
}
bind_ptr = AddToQueue(attv);
if (IsNonVarTerm(reg2)) {
if (IsPairTerm(reg2) && RepPair(reg2) == myH)
reg2 = AbsPair(H);
else if (IsApplTerm(reg2) && RepAppl(reg2) == myH)
reg2 = AbsAppl(H);
}
*bind_ptr = reg2;
Bind_Global(&(attv->Value), reg2);
}
#ifndef FIXED_STACKS
static void
mark_attvar(CELL *orig)
{
register attvar_record *attv = (attvar_record *)orig;
Int i;
mark_external_reference(&(attv->Value));
mark_external_reference(&(attv->Done));
for (i = 0; i < NUM_OF_ATTS; i++) {
mark_external_reference(attv->Atts+2*i+1);
}
}
#endif /* FIXED_STACKS */
static Int
CurrentTime(void) {
return((CELL *)(TR)-(CELL *)TrailBase);
}
static Int
InitVarTime(void) {
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
/* so we just init a TR cell that will not harm anyone */
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
return((CELL *)(B->cp_tr)-(CELL *)TrailBase);
}
static Int
PutAtt(attvar_record *attv, Int i, Term tatt) {
Int pos = i*2;
tr_fr_ptr timestmp = (tr_fr_ptr)((CELL *)TrailBase+IntegerOfTerm(attv->Atts[pos]));
if (B->cp_tr <= timestmp
#if defined(SBA) || defined(TABLING)
&& timestmp <= TR
#endif
) {
#if defined(SBA)
if (Unsigned((Int)(attv)-(Int)(H_FZ)) >
Unsigned((Int)(B_FZ)-(Int)(H_FZ))) {
CELL *ptr = STACK_TO_SBA(attv->Atts+pos+1);
*ptr = tatt;
} else
#endif
attv->Atts[pos+1] = tatt;
#if defined(SBA) || defined(TABLING)
if (Unsigned((Int)(attv)-(Int)(HBREG)) >
Unsigned(BBREG)-(Int)(HBREG))
TrailVal(timestmp-1) = tatt;
#endif
} else {
Term tnewt;
MaBind(attv->Atts+pos+1, tatt);
tnewt = MkIntegerTerm(CurrentTime());
MaBind(attv->Atts+pos, tnewt);
}
return(TRUE);
}
static Int
RmAtt(attvar_record *attv, Int i) {
Int pos = i *2;
if (!IsVarTerm(attv->Atts[pos+1])) {
tr_fr_ptr timestmp = (tr_fr_ptr)((CELL *)TrailBase+IntegerOfTerm(attv->Atts[pos]));
if (B->cp_tr <= timestmp
#if defined(SBA) || defined(TABLING)
&& timestmp <= TR
#endif
) {
RESET_VARIABLE(attv->Atts+(pos+1));
#if defined(SBA) || defined(TABLING)
if (Unsigned((Int)(attv)-(Int)(HBREG)) >
Unsigned(BBREG)-(Int)(HBREG))
TrailVal(timestmp-1) = attv->Atts[pos+1];
#endif
} else {
/* reset the variable */
Term tnewt;
#ifdef SBA
MaBind(attv->Atts+(pos+1), 0L);
#else
MaBind(attv->Atts+(pos+1), (CELL)(attv->Atts+(pos+1)));
#endif
tnewt = MkIntegerTerm(CurrentTime());
MaBind(attv->Atts+pos, tnewt);
}
}
return(TRUE);
}
static Int
BuildNewAttVar(Term t, Int i, Term tatt)
{
/* allocate space in Heap */
Term time = InitVarTime();
int j;
Term ttime;
attvar_record *attv = (attvar_record *)ReadTimedVar(DelayedVars);
if (H0 - (CELL *)attv < 1024+(2*NUM_OF_ATTS)) {
ARG1 = t;
ARG2 = tatt;
growglobal();
t = ARG1;
tatt = ARG2;
}
RESET_VARIABLE(&(attv->Value));
RESET_VARIABLE(&(attv->Done));
attv->sus_id = attvars_ext;
ttime = MkIntegerTerm(time);
for (j = 0; j < NUM_OF_ATTS; j++) {
attv->Atts[2*j] = ttime;
RESET_VARIABLE(attv->Atts+2*j+1);
}
attv->NS = UpdateTimedVar(AttsMutableList, (CELL)&(attv->Done));
Bind((CELL *)t,(CELL)attv);
UpdateTimedVar(DelayedVars,(CELL)(attv->Atts+2*j));
return(PutAtt(attv, i, tatt));
}
static Int
GetAtt(attvar_record *attv, int i) {
Int pos = i *2;
#if SBA
if (IsUnboundVar(attv->Atts[pos+1]))
return((CELL)&(attv->Atts[pos+1]));
#endif
return(attv->Atts[pos+1]);
}
static Int
FreeAtt(attvar_record *attv, int i) {
Int pos = i *2;
return(IsVarTerm(attv->Atts[pos+1]));
}
static Int
BindAttVar(attvar_record *attv) {
if (IsVarTerm(attv->Done) && IsUnboundVar(attv->Done)) {
Bind_Global(&(attv->Done), attv->Value);
return(TRUE);
} else {
Error(SYSTEM_ERROR,(CELL)&(attv->Done),"attvar was bound when set");
return(FALSE);
}
}
static Term
GetAllAtts(attvar_record *attv) {
Int i;
Term t = TermNil;
for (i = NUM_OF_ATTS-1; i >= 0; i --) {
if (!IsVarTerm(attv->Atts[2*i+1]))
t = MkPairTerm(MkPairTerm(MkIntegerTerm(i),attv->Atts[2*i+1]), t);
}
return(t);
}
static Term
AllAttVars(Term t) {
if (t == TermNil) {
return(t);
} else {
attvar_record *attv = (attvar_record *)VarOfTerm(t);
if (!IsVarTerm(attv->Done) || !IsUnboundVar(attv->Done))
return(AllAttVars(attv->NS));
else return(MkPairTerm(t,AllAttVars(attv->NS)));
}
}
Term
CurrentAttVars(void) {
return(AllAttVars(ReadTimedVar(AttsMutableList)));
}
static Int
p_put_att(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
return(PutAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3)));
}
return(BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), Deref(ARG3)));
} else {
Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE);
}
}
static Int
p_rm_att(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Error(TYPE_ERROR_VARIABLE,inp,"delete_attribute/2");
return(FALSE);
}
return(RmAtt(attv, IntegerOfTerm(Deref(ARG2))));
}
return(TRUE);
} else {
Error(TYPE_ERROR_VARIABLE,inp,"delete_attribute/2");
return(FALSE);
}
}
static Int
p_get_att(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
Term out;
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
out = GetAtt(attv,IntegerOfTerm(Deref(ARG2)));
return(!IsVarTerm(out) && unify(ARG3,out));
}
/* Error(INSTANTIATION_ERROR,inp,"get_att/2");*/
return(FALSE);
} else {
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
}
static Int
p_free_att(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
return(FreeAtt(attv,IntegerOfTerm(Deref(ARG2))));
}
return(TRUE);
} else {
Error(TYPE_ERROR_VARIABLE,inp,"free_att/2");
return(FALSE);
}
}
static Int
p_bind_attvar(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)attv->sus_id;
if (id != attvars_ext) {
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
return(BindAttVar(attv));
}
return(TRUE);
} else {
Error(TYPE_ERROR_VARIABLE,inp,"bind_att/2");
return(FALSE);
}
}
static Int
p_get_all_atts(void) {
/* receive a variable in ARG1 */
Term inp = Deref(ARG1);
/* if this is unbound, ok */
if (IsVarTerm(inp)) {
if (IsAttachedTerm(inp)) {
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
exts id = (exts)(attv->sus_id);
if (id != attvars_ext) {
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
return(unify(ARG2,GetAllAtts(attv)));
}
return(TRUE);
} else {
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
return(FALSE);
}
}
static Int
p_inc_atts(void)
{
Term t = MkIntegerTerm(NUM_OF_ATTS);
NUM_OF_ATTS++;
return(unify(ARG1,t));
}
static Int
p_n_atts(void)
{
Term t = MkIntegerTerm(NUM_OF_ATTS);
return(unify(ARG1,t));
}
static Int
p_all_attvars(void)
{
Term t = ReadTimedVar(AttsMutableList);
return(unify(ARG1,AllAttVars(t)));
}
static Int
p_is_attvar(void)
{
Term t = Deref(ARG1);
return(IsVarTerm(t) &&
IsAttachedTerm(t) &&
((attvar_record *)VarOfTerm(t))->sus_id == attvars_ext);
}
void InitAttVarPreds(void)
{
attas[attvars_ext].bind_op = WakeAttVar;
attas[attvars_ext].copy_term_op = CopyAttVar;
#ifndef FIXED_STACKS
attas[attvars_ext].mark_op = mark_attvar;
#endif
InitCPred("get_att", 3, p_get_att, SafePredFlag);
InitCPred("get_all_atts", 2, p_get_all_atts, SafePredFlag);
InitCPred("free_att", 2, p_free_att, SafePredFlag);
InitCPred("put_att", 3, p_put_att, 0);
InitCPred("rm_att", 2, p_rm_att, SafePredFlag);
InitCPred("inc_n_of_atts", 1, p_inc_atts, SafePredFlag);
InitCPred("n_of_atts", 1, p_n_atts, SafePredFlag);
InitCPred("bind_attvar", 1, p_bind_attvar, SafePredFlag);
InitCPred("$all_attvars", 1, p_all_attvars, SafePredFlag);
InitCPred("$is_att_variable", 1, p_is_attvar, SafePredFlag);
}
#endif /* COROUTINING */

352
C/bb.c Normal file
View File

@@ -0,0 +1,352 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: bb.c *
* Last rev: 12/29/99 *
* mods: *
* comments: YAP's blackboard routines *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#ifndef NULL
#define NULL (void *)0
#endif
static BBProp
PutBBProp(AtomEntry *ae) /* get BBentry for at; */
{
Prop p0;
BBProp p;
WRITE_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != CurrentModule))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
p = (BBProp)AllocAtomSpace(sizeof(*p));
if (p == NULL) {
WRITE_UNLOCK(ae->ARWLock);
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsBBProp(p);
p->ModuleOfBB = CurrentModule;
p->Element = NULL;
p->KeyOfBB = AbsAtom(ae);
p->KindOfPE = BBProperty;
INIT_RWLOCK(p->BBRWLock);
}
WRITE_UNLOCK(ae->ARWLock);
return (p);
}
static BBProp
PutIntBBProp(Int key) /* get BBentry for at; */
{
Prop p0;
BBProp p;
UInt hash_key;
if (INT_BB_KEYS == NULL) {
INT_BB_KEYS = (Prop *)AllocCodeSpace(sizeof(Prop)*INT_BB_KEYS_SIZE);
if (INT_BB_KEYS != NULL) {
UInt i = 0;
Prop *pp = INT_BB_KEYS;
for (i = 0; i < INT_BB_KEYS_SIZE; i++) {
pp[0] = NIL;
pp++;
}
} else {
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
}
hash_key = (CELL)key % INT_BB_KEYS_SIZE;
p0 = INT_BB_KEYS[hash_key];
p = RepBBProp(p0);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
key != (Int)(p->KeyOfBB) ||
(p->ModuleOfBB != CurrentModule))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
YAPEnterCriticalSection();
p = (BBProp)AllocAtomSpace(sizeof(*p));
if (p == NULL) {
YAPLeaveCriticalSection();
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
p->ModuleOfBB = CurrentModule;
p->Element = NULL;
p->KeyOfBB = (Atom)key;
p->KindOfPE = BBProperty;
p->NextOfPE = INT_BB_KEYS[hash_key];
INT_BB_KEYS[hash_key] = AbsBBProp(p);
YAPLeaveCriticalSection();
}
return (p);
}
static BBProp
GetBBProp(AtomEntry *ae) /* get BBentry for at; */
{
Prop p0;
BBProp p;
READ_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != CurrentModule))) {
p = RepBBProp(p0 = p->NextOfPE);
}
READ_UNLOCK(ae->ARWLock);
if (p0 == NIL) {
return(NULL);
}
return (p);
}
static BBProp
GetIntBBProp(Int key) /* get BBentry for at; */
{
Prop p0;
BBProp p;
UInt hash_key;
if (INT_BB_KEYS == NULL)
return(NULL);
hash_key = (CELL)key % INT_BB_KEYS_SIZE;
p0 = INT_BB_KEYS[hash_key];
p = RepBBProp(p0);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
key != (Int)(p->KeyOfBB) ||
(p->ModuleOfBB != CurrentModule))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
return(NULL);
}
return (p);
}
static int
resize_bb_int_keys(UInt new_size) {
Prop *new;
UInt i;
YAPEnterCriticalSection();
if (INT_BB_KEYS == NULL) {
INT_BB_KEYS_SIZE = new_size;
YAPLeaveCriticalSection();
return(TRUE);
}
new = (Prop *)AllocCodeSpace(sizeof(Prop)*new_size);
if (new == NULL) {
YAPLeaveCriticalSection();
Error(SYSTEM_ERROR,ARG1,"could not allocate space");
return(FALSE);
}
for (i = 0; i < new_size; i++) {
new[i] = NIL;
}
for (i = 0; i < INT_BB_KEYS_SIZE; i++) {
if (INT_BB_KEYS[i] != NIL) {
Prop p0 = INT_BB_KEYS[i];
while (p0 != NIL) {
BBProp p = RepBBProp(p0);
CELL key = (CELL)(p->KeyOfBB);
UInt hash_key = (CELL)key % new_size;
p0 = p->NextOfPE;
p->NextOfPE = new[hash_key];
new[hash_key] = AbsBBProp(p);
}
}
}
FreeCodeSpace((char *)INT_BB_KEYS);
INT_BB_KEYS = new;
INT_BB_KEYS_SIZE = new_size;
YAPLeaveCriticalSection();
return(TRUE);
}
static BBProp
AddBBProp(Term t1, char *msg)
{
SMALLUNSGN old_module = CurrentModule;
BBProp p;
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
return(NULL);
} if (IsAtomTerm(t1)) {
p = PutBBProp(RepAtom(AtomOfTerm(t1)));
} else if (IsIntegerTerm(t1)) {
p = PutIntBBProp(IntegerOfTerm(t1));
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term mod = ArgOfTerm(1, t1);
if (!IsVarTerm(mod) ) {
CurrentModule = LookupModule(mod);
t1 = ArgOfTerm(2, t1);
p = AddBBProp(t1, msg);
} else {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
return(NULL);
}
} else {
Error(TYPE_ERROR_ATOM, t1, msg);
CurrentModule = old_module;
return(NULL);
}
CurrentModule = old_module;
return(p);
}
static BBProp
FetchBBProp(Term t1, char *msg)
{
SMALLUNSGN old_module = CurrentModule;
BBProp p;
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
return(NULL);
} if (IsAtomTerm(t1)) {
p = GetBBProp(RepAtom(AtomOfTerm(t1)));
} else if (IsIntegerTerm(t1)) {
p = GetIntBBProp(IntegerOfTerm(t1));
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term mod = ArgOfTerm(1, t1);
if (!IsVarTerm(mod) ) {
CurrentModule = LookupModule(mod);
t1 = ArgOfTerm(2, t1);
p = FetchBBProp(t1, msg);
} else {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
return(NULL);
}
} else {
Error(TYPE_ERROR_ATOM, t1, msg);
CurrentModule = old_module;
return(NULL);
}
CurrentModule = old_module;
return(p);
}
static Int
p_bb_put(void)
{
Term t1 = Deref(ARG1);
BBProp p = AddBBProp(t1, "bb_put/2");
if (p == NULL)
return(FALSE);
WRITE_LOCK(p->BBRWLock);
if (p->Element != NULL) {
ReleaseTermFromDB(p->Element);
}
p->Element = StoreTermInDB(Deref(ARG2),3);
WRITE_UNLOCK(p->BBRWLock);
return(p->Element != NULL);
}
static Int
p_bb_get(void)
{
Term t1 = Deref(ARG1);
BBProp p = FetchBBProp(t1, "bb_get/2");
Term out;
if (p == NULL || p->Element == NULL)
return(FALSE);
READ_LOCK(p->BBRWLock);
out = FetchTermFromDB(p->Element,3);
READ_UNLOCK(p->BBRWLock);
return(unify(ARG2,out));
}
static Int
p_bb_delete(void)
{
Term t1 = Deref(ARG1);
BBProp p;
Term out;
p = FetchBBProp(t1, "bb_delete/2");
if (p == NULL || p->Element == NULL)
return(FALSE);
out = FetchTermFromDB(p->Element,3);
WRITE_LOCK(p->BBRWLock);
ReleaseTermFromDB(p->Element);
p->Element = NULL;
WRITE_UNLOCK(p->BBRWLock);
return(unify(ARG2,out));
}
static Int
p_bb_update(void)
{
Term t1 = Deref(ARG1);
BBProp p;
Term out;
p = FetchBBProp(t1, "bb_update/3");
if (p == NULL || p->Element == NULL)
return(FALSE);
WRITE_LOCK(p->BBRWLock);
out = FetchTermFromDB(p->Element,3);
if (!unify(ARG2,out)) {
WRITE_UNLOCK(p->BBRWLock);
return(FALSE);
}
ReleaseTermFromDB(p->Element);
p->Element = StoreTermInDB(Deref(ARG3),3);
WRITE_UNLOCK(p->BBRWLock);
return(TRUE);
}
static Int
p_resize_bb_int_keys(void)
{
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
return(unify(ARG1,MkIntegerTerm((Int)INT_BB_KEYS_SIZE)));
}
if (!IsIntegerTerm(t1)) {
Error(TYPE_ERROR_INTEGER, t1, "yap_flag(resize_bb_int_keys,T)");
return(FALSE);
}
return(resize_bb_int_keys(IntegerOfTerm(t1)));
}
void
InitBBPreds(void)
{
InitCPred("bb_put", 2, p_bb_put, 0);
InitCPred("bb_get", 2, p_bb_get, 0);
InitCPred("bb_delete", 2, p_bb_delete, 0);
InitCPred("bb_update", 3, p_bb_update, 0);
InitCPred("$resize_bb_int_keys", 1, p_resize_bb_int_keys, SafePredFlag|SyncPredFlag);
}

216
C/bignum.c Normal file
View File

@@ -0,0 +1,216 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: arith1.c *
* Last rev: *
* mods: *
* comments: bignum support through gmp *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#ifdef USE_GMP
#include "Heap.h"
#include "eval.h"
#include "alloc.h"
#if HAVE_STRING_H
#include <string.h>
#endif
/* This global variable tells how things are going */
static CELL *pre_alloc_base = NULL, *alloc_ptr;
MP_INT *
PreAllocBigNum(void)
{
MP_INT *ret;
if (pre_alloc_base != H) {
/* inform where we are allocating */
alloc_ptr = pre_alloc_base = H;
}
ret = (MP_INT *)(alloc_ptr+1);
/* first reserve space for the functor */
alloc_ptr[0] = 0L;
/* now allocate space for mpz_t */
alloc_ptr = (CELL *)(ret+1);
/* initialise the fields */
mpz_init(ret);
return(ret);
}
MP_INT *
InitBigNum(Int in)
{
MP_INT *ret;
if (pre_alloc_base == NULL) {
/* inform where we are allocating */
alloc_ptr = pre_alloc_base = H;
}
ret = (MP_INT *)(alloc_ptr+1);
/* first reserve space for the functor */
/* I use a 0 to indicate this is the first time
we are building the bignum */
alloc_ptr[0] = 0L;
/* now allocate space for mpz_t */
alloc_ptr = (CELL *)(ret+1);
/* initialise the fields */
mpz_init_set_si(ret, in);
return(ret);
}
/* This is a trivial allocator that use the global space:
Each unit has a:
size;
nof elements;
*/
static void *
AllocBigNumSpace(size_t size)
{
void *ret = (void *)(alloc_ptr+1);
size = AdjustSize(size)/CellSize;
alloc_ptr[0] = size;
alloc_ptr += size+1;
if (alloc_ptr > ASP-1024)
Error(SYSTEM_ERROR,TermNil,"no space for bignum");
return(ret);
}
static void *
ReAllocBigNumSpace(void *optr, size_t osize, size_t size)
{
void *out;
size = AdjustSize(size)/CellSize;
osize = AdjustSize(osize)/CellSize;
if (((CELL *)optr)+osize == alloc_ptr) {
alloc_ptr += (size-osize);
((CELL *)optr)[-1] = size;
if (alloc_ptr > ASP-1024)
Error(SYSTEM_ERROR,TermNil,"no space for bignum");
return(optr);
}
out = AllocBigNumSpace(size);
memcpy(out, (const void *)optr, size*CellSize);
return(out);
}
static void
FreeBigNumSpace(void *optr, size_t size)
{
CELL *bp = (CELL *)optr;
size = AdjustSize(size)/CellSize;
if (bp+size == alloc_ptr) {
alloc_ptr = bp-1;
return;
}
/* just say it is free */
bp[-1] = -bp[-1];
}
/* This can be done in several different situations:
- we did BigIntOf and want to recover now (check through ret[0]);
- we have done PreAlloc() and then a lot happened in between:
o our final computation fits in an Int;
o our final computation is the first we PreAlloced();
o our final computation is not the first term we PreAlloced();
The result may be an Int, the old BigInt, or a BigInt moved to
pre_alloc_base;
*/
Term
MkBigIntTerm(MP_INT *big)
{
CELL *new = (CELL *)(big+1);
Int nlimbs = (big->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
Int sz;
CELL *ret = ((CELL *)big)-1;
sz = mpz_sizeinbase(big, 2);
/* was already there */
if (ret[0] == (CELL)FunctorBigInt) {
/* don't need to do no nothing */
return(AbsAppl(ret));
}
if (sz < SIZEOF_LONG_INT*8-1) {
Int out;
H = pre_alloc_base;
pre_alloc_base = NULL;
out = mpz_get_si(big);
return(MkIntegerTerm(out));
} else {
/* we may have created a lot of bignums since we did the first
PreAlloc(). We want to recover the space, not leave "holes" on
the global stack */
if (pre_alloc_base != ret) {
/* copy everything to the start of the temp area */
MP_INT *dst = (MP_INT *)(pre_alloc_base+1);
dst->_mp_size = big->_mp_size;
dst->_mp_alloc = big->_mp_alloc;
new = (CELL *)(dst+1);
ret = pre_alloc_base;
}
ret[0] = (CELL)FunctorBigInt;
memmove((void *)new, (const void *)(big->_mp_d), nlimbs*CellSize);
H = (CELL *)(new+nlimbs);
H[0] = ((H-ret)*sizeof(CELL)+EndSpecials)|MBIT;
H++;
pre_alloc_base = NULL;
return(AbsAppl(ret));
}
}
MP_INT *
BigIntOfTerm(Term t)
{
MP_INT *new = (MP_INT *)(RepAppl(t)+1);
new->_mp_d = (mp_limb_t *)(new+1);
return(new);
}
#endif
static Int
p_is_bignum(void)
{
#ifdef USE_GMP
Term t = Deref(ARG1);
return(IsNonVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == FunctorBigInt);
#else
return(FALSE);
#endif
}
void
InitBigNums(void)
{
#ifdef USE_GMP
/* YAP style memory allocation */
mp_set_memory_functions(
AllocBigNumSpace,
ReAllocBigNumSpace,
FreeBigNumSpace);
#endif
InitCPred("$bignum", 1, p_is_bignum, SafePredFlag);
}

744
C/c_interface.c Normal file
View File

@@ -0,0 +1,744 @@
/*************************************************************************
* *
* YAP Prolog %W% %G% *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: c_interface.c *
* Last rev: 19/2/88 *
* mods: *
* comments: c_interface primitives definition *
* *
*************************************************************************/
#define Bool int
#define flt double
#define C_INTERFACE
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#define HAS_YAP_H 1
#include "yap_structs.h"
#ifdef YAPOR
#include "or.macros.h"
#endif /* YAPOR */
#define YAP_BOOT_FROM_PROLOG 0
#define YAP_BOOT_FROM_SAVED_CODE 1
#define YAP_BOOT_FROM_SAVED_STACKS 2
#define YAP_BOOT_FROM_SAVED_ERROR -1
#if defined(_MSC_VER) && defined(YAPDLL_EXPORTS)
#define X_API __declspec(dllexport)
#else
#define X_API
#endif
X_API Term STD_PROTO(YapA,(int));
X_API Term STD_PROTO(YapMkVarTerm,(void));
X_API Bool STD_PROTO(YapIsVarTerm,(Term));
X_API Bool STD_PROTO(YapIsNonVarTerm,(Term));
X_API Bool STD_PROTO(YapIsIntTerm,(Term));
X_API Bool STD_PROTO(YapIsFloatTerm,(Term));
X_API Bool STD_PROTO(YapIsDbRefTerm,(Term));
X_API Bool STD_PROTO(YapIsAtomTerm,(Term));
X_API Bool STD_PROTO(YapIsPairTerm,(Term));
X_API Bool STD_PROTO(YapIsApplTerm,(Term));
X_API Term STD_PROTO(YapMkIntTerm,(Int));
X_API Int STD_PROTO(YapIntOfTerm,(Term));
X_API Term STD_PROTO(YapMkFloatTerm,(flt));
X_API flt STD_PROTO(YapFloatOfTerm,(Term));
X_API Term STD_PROTO(YapMkAtomTerm,(Atom));
X_API Atom STD_PROTO(YapAtomOfTerm,(Term));
X_API Atom STD_PROTO(YapLookupAtom,(char *));
X_API Atom STD_PROTO(YapFullLookupAtom,(char *));
X_API char *STD_PROTO(YapAtomName,(Atom));
X_API Term STD_PROTO(YapMkPairTerm,(Term,Term));
X_API Term STD_PROTO(YapHeadOfTerm,(Term));
X_API Term STD_PROTO(YapTailOfTerm,(Term));
X_API Term STD_PROTO(YapMkApplTerm,(Functor,unsigned int,Term *));
X_API Functor STD_PROTO(YapFunctorOfTerm,(Term));
X_API Term STD_PROTO(YapArgOfTerm,(Int,Term));
X_API Functor STD_PROTO(YapMkFunctor,(Atom,Int));
X_API Atom STD_PROTO(YapNameOfFunctor,(Functor));
X_API Int STD_PROTO(YapArityOfFunctor,(Functor));
X_API void *STD_PROTO(YapExtraSpace,(void));
X_API Int STD_PROTO(Yapcut_fail,(void));
X_API Int STD_PROTO(Yapcut_succeed,(void));
X_API Int STD_PROTO(YapUnify,(Term,Term));
X_API Int STD_PROTO(YapUnify,(Term,Term));
Int STD_PROTO(YapExecute,(CPredicate));
X_API int STD_PROTO(YapReset,(void));
X_API Int STD_PROTO(YapInit,(yap_init_args *));
X_API Int STD_PROTO(YapFastInit,(char *));
X_API Int STD_PROTO(YapCallProlog,(Term));
X_API void *STD_PROTO(YapAllocSpaceFromYap,(unsigned int));
X_API void STD_PROTO(YapFreeSpaceFromYap,(void *));
X_API void STD_PROTO(YapFreeSpaceFromYap,(void *));
X_API int STD_PROTO(YapStringToBuffer, (Term, char *, unsigned int));
X_API void STD_PROTO(YapError,(char *));
X_API int STD_PROTO(YapRunGoal,(Term));
X_API int STD_PROTO(YapRestartGoal,(void));
X_API int STD_PROTO(YapContinueGoal,(void));
X_API void STD_PROTO(YapInitConsult,(int, char *));
X_API void STD_PROTO(YapEndConsult,(void));
X_API Term STD_PROTO(YapRead, (int (*)(void)));
X_API void STD_PROTO(YapWrite, (Term, void (*)(int), int));
X_API char *STD_PROTO(YapCompileClause, (Term));
X_API void STD_PROTO(YapPutValue, (Atom,Term));
X_API Term STD_PROTO(YapGetValue, (Atom));
X_API int STD_PROTO(YapReset, (void));
X_API void STD_PROTO(YapExit, (int));
X_API void STD_PROTO(YapInitSocks, (char *, long));
X_API void STD_PROTO(YapSetOutputMessage, (void));
X_API Term
YapA(int i)
{
return(Deref(XREGS[i]));
}
X_API Bool
YapIsIntTerm(Term t)
{
return (IsIntTerm(t) || IsLongIntTerm(t));
}
X_API Bool
YapIsVarTerm(Term t)
{
return (IsVarTerm(t));
}
X_API Bool
YapIsNonVarTerm(Term t)
{
return (IsNonVarTerm(t));
}
X_API Bool
YapIsFloatTerm(Term t)
{
return (IsFloatTerm(t));
}
X_API Bool
YapIsDbRefTerm(Term t)
{
return (IsDBRefTerm(t));
}
X_API Bool
YapIsAtomTerm(Term t)
{
return (IsAtomTerm(t));
}
X_API Bool
YapIsPairTerm(Term t)
{
return (IsPairTerm(t));
}
X_API Bool
YapIsApplTerm(Term t)
{
return (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t)));
}
X_API Term
YapMkIntTerm(Int n)
{
Term I;
BACKUP_H();
I = MkIntegerTerm(n);
RECOVER_H();
return(I);
}
X_API Int
YapIntOfTerm(Term t)
{
if (!IsApplTerm(t))
return (IntOfTerm(t));
else
return(LongIntOfTerm(t));
}
X_API Term
YapMkFloatTerm(double n)
{
Term t;
BACKUP_H();
t = MkFloatTerm(n);
RECOVER_H();
return(t);
}
X_API flt
YapFloatOfTerm(Term t)
{
return (FloatOfTerm(t));
}
X_API Term
YapMkAtomTerm(Atom n)
{
Term t;
t = MkAtomTerm(n);
return(t);
}
X_API Atom
YapAtomOfTerm(Term t)
{
return (AtomOfTerm(t));
}
X_API char *
YapAtomName(Atom a)
{
char *o;
o = AtomName(a);
return(o);
}
X_API Atom
YapLookupAtom(char *c)
{
return(LookupAtom(c));
}
X_API Atom
YapFullLookupAtom(char *c)
{
Atom at;
at = FullLookupAtom(c);
return(at);
}
X_API Term
YapMkVarTerm(void)
{
CELL t;
BACKUP_H();
t = MkVarTerm();
RECOVER_H();
return(t);
}
X_API Term
YapMkPairTerm(Term t1, Term t2)
{
Term t;
BACKUP_H();
t = MkPairTerm(t1, t2);
RECOVER_H();
return(t);
}
X_API Term
YapHeadOfTerm(Term t)
{
return (HeadOfTerm(t));
}
X_API Term
YapTailOfTerm(Term t)
{
return (TailOfTerm(t));
}
X_API Term
YapMkApplTerm(Functor f,unsigned int arity, Term args[])
{
Term t;
BACKUP_H();
t = MkApplTerm(f, arity, args);
RECOVER_H();
return(t);
}
X_API Functor
YapFunctorOfTerm(Term t)
{
return (FunctorOfTerm(t));
}
X_API Term
YapArgOfTerm(Int n, Term t)
{
return (ArgOfTerm(n, t));
}
X_API Functor
YapMkFunctor(Atom a, Int n)
{
return (MkFunctor(a, n));
}
X_API Atom
YapNameOfFunctor(Functor f)
{
return (NameOfFunctor(f));
}
X_API Int
YapArityOfFunctor(Functor f)
{
return (ArityOfFunctor(f));
}
X_API void *
YapExtraSpace(void)
{
void *ptr;
BACKUP_B();
/* find a pointer to extra space allocable */
ptr = (void *)((CELL *)(B+1)+P->u.lds.s);
RECOVER_B();
return(ptr);
}
X_API Int
Yapcut_fail(void)
{
BACKUP_B();
B = B->cp_b; /* cut_fail */
RECOVER_B();
return(FALSE);
}
X_API Int
Yapcut_succeed(void)
{
BACKUP_B();
B = B->cp_b;
RECOVER_B();
return(TRUE);
}
X_API Int
YapUnify(Term pt1, Term pt2)
{
Int out;
BACKUP_MACHINE_REGS();
out = unify(pt1, pt2);
RECOVER_MACHINE_REGS();
return(out);
}
Int YapExecute(CPredicate code)
{
return((code)());
}
X_API Int YapCallProlog(Term t)
{
Int out;
BACKUP_MACHINE_REGS();
out = execute_goal(t,0);
RECOVER_MACHINE_REGS();
return(out);
}
X_API void *YapAllocSpaceFromYap(unsigned int size)
{
void *ptr;
BACKUP_MACHINE_REGS();
if ((ptr = AllocCodeSpace(size)) == NULL) {
if (!growheap(FALSE)) {
Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
return(NULL);
}
}
RECOVER_MACHINE_REGS();
return(ptr);
}
X_API void YapFreeSpaceFromYap(void *ptr)
{
FreeCodeSpace(ptr);
}
/* copy a string to a buffer */
X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize)
{
unsigned int j = 0;
while (t != TermNil) {
register Term Head;
register Int i;
Head = HeadOfTerm(t);
if (IsVarTerm(Head)) {
Error(INSTANTIATION_ERROR,Head,"user defined procedure");
return(FALSE);
} else if (!IsIntTerm(Head)) {
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"user defined procedure");
return(FALSE);
}
i = IntOfTerm(Head);
if (i < 0 || i > 255) {
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"user defined procedure");
return(FALSE);
}
buf[j++] = i;
if (j > bufsize) return(FALSE);
t = TailOfTerm(t);
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR,t,"user defined procedure");
return(FALSE);
} else if (!IsPairTerm(t) && t != TermNil) {
Error(TYPE_ERROR_LIST, t, "user defined procedure");
return(FALSE);
}
}
buf[j] = '\0';
return(TRUE);
}
X_API void
YapError(char *buf)
{
Error(SYSTEM_ERROR,TermNil,buf);
}
X_API int
YapRunGoal(Term t)
{
int out;
BACKUP_MACHINE_REGS();
InitYaamRegs();
out = RunTopGoal(t);
RECOVER_MACHINE_REGS();
return(out);
}
X_API int
YapRestartGoal(void)
{
int out;
BACKUP_MACHINE_REGS();
P = (yamop *)FAILCODE;
out = exec_absmi(TRUE);
RECOVER_MACHINE_REGS();
return(out);
}
X_API int
YapContinueGoal(void)
{
int out;
BACKUP_MACHINE_REGS();
out = exec_absmi(TRUE);
RECOVER_MACHINE_REGS();
return(out);
}
X_API void
YapInitConsult(int mode, char *filename)
{
BACKUP_MACHINE_REGS();
if (mode == YAP_CONSULT_MODE)
init_consult(FALSE, filename);
else
init_consult(TRUE, filename);
RECOVER_MACHINE_REGS();
}
X_API void
YapEndConsult(void)
{
BACKUP_MACHINE_REGS();
end_consult();
RECOVER_MACHINE_REGS();
}
static int (*do_getf)(void);
static int do_yap_getc(int streamno) {
return(do_getf());
}
X_API Term
YapRead(int (*mygetc)(void))
{
Term t;
tr_fr_ptr old_TR;
BACKUP_MACHINE_REGS();
do_getf = mygetc;
old_TR = TR;
tokptr = toktide = tokenizer(do_yap_getc, do_yap_getc);
if (ErrorMessage)
{
TR = old_TR;
save_machine_regs();
return(0);
}
t = Parse();
TR = old_TR;
RECOVER_MACHINE_REGS();
return(t);
}
static void (*do_putcf)(int);
static int do_yap_putc(int streamno,int ch) {
do_putcf(ch);
return(ch);
}
X_API void
YapWrite(Term t, void (*myputc)(int), int flags)
{
BACKUP_MACHINE_REGS();
do_putcf = myputc;
plwrite (t, do_yap_putc, flags);
RECOVER_MACHINE_REGS();
}
X_API char *
YapCompileClause(Term t)
{
char *ErrorMessage;
CODEADDR codeaddr;
BACKUP_MACHINE_REGS();
ErrorMessage = NULL;
ARG1 = t;
codeaddr = cclause (t,0);
if (codeaddr != NULL) {
t = Deref(ARG1); /* just in case there was an heap overflow */
addclause (t, codeaddr, TRUE);
}
RECOVER_MACHINE_REGS();
return(ErrorMessage);
}
/* this routine is supposed to be called from an external program
that wants to control Yap */
X_API Int
YapInit(yap_init_args *yap_init)
{
int restore_result;
int Trail = 0, Stack = 0, Heap = 0;
BACKUP_MACHINE_REGS();
yap_args = yap_init->Argv;
yap_argc = yap_init->Argc;
if (yap_init->SavedState != NULL) {
if (SavedInfo (yap_init->SavedState, &Trail, &Stack, &Heap, yap_init->YapLibDir) != 1) {
return(YAP_BOOT_FROM_SAVED_ERROR);
}
}
if (yap_init->TrailSize == 0) {
if (Trail == 0)
Trail = DefTrailSpace;
} else {
Trail = yap_init->TrailSize;
}
if (yap_init->StackSize == 0) {
if (Stack == 0)
Stack = DefStackSpace;
} else {
Stack = yap_init->StackSize;
}
if (yap_init->HeapSize == 0) {
if (Heap == 0)
Heap = DefHeapSpace;
} else {
Heap = yap_init->HeapSize;
}
InitStacks (Heap, Stack, Trail,
yap_init->NumberWorkers,
yap_init->SchedulerLoop,
yap_init->DelayedReleaseLoad
);
InitYaamRegs();
if (yap_init->YapPrologBootFile != NULL) {
/*
This must be done before restore, otherwise
restore will print out messages ....
*/
yap_flags[HALT_AFTER_CONSULT_FLAG] = yap_init->HaltAfterConsult;
}
if (yap_init->SavedState != NULL) {
restore_result = Restore(yap_init->SavedState);
} else {
restore_result = FAIL_RESTORE;
}
#if defined(YAPOR) || defined(TABLING)
make_root_frames();
#ifdef YAPOR
init_workers();
#endif /* YAPOR */
init_local();
#ifdef YAPOR
if (worker_id != 0) {
#if SBA
/*
In the SBA we cannot just happily inherit registers
from the other workers
*/
InitYaamRegs();
#endif
/* slaves, waiting for work */
CurrentModule = 1;
P = GETWORK_FIRST_TIME;
exec_absmi(FALSE);
abort_optyap("abstract machine unexpected exit");
}
#endif /* YAPOR */
#endif /* YAPOR || TABLING */
RECOVER_MACHINE_REGS();
if (yap_init->YapPrologBootFile != NULL) {
PutValue(FullLookupAtom("$consult_on_boot"), MkAtomTerm(LookupAtom(yap_init->YapPrologBootFile)));
/*
This must be done again after restore, as yap_flags
has been overwritten ....
*/
yap_flags[HALT_AFTER_CONSULT_FLAG] = yap_init->HaltAfterConsult;
}
if (yap_init->SavedState != NULL) {
if (restore_result == FAIL_RESTORE)
return(YAP_BOOT_FROM_SAVED_ERROR);
if (restore_result == DO_ONLY_CODE) {
return(YAP_BOOT_FROM_SAVED_CODE);
} else {
return(YAP_BOOT_FROM_SAVED_STACKS);
}
}
return(YAP_BOOT_FROM_PROLOG);
}
X_API Int
YapFastInit(char saved_state[])
{
yap_init_args init_args;
init_args.SavedState = saved_state;
init_args.HeapSize = 0;
init_args.StackSize = 0;
init_args.TrailSize = 0;
init_args.YapLibDir = NULL;
init_args.YapPrologBootFile = NULL;
init_args.HaltAfterConsult = FALSE;
init_args.NumberWorkers = 1;
init_args.SchedulerLoop = 10;
init_args.DelayedReleaseLoad = 3;
init_args.Argc = 0;
init_args.Argv = NULL;
return(YapInit(&init_args));
}
X_API void
YapPutValue(Atom at, Term t)
{
PutValue(at, t);
}
X_API Term
YapGetValue(Atom at)
{
return(GetValue(at));
}
X_API int
YapReset(void)
{
BACKUP_MACHINE_REGS();
/* first, backtrack to the root */
if (B != NULL) {
while (B->cp_b != NULL)
B = B->cp_b;
P = (yamop *)FAILCODE;
if (exec_absmi(0) != 0)
return(FALSE);
}
/* reinitialise the engine */
InitYaamRegs();
RECOVER_MACHINE_REGS();
return(TRUE);
}
X_API void
YapExit(int retval)
{
exit_yap(retval, NULL);
}
X_API void
YapInitSocks(char *host, long port)
{
#if USE_SOCKET
init_socks(host, port);
#endif
}
X_API void
YapSetOutputMessage(void)
{
#if DEBUG
output_msg = TRUE;
#endif
}

2191
C/cdmgr.c Normal file
View File

File diff suppressed because it is too large Load Diff

1142
C/cmppreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

2624
C/compiler.c Normal file
View File

File diff suppressed because it is too large Load Diff

652
C/computils.c Normal file
View File

@@ -0,0 +1,652 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: computils.c *
* Last rev: *
* mods: *
* comments: some useful routines for YAP's compiler *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This file includes a set of utilities, useful to the several compilation
* modules
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "compile.h"
#include "yapio.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#ifdef DEBUG
STATIC_PROTO (void ShowOp, (char *));
#endif /* DEBUG */
/*
* The compiler creates an instruction chain which will be assembled after
* afterwards
*/
char *freep, *freep0;
Int arg, rn;
compiler_vm_op ic;
CELL *cptr;
char *
AllocCMem (int size)
{
char *p;
p = freep;
#if SIZEOF_INT_P==8
size = (size + 7) & 0xfffffffffffffff8L;
#else
size = (size + 3) & 0xfffffffcL;
#endif
freep += size;
if (ASP <= CellPtr (freep) + 256) {
save_machine_regs();
longjmp(CompilerBotch,3);
}
return (p);
}
int
is_a_test_pred (Term arg)
{
Atom At;
int arity;
if (IsVarTerm (arg))
return (FALSE);
else if (IsAtomTerm (arg))
{
At = AtomOfTerm (arg);
arity = 0;
}
else if (IsApplTerm (arg))
{
Functor f = FunctorOfTerm (arg);
At = NameOfFunctor (f);
arity = ArityOfFunctor (f);
}
else
return (FALSE);
if (RepPredProp (PredProp (At, arity)) == NULL)
return (FALSE);
return (RepPredProp (PredProp (At, arity))->PredFlags & TestPredFlag);
}
void
emit (compiler_vm_op o, Int r1, CELL r2)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p));
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->nextInst = NIL;
if (cpc == NIL)
cpc = CodeStart = p;
else
{
cpc->nextInst = p;
cpc = p;
}
}
void
emit_3ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+sizeof(CELL));
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->nextInst = NIL;
if (cpc == NIL)
cpc = CodeStart = p;
else
{
cpc->nextInst = p;
cpc = p;
}
}
CELL *
emit_extra_size (compiler_vm_op o, CELL r1, int size)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p) + size - CellSize);
p->op = o;
p->rnd1 = r1;
p->nextInst = NIL;
if (cpc == NIL)
cpc = CodeStart = p;
else
{
cpc->nextInst = p;
cpc = p;
}
return (p->arnds);
}
void
bip_name(Int op, char *s)
{
switch (op) {
case _atom:
strcpy(s,"atom");
break;
case _atomic:
strcpy(s,"atomic");
break;
case _integer:
strcpy(s,"integer");
break;
case _nonvar:
strcpy(s,"nonvar");
break;
case _number:
strcpy(s,"number");
break;
case _var:
strcpy(s,"var");
break;
case _cut_by:
strcpy(s,"cut_by");
break;
case _db_ref:
strcpy(s,"db_ref");
break;
case _compound:
strcpy(s,"compound");
break;
case _float:
strcpy(s,"float");
break;
case _primitive:
strcpy(s,"primitive");
break;
case _equal:
strcpy(s,"equal");
break;
case _dif:
strcpy(s,"dif");
break;
case _eq:
strcpy(s,"eq");
break;
case _arg:
strcpy(s,"arg");
break;
case _functor:
strcpy(s,"functor");
break;
case _plus:
strcpy(s,"plus");
break;
case _minus:
strcpy(s,"minus");
break;
case _times:
strcpy(s,"times");
break;
case _div:
strcpy(s,"div");
break;
case _and:
strcpy(s,"and");
break;
case _or:
strcpy(s,"or");
break;
case _sll:
strcpy(s,"sll");
break;
case _slr:
strcpy(s,"slr");
break;
default:
strcpy(s,"");
break;
}
}
#ifdef DEBUG
static void
ShowOp (f)
char *f;
{
char ch;
while ((ch = *f++) != 0)
{
if (ch == '%')
switch (ch = *f++)
{
case 'a':
case 'n':
plwrite ((Term) arg, DebugPutc, 0);
break;
case 'b':
/* write a variable bitmap for a call */
{
int max = arg/(8*sizeof(CELL)), i;
CELL *ptr = cptr;
for (i = 0; i <= max; i++) {
plwrite(MkIntegerTerm((Int)(*ptr++)), DebugPutc, 0);
}
}
break;
case 'l':
plwrite (MkIntTerm (arg), DebugPutc, 0);
break;
case 'B':
{
char s[32];
bip_name(rn,s);
plwrite (MkAtomTerm(LookupAtom(s)), DebugPutc, 0);
}
break;
case 'd':
plwrite (MkIntTerm (rn), DebugPutc, 0);
break;
case 'z':
plwrite (MkIntTerm (cpc->rnd3), DebugPutc, 0);
break;
case 'v':
{
Ventry *v = (Ventry *) arg;
DebugPutc (c_output_stream,v->KindOfVE == PermVar ? 'Y' : 'X');
plwrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs), DebugPutc, 0);
}
break;
case 'N':
{
Ventry *v;
cpc = cpc->nextInst;
arg = cpc->rnd1;
v = (Ventry *) arg;
DebugPutc (c_output_stream,v->KindOfVE == PermVar ? 'Y' : 'X');
plwrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs), DebugPutc, 0);
}
break;
case 'm':
plwrite (MkAtomTerm ((Atom) arg), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite (MkIntTerm (rn), DebugPutc, 0);
break;
case 'p':
{
PredEntry *p = RepPredProp ((Prop) arg);
Functor f = p->FunctorOfPred;
plwrite (ModuleName[p->ModuleOfPred], DebugPutc, 0);
DebugPutc (c_output_stream,':');
if (p->ArityOfPE == 0)
f = MkFunctor ((Atom) f, 0);
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite (MkIntTerm (ArityOfFunctor (f)), DebugPutc, 0);
}
break;
case 'P':
{
PredEntry *p = RepPredProp((Prop) rn);
Functor f = p->FunctorOfPred;
plwrite (ModuleName[p->ModuleOfPred], DebugPutc, 0);
DebugPutc (c_output_stream,':');
if (p->ArityOfPE == 0)
f = MkFunctor ((Atom) f, 0);
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite (MkIntTerm (ArityOfFunctor (f)), DebugPutc, 0);
}
break;
case 'f':
if (IsExtensionFunctor((Functor)arg)) {
if ((Functor)arg == FunctorDBRef) {
plwrite(MkAtomTerm(LookupAtom("DBRef")), DebugPutc, 0);
} else if ((Functor)arg == FunctorLongInt) {
plwrite(MkAtomTerm(LookupAtom("LongInt")), DebugPutc, 0);
} else if ((Functor)arg == FunctorDouble) {
plwrite(MkAtomTerm(LookupAtom("Double")), DebugPutc, 0);
}
} else {
plwrite(MkAtomTerm(NameOfFunctor ((Functor) arg)), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite(MkIntTerm(ArityOfFunctor ((Functor) arg)), DebugPutc, 0);
}
break;
case 'r':
DebugPutc (c_output_stream,'A');
plwrite (MkIntTerm (rn), DebugPutc, 0);
break;
case 'h':
{
CELL my_arg = *cptr++;
if (my_arg & 1)
plwrite (MkIntTerm (my_arg),
DebugPutc, 0);
else if (my_arg == (CELL) FAILCODE)
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
else
plwrite (MkIntegerTerm ((Int) my_arg),
DebugPutc, 0);
}
break;
case 'g':
if (arg & 1)
plwrite (MkIntTerm (arg),
DebugPutc, 0);
else if (arg == (CELL) FAILCODE)
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
else
plwrite (MkIntegerTerm ((Int) arg), DebugPutc, 0);
break;
case 'i':
plwrite (MkIntTerm (arg), DebugPutc, 0);
break;
case 'j':
{
Functor fun = (Functor)*cptr++;
if (IsExtensionFunctor(fun)) {
if (fun == FunctorDBRef) {
plwrite(MkAtomTerm(LookupAtom("DBRef")), DebugPutc, 0);
} else if (fun == FunctorLongInt) {
plwrite(MkAtomTerm(LookupAtom("LongInt")), DebugPutc, 0);
} else if (fun == FunctorDouble) {
plwrite(MkAtomTerm(LookupAtom("Double")), DebugPutc, 0);
}
} else {
plwrite (MkAtomTerm(NameOfFunctor(fun)), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite (MkIntTerm(ArityOfFunctor(fun)), DebugPutc, 0);
}
}
break;
case 'O':
plwrite(AbsAppl(cptr), DebugPutc, 0);
break;
case 'x':
plwrite (MkIntTerm (rn >> 1), DebugPutc, 0);
DebugPutc (c_output_stream,'\t');
plwrite (MkIntTerm (rn & 1), DebugPutc, 0);
break;
case 'o':
plwrite ((Term) * cptr++, DebugPutc, 0);
case 'c':
{
int i;
for (i = 0; i < arg; ++i)
{
CELL my_arg;
if (*cptr)
{
plwrite ((Term) * cptr++, DebugPutc, 0);
}
else
{
plwrite (MkIntTerm (0), DebugPutc, 0);
cptr++;
}
DebugPutc (c_output_stream,'\t');
my_arg = *cptr++;
if (my_arg & 1)
plwrite (MkIntTerm (my_arg),
DebugPutc, 0);
else if (my_arg == (CELL) FAILCODE)
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
else
plwrite (MkIntegerTerm ((Int) my_arg), DebugPutc, 0);
DebugPutc (c_output_stream,'\n');
}
}
break;
case 'e':
{
int i;
for (i = 0; i < arg; ++i)
{
CELL my_arg;
if (*cptr)
{
plwrite (MkAtomTerm (NameOfFunctor ((Functor) * cptr)), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite (MkIntTerm (ArityOfFunctor ((Functor) * cptr++)), DebugPutc, 0);
}
else
{
plwrite (MkIntTerm (0), DebugPutc, 0);
cptr++;
}
DebugPutc (c_output_stream,'\t');
my_arg = *cptr++;
if (my_arg & 1)
plwrite (MkIntTerm (my_arg),
DebugPutc, 0);
else if (my_arg == (CELL) FAILCODE)
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
else
plwrite (MkIntegerTerm ((Int) my_arg), DebugPutc, 0);
DebugPutc (c_output_stream,'\n');
}
}
break;
default:
DebugPutc (c_output_stream,'%');
DebugPutc (c_output_stream,ch);
}
else
DebugPutc (c_output_stream,ch);
}
DebugPutc (c_output_stream,'\n');
}
static char *opformat[] =
{
"nop",
"get_var\t\t%v,%r",
"put_var\t\t%v,%r",
"get_val\t\t%v,%r",
"put_val\t\t%v,%r",
"get_atom\t%a,%r",
"put_atom\t%a,%r",
"get_num\t\t%n,%r",
"put_num\t\t%n,%r",
"get_float\t\t%l,%r",
"put_float\t\t%l,%r",
"get_longint\t\t%l,%r",
"put_longint\t\t%l,%r",
"get_bigint\t\t%l,%r",
"put_bigint\t\t%l,%r",
"get_list\t%r",
"put_list\t%r",
"get_struct\t%f,%r",
"put_struct\t%f,%r",
"put_unsafe\t%v,%r",
"unify_var\t%v",
"write_var\t%v",
"unify_val\t%v",
"write_val\t%v",
"unify_atom\t%a",
"write_atom\t%a",
"unify_num\t%n",
"write_num\t%n",
"unify_float\t%l",
"write_float\t%l",
"unify_longint\t%l",
"write_longint\t%l",
"unify_bigint\t%l",
"write_bigint\t%l",
"unify_list",
"write_list",
"unify_struct\t%f",
"write_struct\t%f",
"write_unsafe\t%v",
"fail",
"cut",
"cutexit",
"allocate",
"deallocate",
"try_me_else\t\t%l\t%x",
"jump\t\t%l",
"procceed",
"call\t\t%p,%d,%z",
"execute\t\t%p",
"sys\t\t%p",
"%l:",
"name\t\t%m,%d",
"pop\t\t%l",
"retry_me_else\t\t%l\t%x",
"trust_me_else_fail\t%x",
"either_me\t\t%l,%d,%z",
"or_else\t\t%l,%z",
"or_last",
"push_or",
"pushpop_or",
"pop_or",
"save_by\t\t%v",
"comit_by\t\t%v",
"patch_by\t\t%v",
"try\t\t%g\t%x",
"retry\t\t%g\t%x",
"trust\t\t%g\t%x",
"try_in\t\t%g\t%x",
"retry_in\t\t%g\t%x",
"trust_in\t\t%g\t%x",
"try_first\t\t%g\t%x",
"retry_first\t\t%g\t%x",
"trust_first\t\t%g\t%x",
"try_first in\t\t%g\t%x",
"retry_first in\t\t%g\t%x",
"trust_first in\t\t%g\t%x",
"try_tail\t\t%g\t%x",
"retry_tail\t\t%g\t%x",
"trust_tail\t\t%g\t%x",
"try_tail_in\t\t%g\t%x",
"retry_tail_in\t\t%g\t%x",
"trust_tail_in\t\t%g\t%x",
"try_head\t\t%g\t%x",
"retry_head\t\t%g\t%x",
"trust_head\t\t%g\t%x",
"try_head_in\t\t%g\t%x",
"retry_head_in\t\t%g\t%x",
"trust_head_in\t\t%g\t%x",
"try_last_first\t\t%g\t%x",
"try_last_head\t\t%g\t%x",
"jump_if_var\t\t%g",
"switch_on_type\t%h\t%h\t%h\t%h",
"switch_on_type_if_nonvar\t%h\t%h\t%h",
"switch_on_type_of_last\t%h\t%h\t%h",
"switch_on_type_of_head\t%h\t%h\t%h\t%h",
"switch_on_list_or_nil\t%h\t%h\t%h\t%h",
"switch_if_list_or_nil\t%h\t%h\t%h",
"switch_on_last_list_or_nil\t%h\t%h\t%h",
"switch_on_constant\t%i\n%c",
"if_a_constant\t%i\t%h\n%c",
"go_if_ equals_constant\t%o\t%h\t%h",
"switch_on_functor\t%i\n%e",
"if_a_functor\t%i\t%h\n%e",
"go_if_equals_functor\t%j\t%h\t%h",
"if_not_then\t%i\t%h\t%h\t%h",
"save_pair\t%v",
"save_appl\t%v",
"fail_label\t%l",
"unify_local\t%v",
"write local\t%v",
"unify_last_list",
"write_last_list",
"unify_last_struct\t%f",
"write_last_struct\t%f",
"unify_last_var\t%v",
"unify_last_val\t%v",
"unify_last_local\t%v",
"unify_last_atom\t%a",
"unify_last_num\t%n",
"unify_last_float\t%l",
"unify_last_longint\t%l",
"unify_last_bigint\t%l",
"pvar_bitmap\t%l,%b",
"pvar_live_regs\t%l,%b",
"fetch_reg1_reg2\t%N,%N",
"fetch_constant_reg\t%l,%N",
"fetch_reg_constant\t%l,%N",
"function_to_var\t%v,%B",
"function_to_al\t%v,%B",
"enter_profiling\t\t%g",
"retry_profiled\t\t%g",
"restore_temps\t\t%l",
"restore_temps_and_skip\t\t%l",
"empty_call\t\t%l,%d",
#ifdef TABLING
"table_new_answer",
#endif /* TABLING */
#ifdef YAPOR
"sync",
#endif /* YAPOR */
"fetch_args_for_bccall\t%v",
"binary_cfunc\t\t%v,%P",
"blob\t%O"
#ifdef SFUNC
,
"get_s_f_op\t%f,%r",
"put_s_f_op\t%f,%r",
"unify_s_f_op\t%f",
"write_s_f_op\t%f",
"unify_s_var\t%v,%r",
"write_s_var\t%v,%r",
"unify_s_val\t%v,%r",
"write_s_val\t%v,%r",
"unify_s_a\t%a,%r",
"write_s_a\t%a,%r",
"get_s_end",
"put_s_end",
"unify_s_end",
"write_s_end"
#endif
};
void
ShowCode ()
{
CELL *OldH = H;
cpc = CodeStart;
/* MkIntTerm and friends may build terms in the global stack */
H = (CELL *)freep;
while (cpc)
{
ic = cpc->op;
arg = cpc->rnd1;
rn = cpc->rnd2;
cptr = cpc->arnds;
if (ic != nop_op)
ShowOp (opformat[ic]);
cpc = cpc->nextInst;
}
DebugPutc (c_output_stream,'\n');
H = OldH;
}
#endif /* DEBUG */

1176
C/corout.c Normal file
View File

File diff suppressed because it is too large Load Diff

4207
C/dbase.c Normal file
View File

File diff suppressed because it is too large Load Diff

60
C/depth_bound.c Normal file
View File

@@ -0,0 +1,60 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: it_deep.c *
* Last rev: *
* mods: *
* comments: Support for Iterative Deepening *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif /* SCCS */
#include "Yap.h"
#ifdef DEPTH_LIMIT
#include "Yatom.h"
STD_PROTO(static Int p_get_depth_limit, (void));
STD_PROTO(static Int p_set_depth_limit, (void));
static Int p_get_depth_limit(void)
{
return(unify_constant(ARG1, MkIntTerm(IntOfTerm(DEPTH/2))));
}
static Int p_set_depth_limit(void)
{
Term d = Deref(ARG1);
if (IsVarTerm(d)) {
Error(INSTANTIATION_ERROR, d, "set-depth_limit");
return(FALSE);
} else if (!IsIntegerTerm(d)) {
Error(TYPE_ERROR_INTEGER, d, "set-depth_limit");
return(FALSE);
}
d = MkIntTerm(IntegerOfTerm(d)*2);
YENV[E_DEPTH] = d;
DEPTH = d;
return(TRUE);
}
void InitItDeepenPreds(void)
{
InitCPred("get_depth_limit", 1, p_get_depth_limit, SafePredFlag);
InitCPred("$set_depth_limit", 1, p_set_depth_limit, 0);
}
#endif

1814
C/errors.c Normal file
View File

File diff suppressed because it is too large Load Diff

145
C/eval.c Normal file
View File

@@ -0,0 +1,145 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: eval.c *
* Last rev: *
* mods: *
* comments: arithmetical expression evaluation *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This file implements arithmetic operations
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "eval.h"
yap_error_number YAP_matherror = NO_ERROR;
#define E_FUNC blob_type
#define E_ARGS arith_retptr o
#define USE_E_ARGS o
#define RBIG(v) (o)->big = v; return(big_int_e)
#define RINT(v) (o)->Int = v; return(long_int_e)
#define RFLOAT(v) (o)->dbl = v; return(double_e)
#define RERROR() return(db_ref_e)
static Term
EvalToTerm(blob_type bt, union arith_ret *res)
{
switch (bt) {
case long_int_e:
return(MkIntegerTerm(res->Int));
case double_e:
return(MkFloatTerm(res->dbl));
#ifdef USE_GMP
case big_int_e:
return(MkBigIntTerm(res->big));
#endif
default:
return(TermNil);
}
}
E_FUNC
Eval(Term t, E_ARGS)
{
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR,TermNil,"in arithmetic");
P = (yamop *)FAILCODE;
RERROR();
}
if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
switch ((CELL)fun) {
case (CELL)FunctorLongInt:
RINT(LongIntOfTerm(t));
case (CELL)FunctorDouble:
RFLOAT(FloatOfTerm(t));
#ifdef USE_GMP
case (CELL)FunctorBigInt:
RBIG(BigIntOfTerm(t));
#endif
default:
{
Int n = ArityOfFunctor(fun);
Atom name = NameOfFunctor(fun);
ExpEntry *p;
if (EndOfPAEntr(p = RepExpProp(GetExpProp(name, n)))) {
Term ti[2];
/* error */
ti[0] = t;
ti[1] = MkIntegerTerm(n);
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
Error(TYPE_ERROR_EVALUABLE, t,
"functor %s/%d for arithmetic expression",
RepAtom(name)->StrOfAE,n);
P = (yamop *)FAILCODE;
RERROR();
}
if (n == 1)
return(p->FOfEE.unary(ArgOfTerm(1,t), USE_E_ARGS));
return(p->FOfEE.binary(ArgOfTerm(1,t),ArgOfTerm(2,t), USE_E_ARGS));
}
}
} else if (IsPairTerm(t)) {
return(Eval(HeadOfTerm(t), USE_E_ARGS));
} else if (IsIntTerm(t)) {
RINT(IntOfTerm(t));
} else {
Atom name = AtomOfTerm(t);
ExpEntry *p;
if (EndOfPAEntr(p = RepExpProp(GetExpProp(name, 0)))) {
Term ti[2];
/* error */
ti[0] = t;
ti[1] = MkIntTerm(0);
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
Error(TYPE_ERROR_EVALUABLE, t,
"functor %s/%d for arithmetic expression",
RepAtom(name)->StrOfAE,0);
P = (yamop *)FAILCODE;
RERROR();
}
return(p->FOfEE.constant(USE_E_ARGS));
}
}
static Int
p_is(void)
{ /* X is Y */
union arith_ret res;
blob_type bt;
bt = Eval(Deref(ARG2), &res);
return (unify_constant(ARG1,EvalToTerm(bt,&res)));
}
void
InitEval(void)
{
/* here are the arithmetical predicates */
InitConstExps();
InitUnaryExps();
InitBinaryExps();
InitCPred("is", 2, p_is, TestPredFlag | SafePredFlag);
}

233
C/evalis.c Normal file
View File

@@ -0,0 +1,233 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: evalis.c *
* Last rev: *
* mods: *
* comments: is/3 predicate *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif /* SCCS */
/*
* This predicates had to be developed here because of a bug in the MPW
* compiler, which was not able to compile the original eval.c
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "eval.h"
int
UnEvalInt(BITS16 op, Int i1)
{
switch(op) {
case e_uminus:
REvalInt(-i1);
case e_abs:
#if SHORT_INTS
#if HAVE_LABS
REvalInt((Int)labs((long int)i1));
#else
REvalInt((i1 >= 0 ? i1 : -i1));
#endif
#else
REvalInt(abs(i1));
#endif
case e_msb:
REvalInt(msb(i1));
case e_uplus:
REvalInt(i1);
case e_not:
REvalInt(~i1);
case e_exp:
REvalFl(exp(FL(i1)));
case e_log:
REvalFl(log(FL(i1)));
case e_log10:
REvalFl(log10(FL(i1)));
case e_sqrt:
REvalFl(sqrt(FL(i1)));
case e_sin:
REvalFl(sin(FL(i1)));
case e_cos:
REvalFl(cos(FL(i1)));
case e_tan:
REvalFl(tan(FL(i1)));
case e_sinh:
REvalFl(sinh(FL(i1)));
case e_cosh:
REvalFl(cosh(FL(i1)));
case e_tanh:
REvalFl(tanh(FL(i1)));
case e_asin:
REvalFl(asin(FL(i1)));
case e_acos:
REvalFl(acos(FL(i1)));
case e_atan:
REvalFl(atan(FL(i1)));
case e_asinh:
REvalFl(asinh(FL(i1)));
case e_acosh:
REvalFl(acosh(FL(i1)));
case e_atanh:
REvalFl(atanh(FL(i1)));
case e_floor:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "floor/1");
P = (yamop *)FAILCODE;
REvalError();
} else {
REvalFl(FL(i1));
}
case e_round:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "round/1");
P = (yamop *)FAILCODE;
REvalError();
} else {
REvalFl(FL(i1));
}
case e_ceiling:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "floor/1");
P = (yamop *)FAILCODE;
REvalError();
} else {
REvalFl(FL(i1));
}
case e_truncate:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "truncate/1");
P = (yamop *)FAILCODE;
REvalError();
} else {
REvalFl(FL(i1));
}
case e_integer:
REvalInt(i1);
case e_float:
REvalFl(FL(i1));
case e_fmodf:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
Error(TYPE_ERROR_FLOAT,MkIntegerTerm(i1),"mod/2");
P = (yamop *)FAILCODE;
REvalError();
} else {
REvalFl(FL(0.0));
}
case e_imodf:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
/* iso does not allow integer arguments to this procedure */
Error(TYPE_ERROR_FLOAT,MkIntegerTerm(i1),"mod/2");
P = (yamop *)FAILCODE;
REvalError();
} else {
REvalFl(FL(i1));
}
case e_sign:
if (i1 < 0) {
REvalInt(-1);
} else if (i1 == 0) {
REvalInt(0);
} else {
REvalInt(1);
}
default:
{
Term t, ti[2];
ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(current_eval_term)));
ti[1] = MkIntegerTerm(1);
t = MkApplTerm(MkFunctor(LookupAtom("/"),1), 1, ti);
Error(TYPE_ERROR_EVALUABLE, t,
"arithmetic expression %s/%d",
RepAtom(NameOfFunctor(FunctorOfTerm(current_eval_term)))->StrOfAE,
2
);
P = (yamop *)FAILCODE;
REvalError();
}
}
}
Int
p_unary_is(void)
{
register BITS16 OpNum;
Term t2, t3;
int flag;
current_eval_term = MkIntTerm(1);
t2 = Deref(ARG2);
if (IsVarTerm(t2)) {
Error(INSTANTIATION_ERROR, t2, "operation for is/3");
P = (yamop *)FAILCODE;
return(FALSE);
}
if (IsAtomTerm(t2)) {
Atom name;
Prop p;
name = AtomOfTerm(t2);
if ((p = GetExpProp(name, 1)) == NIL) {
Term t, ti[2];
ti[0] = MkAtomTerm(name);
ti[1] = MkIntegerTerm(1);
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
Error(TYPE_ERROR_EVALUABLE, t,
"arithmetic expression %s/%d",
RepAtom(name)->StrOfAE,
1
);
P = (yamop *)FAILCODE;
return(FALSE);
}
OpNum = RepExpProp(p)->ENoOfEE;
} else if (IsIntTerm(t2))
OpNum = IntOfTerm(t2);
else
return (FALSE);
t3 = Deref(ARG3);
if (IsVarTerm(t3)) {
int op = 0;
while (InitTab[op].eno != OpNum) op++;
Error(INSTANTIATION_ERROR, t3, "arithmetic expression %s/1", InitTab[op].OpName);
P = (yamop *)FAILCODE;
return(FALSE);
}
if (IsIntegerTerm(t3)) {
flag = UnEvalInt(OpNum, IntegerOfTerm(t3));
} else if (IsFloatTerm(t3)) {
flag = UnEvalFl(OpNum, FloatOfTerm(t3));
} else {
int aflag = Eval(t3);
if (aflag == FError) {
return(FALSE);
} else if (aflag == FInt) {
flag = UnEvalInt(OpNum, eval_int);
} else {
flag = UnEvalFl(OpNum, eval_flt);
}
}
if (flag == FError) {
return(FALSE);
} else if (flag == FInt) {
return(unify_constant(ARG1,MkIntegerTerm(eval_int)));
} else {
return(unify_constant(ARG1,MkFloatTerm(eval_flt)));
}
}

301
C/evaltwo.c Normal file
View File

@@ -0,0 +1,301 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: evaltwo.c *
* Last rev: *
* mods: *
* comments: is/4 predicate *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This predicates had to be developed here because of a bug in the MPW
* compiler, which was not able to compile the original eval.c
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "eval.h"
#define IntRes(X) return(unify_constant(ARG1,MkIntegerTerm(X)))
#define FloatRes(X) return(unify_constant(ARG1,MkEvalFl(X)))
int
BinEvalInt(BITS16 op, Int i1, Int i2)
{
switch(op) {
case e_plus:
REvalInt(i1 + i2);
case e_dif:
REvalInt(i1 - i2);
case e_times:
REvalInt(i1 * i2);
case e_div:
#ifdef TRY_TO_CONVERT_FLOATS_TO_INTS
if (i1 % i2 == 0)
REvalInt(i1 / i2);
#endif
REvalFl(FL(i1) / FL(i2));
case e_and:
REvalInt(i1 & i2);
case e_xor:
REvalInt(i1 ^ i2);
case e_or:
REvalInt(i1 | i2);
case e_lshift:
REvalInt(i1 << i2);
case e_rshift:
REvalInt(i1 >> i2);
case e_mod:
REvalInt(i1 % i2);
case e_idiv:
REvalInt(i1 / i2);
case e_gcd:
REvalInt(gcd(abs(i1),abs(i2)));
case e_gcdmult:
{
Int i;
REvalInt(gcdmult(abs(i1),abs(i2), &i));
}
case e_min:
REvalInt((i1 < i2 ? i1 : i2));
case e_max:
REvalInt((i1 > i2 ? i1 : i2));
case e_power:
REvalFl(pow(FL(i1), FL(i2)));
case e_atan2:
REvalFl(atan2(FL(i1), FL(i2)));
default:
{
Term t, ti[2];
ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(current_eval_term)));
ti[1] = MkIntegerTerm(2);
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
Error(TYPE_ERROR_EVALUABLE, t,
"in arithmetic expression %s(%d,%d)",
RepAtom(NameOfFunctor(FunctorOfTerm(current_eval_term)))->StrOfAE,
i1,
i2
);
P = (yamop *)FAILCODE;
REvalError();
}
}
}
int
BinEvalFl(BITS16 op, Float f1, Float f2, int flts)
{
switch(op) {
case e_plus:
REvalFl(f1 + f2);
case e_dif:
REvalFl(f1 - f2);
case e_times:
REvalFl(f1 * f2);
case e_div:
REvalFl(f1 / f2);
case e_power:
REvalFl(pow(f1, f2));
case e_atan2:
REvalFl(atan2(f1, f2));
case e_min:
REvalFl((f1 < f2 ? f1 : f2));
case e_max:
REvalFl((f1 > f2 ? f1 : f2));
case e_lshift:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "<</2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "<</2");
P = (yamop *)FAILCODE;
REvalError();
case e_rshift:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), ">>/2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), ">>/2");
P = (yamop *)FAILCODE;
REvalError();
case e_and:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "/\\/2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "/\\/2");
P = (yamop *)FAILCODE;
REvalError();
case e_xor:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "#/2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "#/2");
P = (yamop *)FAILCODE;
REvalError();
case e_or:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "\\/ /2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "\\/ /2");
P = (yamop *)FAILCODE;
REvalError();
case e_mod:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "mod/2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "mod/2");
P = (yamop *)FAILCODE;
REvalError();
case e_idiv:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "/ /2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "/ /2");
P = (yamop *)FAILCODE;
REvalError();
case e_gcd:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "gcd/2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "gcd/2");
P = (yamop *)FAILCODE;
REvalError();
case e_gcdmult:
if (flts & 1)
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "gcdmult/2");
else
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "gcdmult/2");
P = (yamop *)FAILCODE;
REvalError();
default:
{
Term t, ti[2];
ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(current_eval_term)));
ti[1] = MkIntegerTerm(2);
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
Error(TYPE_ERROR_EVALUABLE, t,
"in arithmetic expression %s(%d,%d)",
RepAtom(NameOfFunctor(FunctorOfTerm(current_eval_term)))->StrOfAE,
f1,
f2
);
P = (yamop *)FAILCODE;
}
REvalError();
}
}
Int
p_binary_is(void)
{
register BITS16 OpNum;
Term t2,t3,t4;
Int i1;
Float f1;
int flag;
current_eval_term = MkIntTerm(2);
t2 = Deref(ARG2);
if (IsVarTerm(t2)) {
Error(INSTANTIATION_ERROR, t2, "operation for is/4");
P = (yamop *)FAILCODE;
return(FALSE);
}
if (IsIntTerm(t2))
OpNum = IntOfTerm(t2);
else if (IsAtomTerm(t2)) {
Atom name = AtomOfTerm(t2);
Prop p;
if ((p = GetExpProp(name, 2)) == NIL) {
Term t, ti[2];
ti[0] = MkIntegerTerm(2);
ti[0] = MkAtomTerm(name);
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
Error(TYPE_ERROR_EVALUABLE, t,
"arithmetic expression %s/%d",
RepAtom(name)->StrOfAE,
2
);
P = (yamop *)FAILCODE;
return(FALSE);
}
OpNum = RepExpProp(p)->ENoOfEE;
} else
return (FALSE);
t3 = Deref(ARG3);
t4 = Deref(ARG4);
if (IsVarTerm(t3) || IsVarTerm(t4)) {
int op = 0;
while (InitTab[op].eno != OpNum) op++;
Error(INSTANTIATION_ERROR, (IsVarTerm(t3) ? t3 : t4),
"arithmetic expression %s/2", InitTab[op].OpName);
return(FALSE);
}
if (IsIntegerTerm(t3)) {
i1 = IntegerOfTerm(t3);
t3_int:
if (IsIntegerTerm(t4)) {
flag = BinEvalInt(OpNum, i1, IntegerOfTerm(t4));
} else if (IsFloatTerm(t4)) {
flag = BinEvalFl(OpNum, FL(i1), FloatOfTerm(t4), 2);
} else {
int aflag = Eval(t4);
if (aflag == FError) {
return(FALSE);
} else if (aflag == FInt) {
flag = BinEvalInt(OpNum, i1, eval_int);
} else {
flag = BinEvalFl(OpNum, FL(i1), eval_flt, 2);
}
}
} else if (IsFloatTerm(t3)) {
f1 = FloatOfTerm(t3);
t3_flt:
if (IsIntegerTerm(t4)) {
flag = BinEvalFl(OpNum, f1, FL(IntegerOfTerm(t4)), 1);
} else if (IsFloatTerm(t4)) {
flag = BinEvalFl(OpNum, f1, FloatOfTerm(t4), 3);
} else {
int aflag = Eval(t4);
if (aflag == FError) {
return(FALSE);
} else if (aflag == FInt) {
flag = BinEvalFl(OpNum, f1, eval_int, 1);
} else {
flag = BinEvalFl(OpNum, f1, eval_flt, 3);
}
}
} else {
int aflag = Eval(t3);
if (aflag == FError) {
return(FALSE);
} else if (aflag == FInt) {
i1 = eval_int;
goto t3_int;
} else {
f1 = eval_flt;
goto t3_flt;
}
}
if (flag == FError) {
return(FALSE);
} else if (flag == FInt) {
return(unify_constant(ARG1,MkIntegerTerm(eval_int)));
} else {
return(unify_constant(ARG1,MkFloatTerm(eval_flt)));
}
}

1267
C/exec.c Normal file
View File

File diff suppressed because it is too large Load Diff

949
C/grow.c Normal file
View File

@@ -0,0 +1,949 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: grow.c *
* Last rev: Thu Feb 23 1989 vv *
* mods: *
* comments: Shifting the stacks *
* *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include "alloc.h"
#include "sshift.h"
#include "compile.h"
#if HAVE_STRING_H
#include <string.h>
#endif
static int heap_overflows = 0;
static Int total_heap_overflow_time = 0;
int stack_overflows = 0;
static Int total_stack_overflow_time = 0;
int delay_overflows = 0;
static Int total_delay_overflow_time = 0;
static int trail_overflows = 0;
static Int total_trail_overflow_time = 0;
STATIC_PROTO(Int p_growheap, (void));
STATIC_PROTO(Int p_growstack, (void));
STATIC_PROTO(Int p_inform_trail_overflows, (void));
STATIC_PROTO(Int p_inform_heap_overflows, (void));
STATIC_PROTO(Int p_inform_stack_overflows, (void));
/* #define undf7 */
/* #define undf5 */
STATIC_PROTO(void MoveGlobal, (void));
STATIC_PROTO(void MoveLocalAndTrail, (void));
STATIC_PROTO(void SetHeapRegs, (void));
STATIC_PROTO(void SetStackRegs, (void));
STATIC_PROTO(void AdjustTrail, (int));
STATIC_PROTO(void AdjustLocal, (void));
STATIC_PROTO(void AdjustGlobal, (void));
STATIC_PROTO(void AdjustGrowStack, (void));
STATIC_PROTO(int local_growheap, (long,int));
STATIC_PROTO(void cpcellsd, (CELL *, CELL *, CELL));
STATIC_PROTO(CELL AdjustAppl, (CELL));
STATIC_PROTO(CELL AdjustPair, (CELL));
static void
cpcellsd(register CELL *Dest, register CELL *Org, CELL NOf)
{
#if HAVE_MEMMOVE
memmove((void *)Dest, (void *)Org, NOf*sizeof(CELL));
#else
register Int n_of = NOf;
for (; n_of >= 0; n_of--)
*--Dest = *--Org;
#endif
}
/* The old stack pointers */
CELL *OldASP, *OldLCL0;
tr_fr_ptr OldTR;
CELL *OldGlobalBase, *OldH, *OldH0;
ADDR OldTrailBase, OldTrailTop;
ADDR OldHeapBase, OldHeapTop;
Int
GDiff,
HDiff,
LDiff,
TrDiff,
XDiff,
DelayDiff;
static void
SetHeapRegs(void)
{
#ifdef undf7
YP_fprintf(YP_stderr,"HeapBase = %x\tHeapTop=%x\nGlobalBase=%x\tGlobalTop=%x\nLocalBase=%x\tLocatTop=%x\n", HeapBase, HeapTop, GlobalBase, H, LCL0, ASP);
#endif
/* The old stack pointers */
OldLCL0 = LCL0;
OldASP = ASP;
OldGlobalBase = (CELL *)GlobalBase;
OldH = H;
OldH0 = H0;
OldTrailBase = TrailBase;
OldTrailTop = TrailTop;
OldTR = TR;
OldHeapBase = HeapBase;
OldHeapTop = HeapTop;
/* Adjust stack addresses */
TrailBase = TrailAddrAdjust(TrailBase);
TrailTop = TrailAddrAdjust(TrailTop);
GlobalBase = DelayAddrAdjust(GlobalBase);
LocalBase = LocalAddrAdjust(LocalBase);
AuxSp = PtoDelayAdjust(AuxSp);
AuxTop = DelayAddrAdjust(AuxTop);
/* The registers pointing to one of the stacks */
ENV = PtoLocAdjust(ENV);
ASP = PtoLocAdjust(ASP);
H0 = PtoGloAdjust(H0);
LCL0 = PtoLocAdjust(LCL0);
H = PtoGloAdjust(H);
HB = PtoGloAdjust(HB);
B = ChoicePtrAdjust(B);
if (TopB != NULL)
TopB = ChoicePtrAdjust(TopB);
if (DelayedB != NULL)
DelayedB = ChoicePtrAdjust(DelayedB);
#ifdef TABLING
B_FZ = ChoicePtrAdjust(B_FZ);
BB = ChoicePtrAdjust(BB);
H_FZ = PtoGloAdjust(H_FZ);
TR_FZ = PtoTRAdjust(TR_FZ);
#endif
TR = PtoTRAdjust(TR);
YENV = PtoLocAdjust(YENV);
if (IsOldGlobalPtr(S))
S = PtoGloAdjust(S);
if (MyTR)
MyTR = PtoTRAdjust(MyTR);
#ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#endif
}
static void
SetStackRegs(void)
{
/* The old local stack pointers */
OldLCL0 = LCL0;
OldASP = ASP;
OldH = H;
OldH0 = H0;
OldGlobalBase = (CELL *)GlobalBase;
OldTrailTop = TrailTop;
OldTrailBase = TrailBase;
OldTR = TR;
OldHeapBase = HeapBase;
OldHeapTop = HeapTop;
/* The local and aux stack addresses */
TrailBase = TrailAddrAdjust(TrailBase);
TrailTop = TrailAddrAdjust(TrailTop);
LocalBase = LocalAddrAdjust(LocalBase);
TR = PtoTRAdjust(TR);
/* The registers pointing to the local stack */
ENV = PtoLocAdjust(ENV);
ASP = PtoLocAdjust(ASP);
LCL0 = PtoLocAdjust(LCL0);
B = ChoicePtrAdjust(B);
if (TopB != NULL)
TopB = ChoicePtrAdjust(TopB);
if (DelayedB != NULL)
DelayedB = ChoicePtrAdjust(DelayedB);
#ifdef TABLING
B_FZ = ChoicePtrAdjust(B_FZ);
BB = ChoicePtrAdjust(BB);
TR_FZ = PtoTRAdjust(TR_FZ);
#endif
YENV = PtoLocAdjust(YENV);
if (MyTR)
MyTR = PtoTRAdjust(MyTR);
}
static void
MoveLocalAndTrail(void)
{
/* cpcellsd(To,From,NOfCells) - copy the cells downwards */
#if HAVE_MEMMOVE
cpcellsd(ASP, OldASP, (CELL *)OldTR - OldASP);
#else
cpcellsd((CELL *)TR, (CELL *)OldTR, (CELL *)OldTR - OldASP);
#endif
}
static void
MoveGlobal(void)
{
/*
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
* absmi.asm
*/
#if HAVE_MEMMOVE
cpcellsd((CELL *)GlobalBase, (CELL *)OldGlobalBase, OldH - (CELL *)OldGlobalBase);
#else
cpcellsd(H, OldH, OldH - (CELL *)OldGlobalBase);
#endif
}
static void
MoveGlobalOnly(void)
{
/*
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
* absmi.asm
*/
#if HAVE_MEMMOVE
cpcellsd(H0, OldH0, OldH - OldH0);
#else
cpcellsd(H, OldH, OldH - OldH0);
#endif
}
static inline CELL
AdjustAppl(register CELL t0)
{
register CELL *t = RepAppl(t0);
if (IsOldGlobalPtr(t))
return (AbsAppl(PtoGloAdjust(t)));
else if (IsOldDelayPtr(t))
return (AbsAppl(PtoDelayAdjust(t)));
else if (IsOldTrailPtr(t))
return (AbsAppl(CellPtoTRAdjust(t)));
else if (IsHeapP(t))
return (AbsAppl(CellPtoHeapAdjust(t)));
#ifdef DEBUG
else {
/* strange cell */
/* YP_fprintf(YP_stderr,"[ garbage appl %lx found in stacks by stack shifter ]\n", t0);*/
}
#endif
return(t0);
}
static inline CELL
AdjustPair(register CELL t0)
{
register CELL *t = RepPair(t0);
if (IsOldGlobalPtr(t))
return (AbsPair(PtoGloAdjust(t)));
if (IsOldDelayPtr(t))
return (AbsPair(PtoDelayAdjust(t)));
if (IsOldTrailPtr(t))
return (AbsPair(CellPtoTRAdjust(t)));
else if (IsHeapP(t))
return (AbsPair(CellPtoHeapAdjust(t)));
#ifdef DEBUG
/* YP_fprintf(YP_stderr,"[ garbage pair %lx found in stacks by stack shifter ]\n", t0);*/
#endif
return(t0);
}
static void
AdjustTrail(int adjusting_heap)
{
register tr_fr_ptr ptt;
ptt = TR;
/* moving the trail is simple */
while (ptt != (tr_fr_ptr)TrailBase) {
register CELL reg = TrailTerm(ptt-1);
ptt--;
if (IsVarTerm(reg)) {
if (IsOldLocalInTR(reg))
TrailTerm(ptt) = LocalAdjust(reg);
else if (IsOldGlobal(reg))
TrailTerm(ptt) = GlobalAdjust(reg);
else if (IsOldDelay(reg))
TrailTerm(ptt) = DelayAdjust(reg);
else if (IsOldTrail(reg))
TrailTerm(ptt) = TrailAdjust(reg);
else if (IsOldCode(reg)) {
CELL *ptr;
TrailTerm(ptt) = reg = CodeAdjust(reg);
ptr = (CELL *)reg;
if (IsApplTerm(*ptr)) {
*ptr = AdjustAppl(*ptr);
} else if (IsPairTerm(*ptr)) {
*ptr = AdjustAppl(*ptr);
}
#ifdef DEBUG
else
YP_fprintf(YP_stderr,"[ garbage heap ptr %p to %lx found in trail at %p by stack shifter ]\n", ptr, (unsigned long int)*ptr, ptt);
#endif
}
} else if (IsPairTerm(reg)) {
TrailTerm(ptt) = AdjustPair(reg);
#ifdef MULTI_ASSIGNMENT_VARIABLES /* does not work with new structures */
/* check it whether we are protecting a
multi-assignment */
} else if (IsApplTerm(reg)) {
TrailTerm(ptt) = AdjustAppl(reg);
#endif
}
}
}
static void
AdjustLocal(void)
{
register CELL reg, *pt;
/* Adjusting the local */
pt = LCL0;
while (pt > ASP) {
reg = *--pt;
if (IsVarTerm(reg)) {
if (IsOldLocal(reg))
*pt = LocalAdjust(reg);
else if (IsOldGlobal(reg))
*pt = GlobalAdjust(reg);
else if (IsOldDelay(reg))
*pt = DelayAdjust(reg);
else if (IsOldTrail(reg))
*pt = TrailAdjust(reg);
else if (IsOldCode(reg))
*pt = CodeAdjust(reg);
} else if (IsApplTerm(reg)) {
*pt = AdjustAppl(reg);
} else if (IsPairTerm(reg)) {
*pt = AdjustPair(reg);
}
}
}
static void
AdjustGlobal(void)
{
register CELL *pt;
/*
* to clean the global now that functors are just variables pointing to
* the code
*/
pt = CellPtr(GlobalBase);
while (pt < H) {
register CELL reg;
reg = *pt;
if (IsVarTerm(reg)) {
if (IsOldGlobal(reg))
*pt = GlobalAdjust(reg);
if (IsOldDelay(reg))
*pt = DelayAdjust(reg);
else if (IsOldLocal(reg))
*pt = LocalAdjust(reg);
else if (IsOldCode(reg)) {
Functor f;
f = (Functor)(*pt = CodeAdjust(reg));
if (f <= FunctorDouble && f >= FunctorLongInt) {
/* skip bitmaps */
switch((CELL)f) {
case (CELL)FunctorDouble:
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
pt += 3;
#else
pt += 2;
#endif
break;
#if USE_GMP
case (CELL)FunctorBigInt:
{
Int sz = 1+
sizeof(MP_INT)+
(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
pt += sz;
}
break;
#endif
case (CELL)FunctorLongInt:
default:
pt += 2;
break;
}
}
}
#ifdef MULTI_ASSIGNMENT_VARIABLES
else if (IsOldTrail(reg))
*pt = TrailAdjust(reg);
#endif
} else if (IsApplTerm(reg))
*pt = AdjustAppl(reg);
else if (IsPairTerm(reg))
*pt = AdjustPair(reg);
else if (IsAtomTerm(reg))
*pt = AtomTermAdjust(reg);
pt++;
}
}
/*
* When growing the stack we need to adjust: the local stack cells pointing
* to the local; the local stack cells and the X terms pointing to the global
* (just once) the trail cells pointing both to the global and to the local
*/
void
AdjustStacksAndTrail(void)
{
AdjustTrail(TRUE);
AdjustLocal();
AdjustGlobal();
}
/*
* When growing the stack we need to adjust: the local cells pointing to the
* local; the trail cells pointing to the local
*/
static void
AdjustGrowStack(void)
{
AdjustTrail(FALSE);
AdjustLocal();
}
void
AdjustRegs(int n)
{
int i;
CELL reg;
for (i = 1; i < n; ++i) {
reg = (CELL) XREGS[i];
if (IsVarTerm(reg)) {
if (IsOldLocal(reg))
reg = LocalAdjust(reg);
else if (IsOldGlobal(reg))
reg = GlobalAdjust(reg);
else if (IsOldDelay(reg))
reg = DelayAdjust(reg);
else if (IsOldTrail(reg))
reg = TrailAdjust(reg);
else if (IsOldCode(reg))
reg = CodeAdjust(reg);
} else if (IsApplTerm(reg))
reg = AdjustAppl(reg);
else if (IsPairTerm(reg))
reg = AdjustPair(reg);
XREGS[i] = (Term) reg;
}
}
/* Used by do_goal() when we're short of heap space */
static int
local_growheap(long size, int fix_code)
{
Int start_growth_time, growth_time;
int gc_verbose;
/* adjust to a multiple of 256) */
size = AdjustPageSize(size);
if (!ExtendWorkSpace(size)) {
return(FALSE);
}
start_growth_time = cputime();
gc_verbose = is_gc_verbose();
heap_overflows++;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[HO] Heap overflow %d\n", heap_overflows);
YP_fprintf(YP_stderr, "[HO] growing the heap %ld bytes\n", size);
}
ASP -= 256;
TrDiff = LDiff = GDiff = DelayDiff = size;
XDiff = HDiff = 0;
YAPEnterCriticalSection();
SetHeapRegs();
MoveLocalAndTrail();
if (fix_code) {
CELL *SaveOldH = OldH;
OldH = (CELL *)freep;
MoveGlobal();
OldH = SaveOldH;
} else {
MoveGlobal();
}
AdjustStacksAndTrail();
AdjustRegs(MaxTemps);
YAPLeaveCriticalSection();
ASP += 256;
growth_time = cputime()-start_growth_time;
total_heap_overflow_time += growth_time;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[HO] took %g sec\n", (double)growth_time/1000);
YP_fprintf(YP_stderr, "[HO] Total of %g sec expanding heap \n", (double)total_heap_overflow_time/1000);
}
return(TRUE);
}
/* Used by do_goal() when we're short of heap space */
static int
local_growglobal(long size)
{
Int start_growth_time, growth_time;
int gc_verbose;
/* adjust to a multiple of 256) */
size = AdjustPageSize(size);
if (!ExtendWorkSpace(size)) {
return(FALSE);
}
start_growth_time = cputime();
gc_verbose = is_gc_verbose();
delay_overflows++;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[DO] Delay overflow %d\n", delay_overflows);
YP_fprintf(YP_stderr, "[DO] growing the stacks %ld bytes\n", size);
}
ASP -= 256;
TrDiff = LDiff = GDiff = size;
XDiff = HDiff = DelayDiff = 0;
YAPEnterCriticalSection();
SetHeapRegs();
MoveLocalAndTrail();
MoveGlobalOnly();
AdjustStacksAndTrail();
AdjustRegs(MaxTemps);
YAPLeaveCriticalSection();
ASP += 256;
growth_time = cputime()-start_growth_time;
total_delay_overflow_time += growth_time;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[DO] took %g sec\n", (double)growth_time/1000);
YP_fprintf(YP_stderr, "[DO] Total of %g sec expanding stacks \n", (double)total_delay_overflow_time/1000);
}
return(TRUE);
}
static void
fix_compiler_instructions(PInstr *cpc)
{
while (cpc != NULL) {
PInstr *ncpc = cpc->nextInst;
switch(cpc->op) {
/* check c_var for functions that point at variables */
case get_var_op:
case get_val_op:
case unify_var_op:
case unify_last_var_op:
case unify_val_op:
case unify_last_val_op:
case put_var_op:
case put_val_op:
case write_var_op:
case write_val_op:
case f_var_op:
case f_val_op:
case fetch_args_for_bccall:
case bccall_op:
case save_pair_op:
case save_appl_op:
case save_b_op:
case comit_b_op:
cpc->rnd1 = GlobalAdjust(cpc->rnd1);
break;
default:
/* hopefully nothing to do */
break;
}
if (ncpc != NULL) {
ncpc = (PInstr *)GlobalAddrAdjust((ADDR)(cpc->nextInst));
cpc->nextInst = ncpc;
}
cpc = ncpc;
}
}
#ifdef TABLING
static void
fix_tabling_info(void)
{
/* we must fix the dependency frames and the subgoal frames, as they are
pointing back to the global stack. */
struct dependency_frame *df;
struct subgoal_frame *sg;
df = LOCAL_top_dep_fr;
while (df != NULL) {
if (DepFr_backchain_cp(df))
DepFr_backchain_cp(df) = ChoicePtrAdjust(DepFr_backchain_cp(df));
DepFr_leader_cp(df) = ChoicePtrAdjust(DepFr_leader_cp(df));
DepFr_cons_cp(df) = ConsumerChoicePtrAdjust(DepFr_cons_cp(df));
df = DepFr_next(df);
}
sg = LOCAL_top_sg_fr;
while (sg != NULL) {
SgFr_gen_cp(sg) = GeneratorChoicePtrAdjust(SgFr_gen_cp(sg));
sg = SgFr_next(sg);
}
}
#endif /* TABLING */
int
growheap(int fix_code)
{
unsigned long size = sizeof(CELL) * 16 * 1024L;
int shift_factor = (heap_overflows > 8 ? 8 : heap_overflows);
unsigned long sz = size << shift_factor;
#ifdef FIXED_STACKS
abort_optyap("noheapleft in function absmi");
#endif
if (SizeOfOverflow > sz)
sz = AdjustPageSize(SizeOfOverflow);
while(sz >= sizeof(CELL) * 16 * 1024L && !local_growheap(sz, fix_code)) {
size = size/2;
sz = size << shift_factor;
}
/* we must fix an instruction chain */
if (fix_code) {
PInstr *cpc = CodeStart;
if (cpc != NULL) {
CodeStart = cpc = (PInstr *)GlobalAddrAdjust((ADDR)cpc);
}
fix_compiler_instructions(cpc);
cpc = BlobsStart;
if (cpc != NULL) {
BlobsStart = cpc = (PInstr *)GlobalAddrAdjust((ADDR)cpc);
}
fix_compiler_instructions(cpc);
}
#ifdef TABLING
fix_tabling_info();
#endif
return(sz >= sizeof(CELL) * 16 * 1024L);
}
int
growglobal(void)
{
unsigned long sz = sizeof(CELL) * 16 * 1024L;
#ifdef FIXED_STACKS
abort_optyap("noheapleft in function absmi");
#endif
if (!local_growglobal(sz))
return(FALSE);
#ifdef TABLING
fix_tabling_info();
#endif
return(TRUE);
}
/* Used by do_goal() when we're short of stack space */
int
growstack(long size)
{
Int start_growth_time, growth_time;
int gc_verbose;
#ifdef FIXED_STACKS
abort_optyap("nostackleft in function absmi");
#endif
/* adjust to a multiple of 256) */
size = AdjustPageSize(size);
if (!ExtendWorkSpace(size)) {
return(FALSE);
}
start_growth_time = cputime();
gc_verbose = is_gc_verbose();
stack_overflows++;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[SO] Stack overflow %d\n", stack_overflows);
YP_fprintf(YP_stderr, "[SO] Heap: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)GlobalBase),GlobalBase,H);
YP_fprintf(YP_stderr, "[SO] Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
YP_fprintf(YP_stderr, "[SO] Trail:%8ld cells (%p-%p)\n",
(unsigned long int)(TR-(tr_fr_ptr)TrailBase),TrailBase,TR);
YP_fprintf(YP_stderr, "[SO] growing the stacks %ld bytes\n", size);
}
TrDiff = LDiff = size;
XDiff = HDiff = GDiff = DelayDiff = 0;
ASP -= 256;
YAPEnterCriticalSection();
SetStackRegs();
MoveLocalAndTrail();
AdjustGrowStack();
AdjustRegs(MaxTemps);
#ifdef TABLING
fix_tabling_info();
#endif
YAPLeaveCriticalSection();
CreepFlag = MinStackGap*(stack_overflows+1);
ASP += 256;
growth_time = cputime()-start_growth_time;
total_stack_overflow_time += growth_time;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[SO] took %g sec\n", (double)growth_time/1000);
YP_fprintf(YP_stderr, "[SO] Total of %g sec expanding stacks \n", (double)total_stack_overflow_time/1000);
}
return(TRUE);
}
static void
AdjustVarTable(VarEntry *ves)
{
ves->VarAdr = TermNil;
if (ves->VarRight != NULL) {
ves->VarRight = (VarEntry *)TrailAddrAdjust((ADDR)(ves->VarRight));
AdjustVarTable(ves->VarRight);
}
if (ves->VarLeft != NULL) {
ves->VarLeft = (VarEntry *)TrailAddrAdjust((ADDR)(ves->VarLeft));
AdjustVarTable(ves->VarLeft);
}
}
/*
If we have to shift while we are scanning we need to adjust all
pointers created by the scanner (Tokens and Variables)
*/
static void
AdjustScannerStacks(TokEntry **tksp, VarEntry **vep)
{
TokEntry *tks = *tksp;
VarEntry *ves = *vep;
if (tks != NULL) {
tks = *tksp = (TokEntry *)TrailAddrAdjust((ADDR)tks);
}
while (tks != NULL) {
TokEntry *tktmp;
switch (tks->Tok) {
case Var_tok:
case String_tok:
tks->TokInfo = TrailAdjust(tks->TokInfo);
break;
case Name_tok:
tks->TokInfo = (Term)AtomAdjust((Atom)(tks->TokInfo));
break;
default:
break;
}
tktmp = tks->TokNext;
if (tktmp != NULL) {
tktmp = (TokEntry *)TrailAddrAdjust((ADDR)tktmp);
tks->TokNext = tktmp;
}
tks = tktmp;
}
if (ves != NULL) {
ves = *vep = (VarEntry *)TrailAddrAdjust((ADDR)ves);
AdjustVarTable(ves);
}
ves = AnonVarTable;
if (ves != NULL) {
ves = AnonVarTable = (VarEntry *)TrailAddrAdjust((ADDR)ves);
}
while (ves != NULL) {
VarEntry *vetmp = ves->VarLeft;
if (vetmp != NULL) {
vetmp = (VarEntry *)TrailAddrAdjust((ADDR)vetmp);
ves->VarLeft = vetmp;
}
ves->VarAdr = TermNil;
ves = vetmp;
}
}
/* Used by parser when we're short of stack space */
int
growstack_in_parser(tr_fr_ptr *old_trp, TokEntry **tksp, VarEntry **vep)
{
Int start_growth_time, growth_time;
int gc_verbose;
long size = sizeof(CELL)*(LCL0-(CELL *)GlobalBase);
#ifdef FIXED_STACKS
abort_optyap("nostackleft in parser");
#endif
/* adjust to a multiple of 256) */
size = AdjustPageSize(size);
if (!ExtendWorkSpace(size)) {
return(FALSE);
}
start_growth_time = cputime();
gc_verbose = is_gc_verbose();
stack_overflows++;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[SO] Stack overflow %d\n", stack_overflows);
YP_fprintf(YP_stderr, "[SO] Heap: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)GlobalBase),(CELL *)GlobalBase,H);
YP_fprintf(YP_stderr, "[SO] Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
YP_fprintf(YP_stderr, "[SO] Trail:%8ld cells (%p-%p)\n",
(unsigned long int)(TR-(tr_fr_ptr)TrailBase),TrailBase,TR);
YP_fprintf(YP_stderr, "[SO] growing the stacks %ld bytes\n", size);
}
TrDiff = LDiff = size;
XDiff = HDiff = GDiff = DelayDiff = 0;
ASP -= 256;
YAPEnterCriticalSection();
SetStackRegs();
MoveLocalAndTrail();
AdjustScannerStacks(tksp, vep);
{
tr_fr_ptr nTR = TR;
*old_trp = TR = PtoTRAdjust(*old_trp);
AdjustGrowStack();
TR = nTR;
}
AdjustRegs(MaxTemps);
YAPLeaveCriticalSection();
CreepFlag = MinStackGap*(stack_overflows+1);
ASP += 256;
growth_time = cputime()-start_growth_time;
total_stack_overflow_time += growth_time;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[SO] took %g sec\n", (double)growth_time/1000);
YP_fprintf(YP_stderr, "[SO] Total of %g sec expanding stacks \n", (double)total_stack_overflow_time/1000);
}
return(TRUE);
}
/* Used by do_goal() when we're short of stack space */
int
growtrail(long size)
{
Int start_growth_time = cputime(), growth_time;
int gc_verbose = is_gc_verbose();
#ifdef FIXED_STACKS
abort_optyap("notrailleft in function absmi");
#endif
/* adjust to a multiple of 256) */
size = AdjustPageSize(size);
trail_overflows++;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[TO] Trail overflow %d\n", trail_overflows);
YP_fprintf(YP_stderr, "[TO] growing the trail %ld bytes\n", size);
}
if (!ExtendWorkSpace(size)) {
return(FALSE);
}
YAPEnterCriticalSection();
TrailTop += size;
YAPLeaveCriticalSection();
growth_time = cputime()-start_growth_time;
total_trail_overflow_time += growth_time;
if (gc_verbose) {
YP_fprintf(YP_stderr, "[TO] took %g sec\n", (double)growth_time/1000);
YP_fprintf(YP_stderr, "[TO] Total of %g sec expanding stacks \n", (double)total_stack_overflow_time/1000);
}
return(TRUE);
}
static Int
p_inform_trail_overflows(void)
{
Term tn = MkIntTerm(trail_overflows);
Term tt = MkIntegerTerm(total_trail_overflow_time);
return(unify(tn, ARG1) && unify(tt, ARG2));
}
/* :- grow_heap(Size) */
static Int
p_growheap(void)
{
Int diff;
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, "grow_heap/1");
return(FALSE);
} else if (!IsIntTerm(t1)) {
Error(TYPE_ERROR_INTEGER, t1, "grow_heap/1");
return(FALSE);
}
diff = IntOfTerm(t1);
if (diff < 0) {
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t1, "grow_heap/1");
}
return(local_growheap(diff, FALSE));
}
static Int
p_inform_heap_overflows(void)
{
Term tn = MkIntTerm(heap_overflows);
Term tt = MkIntegerTerm(total_heap_overflow_time);
return(unify(tn, ARG1) && unify(tt, ARG2));
}
/* :- grow_stack(Size) */
static Int
p_growstack(void)
{
Int diff;
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, "grow_stack/1");
return(FALSE);
} else if (!IsIntTerm(t1)) {
Error(TYPE_ERROR_INTEGER, t1, "grow_stack/1");
return(FALSE);
}
diff = IntOfTerm(t1);
if (diff < 0) {
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t1, "grow_stack/1");
}
return(growstack(diff));
}
static Int
p_inform_stack_overflows(void)
{
Term tn = MkIntTerm(stack_overflows);
Term tt = MkIntegerTerm(total_stack_overflow_time);
return(unify(tn, ARG1) && unify(tt, ARG2));
}
Int total_stack_shift_time(void)
{
return(total_heap_overflow_time+
total_stack_overflow_time+
total_trail_overflow_time);
}
void
InitGrowPreds(void)
{
InitCPred("$grow_heap", 1, p_growheap, SafePredFlag);
InitCPred("$grow_stack", 1, p_growstack, SafePredFlag);
InitCPred("$inform_trail_overflows", 2, p_inform_trail_overflows, SafePredFlag);
InitCPred("$inform_heap_overflows", 2, p_inform_heap_overflows, SafePredFlag);
InitCPred("$inform_stack_overflows", 2, p_inform_stack_overflows, SafePredFlag);
init_gc();
}

2388
C/heapgc.c Normal file
View File

File diff suppressed because it is too large Load Diff

1420
C/index.c Normal file
View File

File diff suppressed because it is too large Load Diff

1143
C/init.c Normal file
View File

File diff suppressed because it is too large Load Diff

4175
C/iopreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

81
C/load_aix.c Normal file
View File

@@ -0,0 +1,81 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dl.c *
* comments: dl based dynamic loaderr of external routines *
* tested on i486-linuxelf *
*************************************************************************/
#ifdef _AIX
#include "Yap.h"
#include "Yatom.h"
#include "yapio.h"
#include "Foreign.h"
#include <stdio.h>
#include <errno.h>
/*
* FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
YAPFindExecutable(char *name)
{
/* not really needed for dl version */
strcpy(YapExecutable,"./yap");
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
extern char *sys_errlist[ ];
/* load wants to follow the LIBRARY_PATH */
if (ofiles->next != NULL || libs != NULL) {
strcpy(LoadMsg," Load Failed: in AIX you must load a single object file");
return LOAD_FAILLED;
}
if (!TrueFileName(ofiles->s, FileNameBuf, TRUE)) {
strcpy(LoadMsg, " Trying to open unexisting file in LoadForeign ");
return LOAD_FAILLED;
}
/* In AIX, just call load and everything will go in */
if ((*init_proc=((YapInitProc *)load(FileNameBuf,0,NULL))) == NULL) {
strcpy(LoadMsg,sys_errlist[errno]);
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
void
ShutdownLoadForeign(void)
{
}
Int
ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif /* _AIX */

259
C/load_aout.c Normal file
View File

@@ -0,0 +1,259 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_aout.c *
* comments: aout based dynamic loader of external routines *
* *
*************************************************************************/
#include "Yap.h"
#include "yapio.h"
#include "Foreign.h"
#ifdef A_OUT
#include <stdio.h>
#if STDC_HEADERS
#include <stdlib.h>
#endif
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_FCNTL_H
#include <fcntl.h>
#endif
#if HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#if HAVE_SYS_FILE_H
#include <sys/file.h>
#endif
#if HAVE_SYS_PARAM_H
#include <sys/param.h>
#endif
#if HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
#include <a.out.h>
#define oktox(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,X_OK))
#define oktow(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFDIR&&0==access(n,W_OK))
/*
* YAPFindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
YAPFindExecutable(char *name)
{
register char *cp, *cp2;
struct stat stbuf;
cp = (char *)getenv("PATH");
if (cp == NULL)
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
if (*yap_args[0] == '/') {
if (oktox(yap_args[0])) {
strcpy(FileNameBuf, yap_args[0]);
TrueFileName(FileNameBuf, YapExecutable, TRUE);
return;
}
}
if (*cp == ':')
cp++;
for (; *cp;) {
/*
* copy over current directory and then append
* argv[0]
*/
for (cp2 = FileNameBuf; (*cp) != 0 && (*cp) != ':';)
*cp2++ = *cp++;
*cp2++ = '/';
strcpy(cp2, yap_args[0]);
if (*cp)
cp++;
if (!oktox(FileNameBuf))
continue;
TrueFileName(FileNameBuf, YapExecutable, TRUE);
return;
}
/* one last try for dual systems */
strcpy(FileNameBuf, yap_args[0]);
TrueFileName(FileNameBuf, YapExecutable, TRUE);
if (oktox(YapExecutable))
return;
else
Error(SYSTEM_ERROR,MkAtomTerm(LookupAtom(YapExecutable)),
"cannot find file being executed");
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
int
LoadForeign(StringList ofiles,
StringList libs,
char *proc_name,
YapInitProc *init_proc)
{
char command[2*MAXPATHLEN];
char o_files[1024]; /* list of objects we want to load
*/
char l_files[1024]; /* list of libraries we want to
load */
char tmp_buff[32] = "/tmp/YAP_TMP_XXXXXX"; /* used for
mktemp */
char *tfile; /* name of temporary file */
int fildes; /* temp file descriptor */
struct exec header; /* header for loaded file */
unsigned long loadImageSize, firstloadImSz; /* size of image we will load */
char *FCodeBase; /* where we load foreign code */
/*
* put in a string the names of the files you want to load and of any
* libraries you want to use
*/
/* files first */
*o_files = '\0';
{
StringList tmp = ofiles;
while(tmp != NULL) {
strcat(o_files," ");
strcat(o_files,tmp->s);
tmp = tmp->next;
}
}
/* same_trick for libraries */
*l_files = '\0';
{
StringList tmp = libs;
while(tmp != NULL) {
strcat(l_files," ");
strcat(l_files,tmp->s);
tmp = tmp->next;
}
}
/* next, create a temp file to serve as loader output */
tfile = mktemp(tmp_buff);
/* prepare the magic */
if (strlen(o_files) + strlen(l_files) + strlen(proc_name) +
strlen(YapExecutable) > 2*MAXPATHLEN) {
strcpy(LoadMsg, " too many parameters in load_foreign/3 ");
return LOAD_FAILLED;
}
sprintf(command, "/usr/bin/ld -N -A %s -o %s -u _%s %s %s -lc",
YapExecutable,
tfile, proc_name, o_files, l_files);
/* now, do the magic */
if (system(command) != 0) {
unlink(tfile);
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
/* now check the music has played */
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
/* it did, get the mice */
/* first, get the header */
read(fildes, (char *) &header, sizeof(header));
close(fildes);
/* get the full size of what we need to load */
loadImageSize = header.a_text + header.a_data + header.a_bss;
/* add 16 just to play it safe */
loadImageSize += 16;
/* keep this copy */
firstloadImSz = loadImageSize;
/* now fetch the space we need */
if (!(FCodeBase = AllocCodeSpace((int) loadImageSize))) {
strcpy(LoadMsg," unable to allocate space for external code ");
return LOAD_FAILLED;
}
/* now, a new incantation to load the new foreign code */
sprintf(command, "/usr/bin/ld -N -A %s -T %lx -o %s -u _%s %s %s -lc",
YapExecutable,
(unsigned long) FCodeBase,
tfile, proc_name, o_files, l_files);
/* and do it */
if (system(command) != 0) {
unlink(tfile);
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
read(fildes, (char *) &header, sizeof(header));
loadImageSize = header.a_text + header.a_data + header.a_bss;
if (firstloadImSz < loadImageSize) {
strcpy(LoadMsg," miscalculation in load_foreign/3 ");
return LOAD_FAILLED;
}
/* now search for our init function */
{
char entry_fun[256];
struct nlist func_info[2];
sprintf(entry_fun, "_%s", proc_name);
func_info[0].n_un.n_name = entry_fun;
func_info[1].n_un.n_name = NULL;
if (nlist(tfile, func_info) == -1) {
strcpy(LoadMsg," in nlist(3) ");
return LOAD_FAILLED;
}
if (func_info[0].n_type == 0) {
strcpy(LoadMsg," in nlist(3) ");
return LOAD_FAILLED;
}
*init_proc = (YapInitProc)(func_info[0].n_value);
}
/* ok, we got our init point */
/* now read our text */
lseek(fildes, (long)(N_TXTOFF(header)), 0);
{
unsigned int u1 = header.a_text + header.a_data;
read(fildes, (char *) FCodeBase, u1);
/* zero the BSS segment */
while (u1 < loadImageSize)
FCodeBase[u1++] = 0;
}
close(fildes);
unlink(tfile);
return LOAD_SUCCEEDED;
}
void
ShutdownLoadForeign(void)
{
}
Int
ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

309
C/load_coff.c Normal file
View File

@@ -0,0 +1,309 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_coff.c *
* comments: coff based dynamic loader of external routines *
* *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "Foreign.h"
#ifdef COFF
#include <stdio.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/file.h>
#include <sys/param.h>
#include <sys/stat.h>
#include <a.out.h>
#define oktox(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,X_OK))
#define oktow(n) \
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFDIR&&0==access(n,W_OK))
#ifdef mips
#define MAXSECTIONS 100
#else
#define MAXSECTIONS 20
#endif /* mips */
#ifdef sgi
#include <symbol.h>
#endif /* sgi */
#define N_TXTOFF(x) (sizeof(struct filehdr)+(x).f_opthdr+(x).f_nscns*sizeof(struct scnhdr))
/*
* YAPFindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
YAPFindExecutable(char *name)
{
register char *cp, *cp2;
struct stat stbuf;
cp = (char *)getenv("PATH");
if (cp == NULL)
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
if (*yap_args[0] == '/') {
if (oktox(yap_args[0])) {
strcpy(FileNameBuf, yap_args[0]);
TrueFileName(FileNameBuf, YapExecutable, TRUE);
return;
}
}
if (*cp == ':')
cp++;
for (; *cp;) {
/*
* copy over current directory and then append
* argv[0]
*/
for (cp2 = FileNameBuf; (*cp) != 0 && (*cp) != ':';)
*cp2++ = *cp++;
*cp2++ = '/';
strcpy(cp2, yap_args[0]);
if (*cp)
cp++;
if (!oktox(FileNameBuf))
continue;
TrueFileName(FileNameBuf, YapExecutable, TRUE);
return;
}
/* one last try for dual systems */
strcpy(FileNameBuf, yap_args[0]);
TrueFileName(FileNameBuf, YapExecutable, TRUE);
if (oktox(YapExecutable))
return;
else
Error(SYSTEM_ERROR,MkAtomTerm(LookupAtom(YapExecutable)),
"cannot find file being executed");
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
int
LoadForeign(StringList ofiles,
StringList libs,
char *proc_name,
YapInitProc *init_proc)
{
char command[2*MAXPATHLEN];
char o_files[1024]; /* list of objects we want to load
*/
char l_files[1024]; /* list of libraries we want to
load */
char tmp_buff[32] = "/tmp/YAP_TMP_XXXXXX"; /* used for
mktemp */
char *tfile; /* name of temporary file */
int fildes; /* temp file descriptor */
struct aouthdr sysHeader;
struct filehdr fileHeader;
struct scnhdr sectionHeader[MAXSECTIONS];
struct exec header; /* header for loaded file */
unsigned long loadImageSize, firstloadImSz; /* size of image we will load */
char *FCodeBase; /* where we load foreign code */
/*
* put in a string the names of the files you want to load and of any
* libraries you want to use
*/
/* files first */
*o_files = '\0';
{
StringList tmp = ofiles;
while(tmp != NULL) {
strcat(o_files," ");
strcat(o_files,tmp->s);
tmp = tmp->next;
}
}
/* same_trick for libraries */
*l_files = '\0';
{
StringList tmp = libs;
while(tmp != NULL) {
strcat(l_files," ");
strcat(l_files,tmp->s);
tmp = tmp->next;
}
}
/* next, create a temp file to serve as loader output */
tfile = mktemp(tmp_buff);
/* prepare the magic */
if (strlen(o_files) + strlen(l_files) + strlen(proc_name) +
strlen(YapExecutable) > 2*MAXPATHLEN) {
strcpy(LoadMsg, " too many parameters in load_foreign/3 ");
return LOAD_FAILLED;
}
sprintf(command, "/usr/bin/ld -N -A %s -o %s %s %s -lc",
YapExecutable,
tfile, o_files, l_files);
/* now, do the magic */
if (system(command) != 0) {
unlink(tfile);
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
/* now check the music has played */
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
/* it did, get the mice */
/* first, get the header */
read(fildes, (char *) &fileHeader, sizeof(fileHeader));
read(fildes, (char *) &sysHeader, sizeof(sysHeader));
{ int i;
for (i = 0; i < fileHeader.f_nscns; i++)
read(fildes, (char *) &sectionHeader[i],
sizeof(*sectionHeader));
}
close(fildes);
/* get the full size of what we need to load */
loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize;
#ifdef mips
/* add an extra page in mips machines */
loadImageSize += 4095 + 16;
#else
/* add 16 just to play it safe */
loadImageSize += 16;
#endif
/* keep this copy */
firstloadImSz = loadImageSize;
/* now fetch the space we need */
if (!(FCodeBase = AllocCodeSpace((int) loadImageSize))
#ifdef pyr
|| activate_code(ForeignCodeBase, u1)
#endif /* pyr */
) {
strcpy(LoadMsg," unable to allocate space for external code ");
return LOAD_FAILLED;
}
#ifdef mips
FCodeBase = (char *) (Unsigned(FCodeBase + PAGESIZE - 1) & ~(PAGESIZE - 1));
#endif
/* now, a new incantation to load the new foreign code */
#ifdef convex
/* No -N flag in the Convex loader */
/* -T option does not want MallocBase bit set */
sprintf(command, "ld -x -A %s -T %lx -o %s -u %s %s %s -lc",
ostabf,
((unsigned long) (((unsigned long) (ForeignCodeBase)) &
((unsigned long) (~HeapBase))
)
), tfile, entry_point, o_files, l_files);
#else
#ifdef mips
sprintf(command, "ld -systype bsd43 -N -A %s -T %lx -o %s -u %s %s %s -lc",
ostabf,
(unsigned long) ForeignCodeBase,
tfile, entry_point, o_files, l_files);
#else
sprintf(command, "ld -N -A %s -T %lx -o %s -e %s -u _%s %s -lc",
ostabf,
(unsigned long) ForeignCodeBase,
tfile, entry_point, o_files, l_files);
#endif /* mips */
#endif /* convex */
/* and do it */
if (system(command) != 0) {
unlink(tfile);
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
return LOAD_FAILLED;
}
if ((fildes = open(tfile, O_RDONLY)) < 0) {
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
return LOAD_FAILLED;
}
read(fildes, (char *) &fileHeader, sizeof(fileHeader));
read(fildes, (char *) &sysHeader, sizeof(sysHeader));
{
int i;
for (i = 0; i < fileHeader.f_nscns; i++)
read(fildes, (char *) &sectionHeader[i], sizeof(*sectionHeader));
}
loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize;
if (firstloadImSz < loadImageSize) {
strcpy(LoadMsg," miscalculation in load_foreign/3 ");
return LOAD_FAILLED;
}
/* now search for our init function */
{
char entry_fun[256];
struct nlist func_info[2];
#if defined(mips) || defined(I386)
char NAME1[128], NAME2[128];
func_info[0].n_name = NAME1;
func_info[1].n_name = NAME2;
#endif /* COFF */
sprintf(entry_fun, "_%s", proc_name);
func_info[0].n_name = entry_fun;
func_info[1].n_name = NULL;
if (nlist(tfile, func_info) == -1) {
strcpy(LoadMsg," in nlist(3) ");
return LOAD_FAILLED;
}
if (func_info[0].n_type == 0) {
strcpy(LoadMsg," in nlist(3) ");
return LOAD_FAILLED;
}
*init_proc = (YapInitProc)(func_info[0].n_value);
}
/* ok, we got our init point */
/* now read our text */
lseek(fildes, (long)(N_TXTOFF(header)), 0);
{
unsigned int u1 = header.a_text + header.a_data;
read(fildes, (char *) FCodeBase, u1);
/* zero the BSS segment */
while (u1 < loadImageSize)
FCodeBase[u1++] = 0;
}
close(fildes);
unlink(tfile);
return LOAD_SUCCEEDED;
}
void
ShutdownLoadForeign(void)
{
}
Int
ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

159
C/load_dl.c Normal file
View File

@@ -0,0 +1,159 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dl.c *
* comments: dl based dynamic loaderr of external routines *
* tested on i486-linuxelf *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include "Foreign.h"
#if LOAD_DL
#include <dlfcn.h>
#include <string.h>
#include <stdio.h>
/*
* YAPFindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
YAPFindExecutable(char *name)
{
/* not really needed for dl version */
strcpy(YapExecutable,"yap");
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
while (ofiles) {
void *handle;
/* dlopen wants to follow the LD_CONFIG_PATH */
if (!TrueFileName(ofiles->s, FileNameBuf, TRUE)) {
strcpy(LoadMsg, "[ Trying to open unexisting file in LoadForeign ]");
return LOAD_FAILLED;
}
#ifdef __osf__
if((handle=dlopen(FileNameBuf,RTLD_LAZY)) == 0)
#else
if((handle=dlopen(FileNameBuf,RTLD_LAZY|RTLD_GLOBAL)) == 0)
#endif
{
fprintf(stderr,"calling dlopen with error %s\n", dlerror());
/* strcpy(LoadMsg,dlerror());*/
return LOAD_FAILLED;
}
ofiles->handle = handle;
if (!*init_proc)
*init_proc = (YapInitProc) dlsym(handle,proc_name);
ofiles = ofiles->next;
}
if(! *init_proc) {
strcpy(LoadMsg,"Could not locate initialization routine");
return LOAD_FAILLED;
}
/* load libraries first so that their symbols are available to
other routines */
while (libs) {
if (libs->s[0] == '-') {
strcpy(FileNameBuf,"lib");
strcat(FileNameBuf,libs->s+2);
strcat(FileNameBuf,".so");
} else {
strcpy(FileNameBuf,libs->s);
}
#ifdef __osf__
if((libs->handle=dlopen(FileNameBuf,RTLD_LAZY)) == NULL)
#else
if((libs->handle=dlopen(FileNameBuf,RTLD_LAZY|RTLD_GLOBAL)) == NULL)
#endif
{
strcpy(LoadMsg,dlerror());
return LOAD_FAILLED;
}
libs = libs->next;
}
return LOAD_SUCCEEDED;
}
void
ShutdownLoadForeign(void)
{
ForeignObj *f_code;
f_code = ForeignCodeLoaded;
while (f_code != NULL) {
StringList objs, libs;
objs = f_code->objs;
while (objs != NULL) {
if (dlclose(objs->handle) != 0)
return; /* ERROR */
objs = objs->next;
}
libs = f_code->libs;
while (libs != NULL) {
if (dlclose(libs->handle) != 0)
return; /* ERROR */
objs = libs->next;
}
f_code = f_code->next;
}
}
Int
ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif
#if SIMICS
void dlopen(void)
{
}
void dlclose(void)
{
}
void dlsym(void)
{
}
#endif

103
C/load_dld.c Normal file
View File

@@ -0,0 +1,103 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dld.c *
* comments: dld based dynamic loaderr of external routines *
* tested on i486-linuxaout *
*************************************************************************/
#if defined(linux) && !defined(__ELF__) && !defined(__LCC__)
#include "Foreign.h"
#include <dld.h>
#include <malloc.h>
#include <stdio.h>
/*
* YAPFindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
YAPFindExecutable(char *name)
{
/* use dld_find_executable */
char *res;
if(name != NULL && (res=dld_find_executable(name))) {
strcpy(YapExecutable,res);
} else {
strcpy(YapExecutable,"./yap");
}
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
static int firstTime = 1;
int error;
if(firstTime) {
error = dld_init(YapExecutable);
if(error) {
strcpy(LoadMsg,dld_strerror(error));
return LOAD_FAILLED;
}
firstTime=0;
}
while (ofiles) {
if((error=dld_link(ofiles->s)) !=0) {
strcpy(LoadMsg,dld_strerror(error));
return LOAD_FAILLED;
}
ofiles = ofiles->next;
}
/* TODO: handle libs */
*init_proc = (YapInitProc) dld_get_func(proc_name);
if(! *init_proc) {
strcpy(LoadMsg,"Could not locate initialization routine");
return LOAD_FAILLED;
}
if(!dld_function_executable_p(proc_name)) {
char **undefs = dld_list_undefined_sym();
char **p = undefs;
int k = dld_undefined_sym_count;
strcpy(LoadMsg,"Could not resolve all symbols");
while(k) {
YP_printf("[undefined symbol %s]\n",*p++);
--k;
}
free(undefs);
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
void
ShutdownLoadForeign(void)
{
}
Int
ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

104
C/load_dll.c Normal file
View File

@@ -0,0 +1,104 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_dl.c *
* comments: dl based dynamic loader of external routines *
* tested on i486-linuxelf *
*************************************************************************/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include "Foreign.h"
#if LOAD_DLL
#include <windows.h>
/*
* YAPFindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
YAPFindExecutable(char *name)
{
/* not really needed for dl version */
strcpy(YapExecutable,"yap");
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
while (ofiles) {
HINSTANCE handle;
if (TrueFileName(ofiles->s, FileNameBuf, TRUE) &&
(handle=LoadLibrary(FileNameBuf)) != 0)
{
if (*init_proc == NULL)
*init_proc = (YapInitProc)GetProcAddress((HMODULE)handle, proc_name);
}
ofiles = ofiles->next;
}
/* load libraries first so that their symbols are available to
other routines */
while (libs) {
HINSTANCE handle;
if (libs->s[0] == '-') {
strcat(FileNameBuf,libs->s+2);
strcat(FileNameBuf,".dll");
} else {
strcpy(FileNameBuf,libs->s);
}
if((handle=LoadLibrary(FileNameBuf)) == 0)
{
/* strcpy(LoadMsg,dlerror());*/
return LOAD_FAILLED;
}
if (*init_proc == NULL)
*init_proc = (YapInitProc)GetProcAddress((HMODULE)handle, proc_name);
libs = libs->next;
}
if(*init_proc == NULL) {
strcpy(LoadMsg,"Could not locate initialization routine");
return LOAD_FAILLED;
}
return LOAD_SUCCEEDED;
}
void
ShutdownLoadForeign(void)
{
}
Int
ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

143
C/load_foreign.c Normal file
View File

@@ -0,0 +1,143 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_foreign.c *
* comments: dynamic loader of external routines *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%.2";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include <stdlib.h>
#if HAVE_STRING_H
#include <string.h>
#endif
#include "Foreign.h"
#if _WIN32
#ifndef SHLIB_SUFFIX
#define SHLIB_SUFFIX "dll"
#endif
#endif
char LoadMsg[512];
char YapExecutable[YAP_FILENAME_MAX];
STD_PROTO(Int p_load_foreign, (void));
Int
p_load_foreign(void)
{
StringList ofiles = NIL;
StringList libs = NIL;
char *InitProcName;
YapInitProc InitProc = NULL;
Term t, t1;
StringList new;
Int returncode = FALSE;
strcpy(LoadMsg,"Invalid arguments");
/* collect the list of object files */
t = Deref(ARG1);
while(1) {
if (t == TermNil) break;
t1 = HeadOfTerm(t);
t = TailOfTerm(t);
new = (StringList) AllocCodeSpace(sizeof(StringListItem));
new->next = ofiles;
new->s = RepAtom(AtomOfTerm(t1))->StrOfAE;
ofiles = new;
}
/* collect the list of library files */
t = Deref(ARG2);
while(1) {
if (t == TermNil) break;
t1 = HeadOfTerm(t);
t = TailOfTerm(t);
new = (StringList) AllocCodeSpace(sizeof(StringListItem));
new->next = libs;
new->s = RepAtom(AtomOfTerm(t1))->StrOfAE;
libs = new;
}
/* get the initialization function name */
t1 = Deref(ARG3);
InitProcName = RepAtom(AtomOfTerm(t1))->StrOfAE;
/* call the OS specific function for dynamic loading */
if(LoadForeign(ofiles,libs,InitProcName,&InitProc)==LOAD_SUCCEEDED) {
(*InitProc)();
returncode = TRUE;
}
/* I should recover space if load foreign fails */
if (returncode == TRUE) {
ForeignObj *f_code = (ForeignObj *)AllocCodeSpace(sizeof(ForeignObj));
f_code->objs = ofiles;
f_code->libs = libs;
f_code->f = InitProcName;
f_code->next = ForeignCodeLoaded;
f_code->module = CurrentModule;
ForeignCodeLoaded = (void *)f_code;
}
return returncode;
}
static Int
p_obj_suffix(void) {
return(unify(StringToList(SHLIB_SUFFIX),ARG1));
}
void
InitLoadForeign(void)
{
if (yap_args == NULL)
YAPFindExecutable(NULL);
else
YAPFindExecutable(yap_args[0]);
InitCPred("$load_foreign_files", 3, p_load_foreign, SafePredFlag|SyncPredFlag);
InitCPred("$obj_suffix", 1, p_obj_suffix, SafePredFlag);
}
void
ReOpenLoadForeign(void)
{
ForeignObj *f_code = ForeignCodeLoaded;
int OldModule = CurrentModule;
YapInitProc InitProc = NULL;
while (f_code != NULL) {
CurrentModule = f_code->module;
if(ReLoadForeign(f_code->objs,f_code->libs,f_code->f,&InitProc)==LOAD_SUCCEEDED) {
(*InitProc)();
}
f_code = f_code->next;
}
CurrentModule = OldModule;
}

57
C/load_none.c Normal file
View File

@@ -0,0 +1,57 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_none.c *
* comments: dummy dynamic loaderr of external routines *
*************************************************************************/
#include "Yap.h"
#include "Foreign.h"
#ifdef NO_DYN
/*
* YAPFindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void
YAPFindExecutable(char *name)
{
/* signal name not found */
strcpy(YapExecutable,"./yap");
}
/*
* LoadForeign(file_name,proc_name,init_proc) dynamically loads a foreign
* code file and locates an initialization routine
*/
Int
LoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
strcpy(LoadMsg,"load_foreign not supported in this version of Yap");
return LOAD_FAILLED;
}
void
ShutdownLoadForeign(void)
{
}
Int
ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
return(LoadForeign(ofiles,libs, proc_name, init_proc));
}
#endif

145
C/load_shl.c Normal file
View File

@@ -0,0 +1,145 @@
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include "Foreign.h"
#if LOAD_SHL
#include <dl.h>
#include <malloc.h>
#include <stdio.h>
/*
* YAPFindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap
*/
void YAPFindExecutable(char *name)
{
/* not really needed for shl version */
strcpy( YapExecutable, "yap" );
}
/*
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
* code files and libraries and locates an initialization routine
*/
Int LoadForeign( StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc )
{
/* *init_proc is initialised to NULL in load_foreign.c */
int init_missing = -1;
int n, i;
struct shl_symbol *p;
while( ofiles ) {
int valid_fname;
/* shl_load wants to follow the LD_CONFIG_PATH */
valid_fname = TrueFileName( ofiles->s, FileNameBuf, TRUE );
if( !valid_fname ) {
strcpy( LoadMsg, "[ Trying to open non-existing file in LoadForeign ]" );
return LOAD_FAILLED;
}
ofiles->handle = malloc( sizeof(shl_t) );
*(shl_t *)ofiles->handle = shl_load( FileNameBuf, BIND_DEFERRED, 0 );
if( *(shl_t *)ofiles->handle == NULL ) {
strerror_r( errno, LoadMsg, 512 );
return LOAD_FAILLED;
}
if( init_missing ) {
init_missing = shl_findsym( ofiles->handle, proc_name,
TYPE_PROCEDURE, init_proc );
}
ofiles = ofiles->next;
}
if( init_missing ) {
strcpy( LoadMsg, "Could not locate initialization routine" );
return LOAD_FAILLED;
}
while( libs ) {
if( libs->s[0] == '-' ) {
strcpy( FileNameBuf, "lib" );
strcat( FileNameBuf, libs->s+2 );
strcat( FileNameBuf, ".sl" );
}
else {
strcpy( FileNameBuf, libs->s );
}
*(shl_t *)libs->handle = shl_load( FileNameBuf, BIND_DEFERRED, 0 );
if( *(shl_t *)libs->handle == NULL ) {
strerror_r( errno, LoadMsg, 512 );
return LOAD_FAILLED;
}
libs = libs->next;
}
return LOAD_SUCCEEDED;
}
void ShutdownLoadForeign( void )
{
ForeignObj *f_code;
int err;
f_code = ForeignCodeLoaded;
while( f_code != NULL ) {
StringList objs, libs;
objs = f_code->objs;
while( objs ) {
err = shl_unload( *(shl_t *)objs->handle );
if( err ) {
/* dunno how to properly report an error here */
perror( NULL );
return;
}
free( objs->handle );
objs = objs->next;
}
libs = f_code->libs;
while( libs ) {
err = shl_unload( *(shl_t *)libs->handle );
if( err ) {
/* dunno how to properly report an error here */
perror( NULL );
return;
}
free( libs->handle );
libs = libs->next;
}
f_code = f_code->next;
}
}
Int ReLoadForeign(StringList ofiles, StringList libs,
char *proc_name, YapInitProc *init_proc)
{
ShutdownLoadForeign();
return( LoadForeign( ofiles, libs, proc_name, init_proc ) );
}
/*
dunno what this one is supposed to do, no load_* defines it
void STD_PROTO(ReOpenLoadForeign,(void));
*/
#endif

276
C/mavar.c Normal file
View File

@@ -0,0 +1,276 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: mavar.c *
* Last rev: *
* mods: *
* comments: support from multiple assignment variables in YAP *
* *
*************************************************************************/
#include "Yap.h"
#ifdef MULTI_ASSIGNMENT_VARIABLES
#include "Yatom.h"
#include "Heap.h"
#include "eval.h"
STD_PROTO(static Int p_setarg, (void));
STD_PROTO(static void CreateTimedVar, (Term));
STD_PROTO(static void CreateEmptyTimedVar, (void));
STD_PROTO(static Int p_create_mutable, (void));
STD_PROTO(static Int p_get_mutable, (void));
STD_PROTO(static Int p_update_mutable, (void));
STD_PROTO(static Int p_is_mutable, (void));
static Int
p_setarg(void)
{
CELL ti = Deref(ARG1), ts = Deref(ARG2);
Int i;
if (IsVarTerm(ti)) {
Error(INSTANTIATION_ERROR,ti,"setarg/3");
return(FALSE);
} else {
if (IsIntTerm(ti))
i = IntOfTerm(ti);
else {
union arith_ret v;
if (Eval(ti, &v) == long_int_e) {
i = v.Int;
} else {
Error(TYPE_ERROR_INTEGER,ti,"setarg/3");
return(FALSE);
}
}
}
if (IsVarTerm(ts)) {
Error(INSTANTIATION_ERROR,ts,"setarg/3");
} else if(IsApplTerm(ts)) {
CELL *pt;
if (IsExtensionFunctor(FunctorOfTerm(ts))) {
Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
return(FALSE);
}
if (i < 0 || i > (Int)ArityOfFunctor(FunctorOfTerm(ts))) {
if (i<0)
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return(FALSE);
}
pt = RepAppl(ts)+i;
/* the evil deed is to be done now */
MaBind(pt, Deref(ARG3));
} else if(IsPairTerm(ts)) {
CELL *pt;
if (i != 1 || i != 2) {
if (i<0)
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return(FALSE);
}
pt = RepPair(ts)+i-1;
/* the evil deed is to be done now */
MaBind(pt, Deref(ARG3));
} else {
Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
return(FALSE);
}
return(TRUE);
}
/* One problem with MAVars is that they you always trail on
non-determinate bindings. This is not cool if you have a long
determinate computation. One alternative could be to use
timestamps.
Because of !, the only timestamp one can trust is the trailpointer
(ouch..). The trail is not reclaimed during backtracking. Also, if
there was a conditional binding, the trail is sure to have been
increased since the last choicepoint. For maximum effect, we can
actually store the current value of TR in the timestamp field,
giving a way to actually follow a link of all trailings for these
variables.
*/
/* create and initialise a new timed var. The problem is: how to set
the clock?
If I give it the current value of B->TR, we may have trouble if no
non-determinate bindings are made before the next
choice-point. Just to make sure this doesn't cause trouble, if (TR
== B->TR) we will add a little something ;-).
*/
static void
CreateTimedVar(Term val)
{
timed_var *tv = (timed_var *)H;
tv->clock = MkIntegerTerm((Int)((CELL *)(B->cp_tr)-(CELL *)TrailBase));
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
/* so we just init a TR cell that will not harm anyone */
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
tv->value = val;
H += sizeof(timed_var)/sizeof(CELL);
}
static void
CreateEmptyTimedVar(void)
{
timed_var *tv = (timed_var *)H;
tv->clock = MkIntegerTerm((Int)((CELL *)(B->cp_tr)-(CELL *)TrailBase));
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
/* so we just init a TR cell that will not harm anyone */
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
RESET_VARIABLE(&(tv->value));
H += sizeof(timed_var)/sizeof(CELL);
}
Term NewTimedVar(CELL val)
{
Term t = AbsAppl(H);
*H++ = (CELL)FunctorMutable;
CreateTimedVar(val);
return(t);
}
Term NewEmptyTimedVar(void)
{
Term t = AbsAppl(H);
*H++ = (CELL)FunctorMutable;
CreateEmptyTimedVar();
return(t);
}
Term ReadTimedVar(Term inv)
{
timed_var *tv = (timed_var *)(RepAppl(inv)+1);
return(tv->value);
}
/* update a timed var with a new value */
Term UpdateTimedVar(Term inv, Term new)
{
timed_var *tv = (timed_var *)(RepAppl(inv)+1);
CELL t = tv->value;
tr_fr_ptr timestmp = (tr_fr_ptr)((CELL *)TrailBase + IntegerOfTerm(tv->clock));
if (B->cp_tr <= timestmp
#if defined(SBA) || defined(TABLING)
&& timestmp <= TR
#endif
) {
/* last assignment more recent than last B */
#if SBA
if (Unsigned((Int)(tv)-(Int)(H_FZ)) >
Unsigned((Int)(B_FZ)-(Int)(H_FZ)))
*STACK_TO_SBA(&(tv->value)) = new;
else
#endif
tv->value = new;
#if defined(SBA) || defined(TABLING)
if (Unsigned((Int)(tv)-(Int)(HBREG)) >
Unsigned(BBREG)-(Int)(HBREG))
TrailVal(timestmp-1) = new;
#endif
} else {
Term nclock;
MaBind(&(tv->value), new);
nclock = MkIntegerTerm((Int)((CELL *)TR-(CELL *)TrailBase));
MaBind(&(tv->clock), nclock);
}
return(t);
}
static Int
p_create_mutable(void)
{
Term t = NewTimedVar(Deref(ARG1));
return(unify(ARG2,t));
}
static Int
p_get_mutable(void)
{
Term t = Deref(ARG2);
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR, t, "get_mutable/3");
return(FALSE);
}
if (!IsApplTerm(t)) {
Error(TYPE_ERROR_COMPOUND,t,"get_mutable/3");
return(FALSE);
}
if (FunctorOfTerm(t) != FunctorMutable) {
Error(DOMAIN_ERROR_MUTABLE,t,"get_mutable/3");
return(FALSE);
}
t = ReadTimedVar(t);
return(unify(ARG1, t));
}
static Int
p_update_mutable(void)
{
Term t = Deref(ARG2);
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR, t, "update_mutable/3");
return(FALSE);
}
if (!IsApplTerm(t)) {
Error(TYPE_ERROR_COMPOUND,t,"update_mutable/3");
return(FALSE);
}
if (FunctorOfTerm(t) != FunctorMutable) {
Error(DOMAIN_ERROR_MUTABLE,t,"update_mutable/3");
return(FALSE);
}
UpdateTimedVar(t, Deref(ARG1));
return(TRUE);
}
static Int
p_is_mutable(void)
{
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
return(FALSE);
}
if (!IsApplTerm(t)) {
return(FALSE);
}
if (FunctorOfTerm(t) != FunctorMutable) {
return(FALSE);
}
return(TRUE);
}
#endif
void
InitMaVarCPreds(void)
{
#ifdef MULTI_ASSIGNMENT_VARIABLES
/* The most famous contributions of SICStus to the Prolog language */
InitCPred("setarg", 3, p_setarg, SafePredFlag);
InitCPred("create_mutable", 2, p_create_mutable, SafePredFlag);
InitCPred("get_mutable", 2, p_get_mutable, SafePredFlag);
InitCPred("update_mutable", 2, p_update_mutable, SafePredFlag);
InitCPred("is_mutable", 1, p_is_mutable, SafePredFlag);
#endif
}

96
C/modules.c Normal file
View File

@@ -0,0 +1,96 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
File: modules.c *
* Last rev: *
* mods: *
* comments: module support *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
STATIC_PROTO(Int p_current_module, (void));
STATIC_PROTO(Int p_current_module1, (void));
STD_PROTO(void InitModules, (void));
#define ByteAdr(X) ((char *) &(X))
Term
Module_Name(CODEADDR cap)
{
PredEntry *ap = (PredEntry *)cap;
if (!ap->ModuleOfPred)
/* If the system predicate is a metacall I should return the
module for the metacall, which I will suppose has to be
reachable from the current module anyway.
So I will return the current module in case the system
predicate is a meta-call. Otherwise it will still work.
*/
return(ModuleName[CurrentModule]);
else
return (ModuleName[ap->ModuleOfPred]);
}
int
LookupModule(Term a)
{
unsigned int i;
for (i = 0; i < NoOfModules; ++i)
if (ModuleName[i] == a)
return (i);
ModuleName[i = NoOfModules++] = a;
return (i);
}
static Int
p_current_module(void)
{ /* $current_module(Old,New) */
Term t;
unsigned int i;
if (!unify_constant(ARG1, ModuleName[CurrentModule]))
return (0);
t = Deref(ARG2);
if (IsVarTerm(t) || !IsAtomTerm(t))
return (0);
for (i = 0; i < NoOfModules; ++i)
if (ModuleName[i] == t) {
CurrentModule = i;
return (1);
}
ModuleName[CurrentModule = NoOfModules++] = t;
return (1);
}
static Int
p_current_module1(void)
{ /* $current_module(Old) */
if (!unify_constant(ARG1, ModuleName[CurrentModule]))
return (0);
return (1);
}
void
InitModules(void)
{
ModuleName[CurrentModule = PrimitivesModule = 0] =
MkAtomTerm(LookupAtom("prolog"));
ModuleName[1] = MkAtomTerm(LookupAtom("user"));
InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);
}

52
C/other.c Normal file
View File

@@ -0,0 +1,52 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: other.c *
* Last rev: Dec/90 *
* mods: *
* comments: extra routines *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
Term
MkPairTerm(Term head, Term tail)
{
register CELL *p = H;
*H++ = (CELL) (head);
*H++ = (CELL) (tail);
return (AbsPair(p));
}
Term
MkApplTerm(Functor f, unsigned int n, register Term *a)
/* build compound term with functor f and n
* args a */
{
CELL *t = H;
if (n == 0)
return (MkAtomTerm(NameOfFunctor(f)));
if (f == FunctorList)
return (MkPairTerm(a[0], a[1]));
*H++ = (CELL) f;
while (n--)
*H++ = (CELL) * a++;
return (AbsAppl(t));
}

580
C/parser.c Normal file
View File

@@ -0,0 +1,580 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: parser.c *
* Last rev: *
* mods: *
* comments: Prolog's parser *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* Description:
*
* parser: produces a prolog term from an array of tokens
*
* parser usage: the parser takes its input from an array of token descriptions
* addressed by the global variable 'tokptr' and produces a Term as result. A
* macro 'NextToken' should be defined in 'yap.h' for advancing 'tokptr' from
* one token to the next. In the distributed version this macro also updates
* a variable named 'toktide' for keeping track of how far the parser went
* before failling with a syntax error. The parser should be invoked with
* 'tokptr' pointing to the first token. The last token should have type
* 'eot_tok'. The parser return either a Term. Syntactic errors are signaled
* by a return value 0. The parser builds new terms on the 'global stack' and
* also uses an auxiliary stack pointed to by 'AuxSp'. In the distributed
* version this auxiliary stack is assumed to grow downwards. This
* assumption, however, is only relevant to routine 'ParseArgs', and to the
* variable toktide. conclusion: set tokptr pointing to first token set AuxSp
* Call Parse
*
* VSC: Working whithout known bugs in 87/4/6
*
* LD: -I or +I evaluated by parser 87/4/28
*
* LD: parser extended 87/4/28
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#ifdef __STDC__XXX
#define Volatile volatile
#else
#define Volatile
#endif
STATIC_PROTO(void GNextToken, (void));
STATIC_PROTO(void checkfor, (Term));
STATIC_PROTO(Term ParseArgs, (Atom));
STATIC_PROTO(Term ParseList, (void));
STATIC_PROTO(Term ParseTerm, (int));
/* weak backtraking mechanism based on long_jump */
typedef struct {
jmp_buf JmpBuff;
} JMPBUFF;
static JMPBUFF FailBuff;
#define TRY(S,P) \
{ Volatile JMPBUFF saveenv;\
Volatile TokEntry *saveT=tokptr; \
Volatile CELL *saveH=H;\
Volatile int savecurprio=curprio;\
saveenv=FailBuff;\
if(!setjmp(FailBuff.JmpBuff)) {\
S;\
FailBuff=saveenv;\
P;\
}\
else { FailBuff=saveenv; \
H=saveH; \
curprio = savecurprio; \
tokptr=saveT; \
}\
}\
#define TRY3(S,P,F) \
{ Volatile JMPBUFF saveenv;\
Volatile TokEntry *saveT=tokptr; Volatile CELL *saveH=H;\
saveenv=FailBuff;\
if(!setjmp(FailBuff.JmpBuff)) {\
S;\
FailBuff=saveenv;\
P;\
}\
else { FailBuff=saveenv; H=saveH; tokptr=saveT; F }\
}\
#define FAIL longjmp(FailBuff.JmpBuff,1)
TokEntry *tokptr, *toktide;
VarEntry *VarTable, *AnonVarTable;
VarEntry *
LookupVar(char *var) /* lookup variable in variables table */
{
VarEntry *p;
#ifdef DEBUG
if (Option[4])
YP_fprintf(YP_stderr,"[LookupVar %s]", var);
#endif
if (var[0] != '_' || var[1] != '\0') {
VarEntry **op = &VarTable;
unsigned char *vp = (unsigned char *)var;
CELL hv;
p = VarTable;
HashFunction(vp, hv);
while (p != NULL) {
CELL hpv = p->hv;
if (hv == hpv) {
Int scmp;
if ((scmp = strcmp(var, p->VarRep)) == 0) {
return(p);
} else if (scmp < 0) {
op = &(p->VarLeft);
p = p->VarLeft;
} else {
op = &(p->VarRight);
p = p->VarRight;
}
} else if (hv < hpv) {
op = &(p->VarLeft);
p = p->VarLeft;
} else {
op = &(p->VarRight);
p = p->VarRight;
}
}
p = (VarEntry *) AllocScannerMemory(strlen(var) + sizeof(VarEntry));
*op = p;
p->VarLeft = p->VarRight = NULL;
p->hv = hv;
strcpy(p->VarRep, var);
} else {
/* anon var */
p = (VarEntry *) AllocScannerMemory(sizeof(VarEntry) + 2);
p->VarLeft = AnonVarTable;
AnonVarTable = p;
p->VarRight = NULL;
p->hv = 0L;
p->VarRep[0] = '_';
p->VarRep[1] = '\0';
}
p->VarAdr = TermNil;
return (p);
}
Term
VarNames(VarEntry *p,Term l)
{
if (p != NULL) {
if (strcmp(p->VarRep, "_") != 0) {
Term o = MkPairTerm(MkPairTerm(StringToList(p->VarRep), p->VarAdr),
VarNames(p->VarRight,
VarNames(p->VarLeft,l)));
if (H > ASP-4096) {
longjmp(IOBotch,1);
}
return(o);
} else {
return(VarNames(p->VarRight,VarNames(p->VarLeft,l)));
}
} else {
return (l);
}
}
int
IsPrefixOp(Prop opinfo,int *pptr, int *rpptr)
{
int p;
READ_LOCK(RepOpProp(opinfo)->OpRWLock);
if ((p = RepOpProp(opinfo)->Prefix) != 0) {
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
*pptr = *rpptr = p & MaskPrio;
if (p & DcrrpFlag)
--* rpptr;
return (TRUE);
} else {
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
return (FALSE);
}
}
int
IsInfixOp(Prop opinfo, int *pptr, int *lpptr, int *rpptr)
{
int p;
READ_LOCK(RepOpProp(opinfo)->OpRWLock);
if ((p = RepOpProp(opinfo)->Infix) != 0) {
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
*pptr = *rpptr = *lpptr = p & MaskPrio;
if (p & DcrrpFlag)
--* rpptr;
if (p & DcrlpFlag)
--* lpptr;
return (TRUE);
} else {
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
return (FALSE);
}
}
int
IsPosfixOp(Prop opinfo, int *pptr, int *lpptr)
{
int p;
READ_LOCK(RepOpProp(opinfo)->OpRWLock);
if ((p = RepOpProp(opinfo)->Posfix) != 0) {
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
*pptr = *lpptr = p & MaskPrio;
if (p & DcrlpFlag)
--* lpptr;
return (TRUE);
} else {
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
return (FALSE);
}
}
inline static void
GNextToken(void)
{
if (tokptr->Tok == Ord(eot_tok))
return;
#ifdef EMACS
if ((tokptr = tokptr->TokNext)->TokPos > toktide->TokPos)
toktide = tokptr;
#else
if (tokptr == toktide)
toktide = tokptr = tokptr->TokNext;
else
tokptr = tokptr->TokNext;
#endif
}
inline static void
checkfor(Term c)
{
if (tokptr->Tok != Ord(Ponctuation_tok)
|| tokptr->TokInfo != c)
FAIL;
NextToken;
}
static Term
ParseArgs(Atom a)
{
int nargs = 0;
Term *p, t;
#ifdef SFUNC
SFEntry *pe = (SFEntry *) GetAProp(a, SFProperty);
#endif
NextToken;
p = (Term *) ParserAuxSp;
while (1) {
Term *tp = (Term *)ParserAuxSp;
*tp++ = Unsigned(ParseTerm(999));
ParserAuxSp = (tr_fr_ptr)tp;
++nargs;
if (tokptr->Tok != Ord(Ponctuation_tok))
break;
if (((int) tokptr->TokInfo) != ',')
break;
NextToken;
}
ParserAuxSp = (tr_fr_ptr)p;
/*
* Needed because the arguments for the functor are placed in reverse
* order
*/
#ifdef SFUNC
if (pe)
t = MkSFTerm(MkFunctor(a, SFArity), nargs, p, pe->NilValue);
else
t = MkApplTerm(MkFunctor(a, nargs), nargs, p);
#else
t = MkApplTerm(MkFunctor(a, nargs), nargs, p);
#endif
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
checkfor((Term) ')');
return (t);
}
static Term
ParseList(void)
{
Term t, s;
t = ParseTerm(999);
if (tokptr->Tok == Ord(Ponctuation_tok)) {
if (((int) tokptr->TokInfo) == ',') {
NextToken;
if (tokptr->Tok == Ord(Name_tok)
&& strcmp(RepAtom((Atom)(tokptr->TokInfo))->StrOfAE, "..") == 0) {
NextToken;
s = ParseTerm(999);
} else
s = ParseList();
} else if (((int) tokptr->TokInfo) == '|') {
NextToken;
s = ParseTerm(999);
} else
s = MkAtomTerm(AtomNil);
t = MkPairTerm(t, s);
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
} else
FAIL;
return (t);
}
static Term
ParseTerm(int prio)
{
/* parse term with priority prio */
Volatile Prop opinfo;
Volatile Term t;
Volatile Functor func;
Volatile VarEntry *varinfo;
Volatile int curprio = 0, opprio, oplprio, oprprio;
switch (tokptr->Tok) {
case Name_tok:
t = tokptr->TokInfo;
NextToken;
if ((tokptr->Tok != Ord(Ponctuation_tok)
|| Unsigned(tokptr->TokInfo) != 'l')
&& (opinfo = GetAProp((Atom) t, OpProperty))
&& IsPrefixOp(opinfo, &opprio, &oprprio)
) {
/* special rules apply for +1, -2.3, etc... */
if (tokptr->Tok == Number_tok) {
if ((Atom)t == AtomMinus) {
t = tokptr->TokInfo;
if (IsIntTerm(t))
t = MkIntTerm(-IntOfTerm(t));
else if (IsFloatTerm(t))
t = MkFloatTerm(-FloatOfTerm(t));
#ifdef USE_GMP
else if (IsBigIntTerm(t)) {
MP_INT *new = PreAllocBigNum();
mpz_neg(new, BigIntOfTerm(t));
t = MkBigIntTerm(new);
}
#endif
else
t = MkLongIntTerm(-LongIntOfTerm(t));
NextToken;
break;
} else if ((Atom)t == AtomPlus) {
t = tokptr->TokInfo;
NextToken;
break;
}
}
if (opprio <= prio) {
/* try to parse as a prefix operator */
TRY(
/* build appl on the heap */
func = MkFunctor((Atom) t, 1);
t = ParseTerm(oprprio);
t = MkApplTerm(func, 1, &t);
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
curprio = opprio;
,
break;
)
}
}
if (tokptr->Tok == Ord(Ponctuation_tok)
&& Unsigned(tokptr->TokInfo) == 'l')
t = ParseArgs((Atom) t);
else
t = MkAtomTerm((Atom)t);
break;
case Number_tok:
t = tokptr->TokInfo;
NextToken;
break;
case String_tok: /* build list on the heap */
{
Volatile char *p = (char *) tokptr->TokInfo;
if (*p == 0)
t = MkAtomTerm(AtomNil);
else if (yap_flags[YAP_DOUBLE_QUOTES_FLAG] == STRING_AS_CHARS)
t = StringToListOfAtoms(p);
else if (yap_flags[YAP_DOUBLE_QUOTES_FLAG] == STRING_AS_ATOM)
t = MkAtomTerm(LookupAtom(p));
else
t = StringToList(p);
NextToken;
}
break;
case Var_tok:
varinfo = (VarEntry *) (tokptr->TokInfo);
if ((t = varinfo->VarAdr) == TermNil) {
t = varinfo->VarAdr = MkVarTerm();
}
NextToken;
break;
case Ponctuation_tok:
switch ((int) tokptr->TokInfo) {
case '(':
case 'l': /* non solo ( */
NextToken;
t = ParseTerm(1200);
checkfor((Term) ')');
break;
case '[':
NextToken;
t = ParseList();
checkfor((Term) ']');
break;
case '{':
NextToken;
if (tokptr->Tok == Ord(Ponctuation_tok) &&
Unsigned(tokptr->TokInfo) == '}') {
t = MkAtomTerm(NameOfFunctor(FunctorBraces));
NextToken;
} else {
t = ParseTerm(1200);
t = MkApplTerm(FunctorBraces, 1, &t);
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
checkfor((Term) '}');
}
break;
default:
FAIL;
}
break;
default:
FAIL;
}
/* main loop to parse infix and posfix operators starts here */
while (TRUE) {
if (tokptr->Tok == Ord(Name_tok)
&& (opinfo = GetAProp((Atom)(tokptr->TokInfo), OpProperty))) {
Prop save_opinfo = opinfo;
if (IsInfixOp(opinfo, &opprio, &oplprio, &oprprio)
&& opprio <= prio && oplprio >= curprio) {
/* try parsing as infix operator */
Volatile int oldprio = curprio;
TRY3(
func = MkFunctor((Atom) tokptr->TokInfo, 2);
NextToken;
{
Term args[2];
args[0] = t;
args[1] = ParseTerm(oprprio);
t = MkApplTerm(func, 2, args);
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
},
curprio = opprio;
opinfo = save_opinfo;
continue;
,
opinfo = save_opinfo;
curprio = oldprio;
)
}
if (IsPosfixOp(opinfo, &opprio, &oplprio)
&& opprio <= prio && oplprio >= curprio) {
/* parse as posfix operator */
t = MkApplTerm(MkFunctor((Atom) tokptr->TokInfo, 1), 1, &t);
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
curprio = opprio;
NextToken;
continue;
}
break;
}
if (tokptr->Tok == Ord(Ponctuation_tok)) {
if (Unsigned(tokptr->TokInfo) == ',' &&
prio >= 1000 && curprio <= 999) {
Volatile Term args[2];
NextToken;
args[0] = t;
args[1] = ParseTerm(1000);
t = MkApplTerm(MkFunctor(AtomComma, 2), 2, args);
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
curprio = 1000;
continue;
} else if (Unsigned(tokptr->TokInfo) == '|' && prio >= 1100 &&
curprio <= 1099) {
Volatile Term args[2];
NextToken;
args[0] = t;
args[1] = ParseTerm(1100);
t = MkApplTerm(FunctorVBar, 2, args);
/* check for possible overflow against local stack */
if (H > ASP-4096) {
ErrorMessage = "Stack Overflow";
FAIL;
}
curprio = 1100;
continue;
}
}
if (tokptr->Tok <= Ord(String_tok))
FAIL;
break;
}
return (t);
}
Term
Parse(void)
{
Volatile Term t;
if (!setjmp(FailBuff.JmpBuff)) {
t = ParseTerm(1200);
if (tokptr->Tok != Ord(eot_tok))
return (0L);
return (t);
} else
return (0);
}

2907
C/save.c Normal file
View File

File diff suppressed because it is too large Load Diff

1348
C/scanner.c Normal file
View File

File diff suppressed because it is too large Load Diff

421
C/sort.c Normal file
View File

@@ -0,0 +1,421 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: sort.c *
* Last rev: *
* mods: *
* comments: sorting in Prolog *
* *
*************************************************************************/
/* for the moment, follow Prolog's traditional mergesort */
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#ifndef NULL
#define NULL (void *)0
#endif
/* fill in the even or the odd elements */
#define M_EVEN 0
#define M_ODD 1
STATIC_PROTO(Int build_new_list, (CELL *, Term));
STATIC_PROTO(void simple_mergesort, (CELL *, Int, int));
STATIC_PROTO(Int compact_mergesort, (CELL *, Int, int));
STATIC_PROTO(int key_mergesort, (CELL *, Int, int, Functor));
STATIC_PROTO(void adjust_vector, (CELL *, Int));
STATIC_PROTO(Int p_sort, (void));
STATIC_PROTO(Int p_msort, (void));
STATIC_PROTO(Int p_ksort, (void));
/* copy to a new list of terms */
static Int
build_new_list(CELL *pt, Term t)
{
Int out = 0;
if (IsVarTerm(t))
return(-1);
if (t == TermNil)
return(0);
restart:
while (IsPairTerm(t)) {
out++;
pt[0] = HeadOfTerm(t);
t = TailOfTerm(t);
if (IsVarTerm(t))
return(-1);
if (t == TermNil) {
return(out);
}
pt += 2;
if (pt > ASP - 4096) {
if (!gc(2, ENV, P)) {
Error(SYSTEM_ERROR, TermNil, "YAP could not grow stack in sort/2");
return(FALSE);
}
t = Deref(ARG1);
pt = H;
out = 0;
goto restart;
}
}
return(-1);
}
/* copy to a new list of terms */
static
void simple_mergesort(CELL *pt, Int size, int my_p)
{
if (size > 2) {
Int half_size = size / 2;
CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
int left_p, right_p;
pt_right = pt + half_size*2;
left_p = my_p^1;
right_p = my_p;
simple_mergesort(pt, half_size, left_p);
simple_mergesort(pt_right, size-half_size, right_p);
/* now implement a simple merge routine */
/* pointer to after the end of the list */
end_pt = pt + 2*size;
/* pointer to the element after the last element to the left */
end_pt_left = pt+half_size*2;
/* where is left list */
pt_left = pt+left_p;
/* where is right list */
pt_right += right_p;
/* where is new list */
pt += my_p;
/* while there are elements in the left or right vector do compares */
while (pt_left < end_pt_left && pt_right < end_pt) {
/* if the element to the left is larger than the one to the right */
if (compare_terms(pt_left[0], pt_right[0]) <= 0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
pt_left += 2;
} else {
/* otherwise, copy the one to the right */
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
/* if any elements were left in the left vector just copy them */
while (pt_left < end_pt_left) {
pt[0] = pt_left[0];
pt += 2;
pt_left += 2;
}
/* if any elements were left in the right vector
and they are in the wrong place, just copy them */
if (my_p != right_p) {
while(pt_right < end_pt) {
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
} else {
if (size > 1 && (compare_terms(pt[0],pt[2]) > 0)) {
CELL t = pt[2];
pt[2+my_p] = pt[0];
pt[my_p] = t;
} else if (my_p) {
pt[1] = pt[0];
if (size > 1)
pt[3] = pt[2];
}
}
}
/* copy to a new list of terms */
static
int key_mergesort(CELL *pt, Int size, int my_p, Functor FuncDMinus)
{
if (size > 2) {
Int half_size = size / 2;
CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
int left_p, right_p;
pt_right = pt + half_size*2;
left_p = my_p^1;
right_p = my_p;
if (!key_mergesort(pt, half_size, left_p, FuncDMinus))
return(FALSE);
if (!key_mergesort(pt_right, size-half_size, right_p, FuncDMinus))
return(FALSE);
/* now implement a simple merge routine */
/* pointer to after the end of the list */
end_pt = pt + 2*size;
/* pointer to the element after the last element to the left */
end_pt_left = pt+half_size*2;
/* where is left list */
pt_left = pt+left_p;
/* where is right list */
pt_right += right_p;
/* where is new list */
pt += my_p;
/* while there are elements in the left or right vector do compares */
while (pt_left < end_pt_left && pt_right < end_pt) {
/* if the element to the left is larger than the one to the right */
Term t0 = pt_left[0] , t1 = pt_right[0];
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
return(FALSE);
t0 = ArgOfTerm(1,t0);
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
return(FALSE);
t1 = ArgOfTerm(1,t1);
if (compare_terms(t0, t1) <= 0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
pt_left += 2;
} else {
/* otherwise, copy the one to the right */
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
/* if any elements were left in the left vector just copy them */
while (pt_left < end_pt_left) {
pt[0] = pt_left[0];
pt += 2;
pt_left += 2;
}
/* if any elements were left in the right vector
and they are in the wrong place, just copy them */
if (my_p != right_p) {
while(pt_right < end_pt) {
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
} else {
if (size > 1) {
Term t0 = pt[0], t1 = pt[2];
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
return(FALSE);
t0 = ArgOfTerm(1,t0);
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
return(FALSE);
t1 = ArgOfTerm(1,t1);
if (compare_terms(t0,t1) > 0) {
CELL t = pt[2];
pt[2+my_p] = pt[0];
pt[my_p] = t;
} else if (my_p) {
pt[1] = pt[0];
pt[3] = pt[2];
}
} else {
if (my_p)
pt[1] = pt[0];
}
}
return(TRUE);
}
/* copy to a new list of terms and compress duplicates */
static
Int compact_mergesort(CELL *pt, Int size, int my_p)
{
if (size > 2) {
Int half_size = size / 2;
CELL *pt_left, *pt_right, *end_pt_right, *end_pt_left;
int left_p, right_p;
Int lsize, rsize;
pt_right = pt + half_size*2;
left_p = my_p^1;
right_p = my_p;
lsize = compact_mergesort(pt, half_size, left_p);
rsize = compact_mergesort(pt_right, size-half_size, right_p);
/* now implement a simple merge routine */
/* where is left list */
pt_left = pt+left_p;
/* pointer to the element after the last element to the left */
end_pt_left = pt+2*lsize;
/* where is right list */
pt_right += right_p;
/* pointer to after the end of the list */
end_pt_right = pt_right + 2*rsize;
/* where is new list */
pt += my_p;
size = 0;
/* while there are elements in the left or right vector do compares */
while (pt_left < end_pt_left && pt_right < end_pt_right) {
/* if the element to the left is larger than the one to the right */
Int cmp = compare_terms(pt_left[0], pt_right[0]);
if (cmp < 0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
size ++;
pt_left += 2;
} else if (cmp == 0) {
/* otherwise, just skip one of them, anyone */
pt_left += 2;
} else {
/* otherwise, copy the one to the right */
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
size++;
}
}
/* if any elements were left in the left vector just copy them */
while (pt_left < end_pt_left) {
pt[0] = pt_left[0];
pt += 2;
pt_left += 2;
size++;
}
/* if any elements were left in the right vector
and they are in the wrong place, just copy them */
while(pt_right < end_pt_right) {
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
size++;
}
return(size);
} else if (size == 2) {
Int cmp = compare_terms(pt[0],pt[2]);
if (cmp > 0) {
/* swap */
CELL t = pt[2];
pt[2+my_p] = pt[0];
pt[my_p] = t;
return(2);
} else if (cmp == 0) {
if (my_p)
pt[1] = pt[0];
return(1);
} else {
if (my_p) {
pt[1] = pt[0];
pt[3] = pt[2];
}
return(2);
}
} else {
/* size = 1 */
if (my_p)
pt[1] = pt[0];
return(1);
}
}
static void
adjust_vector(CELL *pt, Int size)
{
/* the elements are where they should be */
CELL *ptf = pt + 2*(size-1);
pt ++;
while (pt < ptf) {
pt[0] = AbsPair(pt+1);
pt += 2;
}
/* close the list */
pt[0] = TermNil;
}
static Int
p_sort(void)
{
/* use the heap to build a new list */
CELL *pt = H;
Term out;
/* list size */
Int size;
size = build_new_list(pt, Deref(ARG1));
if (size < 0)
return(FALSE);
if (size < 2)
return(unify(ARG1, ARG2));
pt = H; /* because of possible garbage collection */
/* make sure no one writes on our temp data structure */
H += size*2;
/* reserve the necessary space */
size = compact_mergesort(pt, size, M_EVEN);
/* reajust space */
H = pt+size*2;
adjust_vector(pt, size);
out = AbsPair(pt);
return(unify(out, ARG2));
}
static Int
p_msort(void)
{
/* use the heap to build a new list */
CELL *pt = H;
Term out;
/* list size */
Int size;
size = build_new_list(pt, Deref(ARG1));
if (size < 0)
return(FALSE);
if (size < 2)
return(unify(ARG1, ARG2));
pt = H; /* because of possible garbage collection */
/* reserve the necessary space */
H += size*2;
simple_mergesort(pt, size, M_EVEN);
adjust_vector(pt, size);
out = AbsPair(pt);
return(unify(out, ARG2));
}
static Int
p_ksort(void)
{
/* use the heap to build a new list */
CELL *pt = H;
Term out;
/* list size */
Int size;
size = build_new_list(pt, Deref(ARG1));
if (size < 0)
return(FALSE);
if (size < 2)
return(unify(ARG1, ARG2));
/* reserve the necessary space */
pt = H; /* because of possible garbage collection */
H += size*2;
if (!key_mergesort(pt, size, M_EVEN, MkFunctor(AtomMinus,2)))
return(FALSE);
adjust_vector(pt, size);
out = AbsPair(pt);
return(unify(out, ARG2));
}
void
InitSortPreds(void)
{
InitCPred("$sort", 2, p_sort, 0);
InitCPred("$msort", 2, p_msort, 0);
InitCPred("$keysort", 2, p_ksort, 0);
}

2247
C/stdpreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

2021
C/sysbits.c Normal file
View File

File diff suppressed because it is too large Load Diff

236
C/tracer.c Normal file
View File

@@ -0,0 +1,236 @@
/*************************************************************************
* *
* YAP Prolog @(#)amidefs.h 1.3 3/15/90
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: tracer.h *
* Last rev: *
* mods: *
* comments: definitions for low level tracer *
* *
*************************************************************************/
#include "Yap.h"
#ifdef LOW_LEVEL_TRACER
#include "Yatom.h"
#include "yapio.h"
#include "tracer.h"
STATIC_PROTO(int TracePutchar, (int, int));
STATIC_PROTO(void send_tracer_message, (char *, char *, Int, char *, CELL *));
int do_low_level_trace = FALSE;
static int do_trace_primitives = TRUE;
int
TracePutchar(int sno, int ch)
{
return(YP_putc(ch, stderr)); /* use standard error stream, which is supposed to be 2*/
}
static void
send_tracer_message(char *start, char *name, Int arity, char *mname, CELL *args)
{
if (name == NULL) {
#ifdef YAPOR
#ifdef DEPTH_LIMIT
YP_fprintf(YP_stderr, "(%d)%s (D:%d)", worker_id, start, (CELL)IntegerOfTerm(DEPTH)/2);
#else
YP_fprintf(YP_stderr, "(%d)%s", worker_id, start);
#endif
#else
#ifdef DEPTH_LIMIT
YP_fprintf(YP_stderr, "%s (D:%d)", start, (CELL)IntegerOfTerm(DEPTH)/2);
#else
YP_fprintf(YP_stderr, "%s", start);
#endif
#endif
} else {
int i;
if (arity) {
#ifdef DEPTH_LIMIT
YP_fprintf(YP_stderr, "%s (D:%d) %s:%s(", start, (CELL)IntegerOfTerm(DEPTH)/2, mname, name);
#else
YP_fprintf(YP_stderr, "%s %s:%s(", start, mname, name);
#endif
} else {
#ifdef DEPTH_LIMIT
YP_fprintf(YP_stderr, "%s (D:%d) %s:%s", start, (CELL)IntegerOfTerm(DEPTH)/2, mname, name);
#else
YP_fprintf(YP_stderr, "%s %s:%s", start, mname, name);
#endif
}
for (i= 0; i < arity; i++) {
if (i > 0) YP_fprintf(YP_stderr, ",");
#if DEBUG
#if COROUTINING
Portray_delays = TRUE;
#endif
#endif
plwrite(args[i], TracePutchar, 4);
#if DEBUG
#if COROUTINING
Portray_delays = FALSE;
#endif
#endif
}
if (arity) YP_fprintf(YP_stderr, ")");
}
YP_fprintf(YP_stderr, "\n");
}
unsigned long vsc_count;
/*
static int
check_trail_consistency(void) {
tr_fr_ptr ptr = TR;
while (ptr > (CELL *)TrailBase) {
ptr = --ptr;
if (!IsVarTerm(TrailTerm(ptr))) {
if (IsApplTerm(TrailTerm(ptr))) {
CELL *cptr = (CELL *)ptr;
ptr = (tr_fr_ptr)(cptr-1);
} else {
if (IsPairTerm(TrailTerm(ptr))) {
CELL *p = RepPair(TrailTerm(ptr));
if (p < H0) continue;
}
printf("Oops at call %ld, B->cp(%p) TR(%p) pt(%p)\n", vsc_count,B->cp_tr, TR, ptr);
return(FALSE);
}
}
}
return(TRUE);
}
*/
void
low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
{
char *s;
char *mname;
Int arity;
extern int gc_calls;
vsc_count++;
/* if (vsc_count < 420430) return; */
/* if (vsc_count > 500000) exit(0); */
/* if (gc_calls < 1) return;*/
YP_fprintf(YP_stderr,"%lu ",vsc_count);
/* check_trail_consistency(); */
if (pred == NULL) {
return;
}
if (pred->ModuleOfPred == 0 && !do_trace_primitives) {
return;
}
switch (port) {
case enter_pred:
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0) {
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
} else {
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
}
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("CALL: ", s, arity, mname, args);
break;
case try_or:
send_tracer_message("TRY_OR ", NULL, 0, NULL, args);
break;
case retry_or:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
send_tracer_message("RETRY_OR ", NULL, 0, NULL, args);
break;
case retry_table_producer:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
/* HANDLE METACALLS */
if (pred == NULL) {
send_tracer_message("RETRY TABLE: ", NULL, 0, NULL, args);
} else {
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0) {
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
} else {
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
}
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("RETRY PRODUCER: ", s, 0, mname, NULL);
}
break;
case retry_table_consumer:
send_tracer_message("FAIL ", NULL, 0, NULL, args);
/* HANDLE METACALLS */
if (pred == NULL) {
send_tracer_message("RETRY TABLE: ", NULL, 0, NULL, args);
} else {
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0) {
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
} else {
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
}
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("RETRY CONSUMER: ", s, 0, mname, NULL);
}
break;
case retry_pred:
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0) {
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
} else {
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
}
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("FAIL ", NULL, 0, NULL, args);
send_tracer_message("RETRY: ", s, arity, mname, args);
break;
}
}
void
toggle_low_level_trace(void)
{
do_low_level_trace = !do_low_level_trace;
}
static Int p_start_low_level_trace(void)
{
do_low_level_trace = TRUE;
return(TRUE);
}
static Int p_stop_low_level_trace(void)
{
do_low_level_trace = FALSE;
do_trace_primitives = TRUE;
return(TRUE);
}
void
InitLowLevelTrace(void)
{
InitCPred("start_low_level_trace", 0, p_start_low_level_trace, SafePredFlag);
InitCPred("stop_low_level_trace", 0, p_stop_low_level_trace, SafePredFlag);
}
#endif

1744
C/unify.c Normal file
View File

File diff suppressed because it is too large Load Diff

352
C/unifyi.c Normal file
View File

@@ -0,0 +1,352 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: unify.c *
* Last rev: *
* mods: *
* comments: Unification and other auxiliary routines for absmi *
* *
*************************************************************************/
int
IUnify_complex(register CELL *pt0, register CELL *pt0_end,
register CELL *pt1
)
{
#if SHADOW_REGS
#if defined(B) || defined(TR)
register REGSTORE *regp = &REGS;
#define REGS (*regp)
#endif /* defined(B) || defined(TR) || defined(HB) */
#endif
#if SHADOW_HB
register CELL *HBREG = HB;
#endif /* SHADOW_HB */
CELL **to_visit = (CELL **)H;
loop:
while (pt0 < pt0_end) {
register CELL *ptd0 = pt0+1;
register CELL d0;
++pt1;
pt0 = ptd0;
d0 = *ptd0;
deref_head(d0, unify_comp_unk);
unify_comp_nvar:
{
register CELL *ptd1 = pt1;
register CELL d1 = *ptd1;
deref_head(d1, unify_comp_nvar_unk);
unify_comp_nvar_nvar:
if (d0 == d1)
continue;
if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
goto cufail;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
if (pt0 < pt1) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)d0;
to_visit += 4;
*pt0 = d1;
}
else {
to_visit[0] = pt1;
to_visit[1] = pt1+(pt0_end-pt0);
to_visit[2] = pt0;
to_visit[3] = (CELL *)d1;
to_visit += 4;
*pt1 = d0;
}
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
pt0_end = (pt0 = RepPair(d0) - 1) + 2;
pt1 = RepPair(d1) - 1;
continue;
}
if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
if (!IsApplTerm(d1)) {
goto cufail;
}
/* store the terms to visit */
ap2 = RepAppl(d0);
ap3 = RepAppl(d1);
f = (Functor) (*ap2);
/* compare functors */
if (f != (Functor) *ap3)
goto cufail;
if (IsExtensionFunctor(f)) {
if (unify_extension(f, d0, ap2, d1))
continue;
goto cufail;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
if (pt0 < pt1) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)d0;
to_visit += 4;
*pt0 = d1;
}
else {
to_visit[0] = pt1;
to_visit[1] = pt1+(pt0_end-pt0);
to_visit[2] = pt0;
to_visit[3] = (CELL *)d1;
to_visit += 4;
*pt1 = d0;
}
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
}
goto cufail;
derefa_body(d1, ptd1, unify_comp_nvar_unk, unify_comp_nvar_nvar);
/* d1 and pt2 have the unbound value, whereas d0 is bound */
Bind_Global(ptd1, d0, bind_unify1);
#ifdef COROUTINING
DO_TRAIL(ptd1, d0);
if (ptd1 < H0) WakeUp(ptd1);
bind_unify1:
#endif
continue;
}
derefa_body(d0, ptd0, unify_comp_unk, unify_comp_nvar);
{
register CELL d1;
register CELL *ptd1;
d1 = pt1[0];
/* pt2 is unbound */
ptd1 = pt1;
deref_head(d1, unify_comp_var_unk);
unify_comp_var_nvar:
/* pt2 is unbound and d1 is bound */
Bind_Global(ptd0, d1, bind_unify2);
#ifdef COROUTINING
DO_TRAIL(ptd0, d1);
if (ptd0 < H0) WakeUp(ptd0);
bind_unify2:
#endif
continue;
{
derefa_body(d1, ptd1, unify_comp_var_unk, unify_comp_var_nvar);
/* ptd0 and ptd1 are unbound */
UnifyGlobalCells(ptd0, ptd1, ugc1, ugc2);
#ifdef COROUTINING
DO_TRAIL(ptd0, (CELL)ptd1);
if (ptd0 < H0) WakeUp(ptd0);
ugc1:
#endif
continue;
#ifdef COROUTINING
ugc2:
DO_TRAIL(ptd1, (CELL)ptd0);
if (ptd1 < H0) WakeUp(ptd1);
continue;
#endif
}
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **) H) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
#endif
goto loop;
}
return (TRUE);
cufail:
#ifdef RATIONAL_TREES
/* failure */
while (to_visit > (CELL **) H) {
CELL *pt0;
to_visit -= 4;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[3];
}
#endif
return (FALSE);
#if SHADOW_REGS
#if defined(B) || defined(TR)
#undef REGS
#endif /* defined(B) || defined(TR) */
#endif
}
int
IUnify(register CELL d0, register CELL d1)
{
#if SHADOW_REGS
#if defined(B) || defined(TR)
register REGSTORE *regp = &REGS;
#define REGS (*regp)
#endif /* defined(B) || defined(TR) */
#endif
#if SHADOW_HB
register CELL *HBREG = HB;
#endif
register CELL *pt0, *pt1;
deref_head(d0, unify_unk);
unify_nvar:
/* d0 is bound */
deref_head(d1, unify_nvar_unk);
unify_nvar_nvar:
/* both arguments are bound */
if (d0 == d1)
return (TRUE);
if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
return (FALSE);
}
pt0 = RepPair(d0);
pt1 = RepPair(d1);
return (IUnify_complex(pt0 - 1, pt0 + 1, pt1 - 1));
}
else if (IsApplTerm(d0)) {
pt0 = RepAppl(d0);
d0 = *pt0;
if (!IsApplTerm(d1))
return (FALSE);
pt1 = RepAppl(d1);
d1 = *pt1;
if (d0 != d1) {
return (FALSE);
} else {
if (IsExtensionFunctor((Functor)d0)) {
switch(d0) {
case (CELL)FunctorDBRef:
return(pt0 == pt1);
case (CELL)FunctorLongInt:
return(pt0[1] == pt1[1]);
case (CELL)FunctorDouble:
return(FloatOfTerm(AbsAppl(pt0)) == FloatOfTerm(AbsAppl(pt1)));
#ifdef USE_GMP
case (CELL)FunctorBigInt:
return(mpz_cmp(BigIntOfTerm(AbsAppl(pt0)),BigIntOfTerm(AbsAppl(pt0))) == 0);
#endif /* USE_GMP */
default:
return(FALSE);
}
}
return (IUnify_complex(pt0, pt0 + ArityOfFunctor((Functor) d0),
pt1));
}
} else {
return (FALSE);
}
deref_body(d1, pt1, unify_nvar_unk, unify_nvar_nvar);
/* d0 is bound and d1 is unbound */
Bind(pt1, d0, bind_unify3);
#ifdef COROUTINING
DO_TRAIL(pt1, d0);
if (pt1 < H0) WakeUp(pt1);
bind_unify3:
#endif
return (TRUE);
deref_body(d0, pt0, unify_unk, unify_nvar);
/* pt0 is unbound */
deref_head(d1, unify_var_unk);
unify_var_nvar:
/* pt0 is unbound and d1 is bound */
Bind(pt0, d1, bind_unify4);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) WakeUp(pt0);
bind_unify4:
#endif
return (TRUE);
#if TRAILING_REQUIRES_BRANCH
unify_var_nvar_trail:
DO_TRAIL(pt0);
return (TRUE);
#endif
deref_body(d1, pt1, unify_var_unk, unify_var_nvar);
/* d0 and pt1 are unbound */
UnifyCells(pt0, pt1, uc1, uc2);
#ifdef COROUTINING
DO_TRAIL(pt0, (CELL)pt1);
if (pt0 < H0) WakeUp(pt0);
uc1:
#endif
return (TRUE);
#ifdef COROUTINING
uc2:
DO_TRAIL(pt1, (CELL)pt0);
if (pt1 < H0) {
WakeUp(pt1);
}
return (TRUE);
#endif
#if SHADOW_REGS
#if defined(B) || defined(TR)
#undef REGS
#endif /* defined(B) || defined(TR) */
#endif
}

734
C/userpreds.c Normal file
View File

@@ -0,0 +1,734 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: userpreds.c *
* Last rev: *
* mods: *
* comments: an entry for user defined predicates *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/*
* This file is an entry for user defined C-predicates.
*
* There are two sorts of C-Predicates: deterministic - which should be defined
* in the function InitUserCPreds().
*
* backtrackable - they include a start and a continuation function, the first
* one called by the first invocation, the last one called after a fail. This
* can be seen as: pred :- init ; repeat, cont. These predicates should be
* defined in the function InitUserBacks()
*
* These two functions are called after any "restore" operation.
*
* The function InitUserExtensions() is called once, when starting the execution
* of the program, and should be used to initialize any user-defined
* extensions (like the execution environment or interfaces to other
* programs).
*
*/
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#if EUROTRA
#include "yapio.h"
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#endif
/* You should include here the prototypes for all static functions */
#ifdef EUROTRA
STATIC_PROTO(int p_clean, (void));
STATIC_PROTO(int p_namelength, (void));
STATIC_PROTO(int p_getpid, (void));
STATIC_PROTO(int p_exit, (void));
STATIC_PROTO(int p_incrcounter, (void));
STATIC_PROTO(int p_setcounter, (void));
STATIC_PROTO(int p_trapsignal, (void));
STATIC_PROTO(int subsumes, (Term, Term));
STATIC_PROTO(int p_subsumes, (void));
STATIC_PROTO(int p_grab_tokens, (void));
/* int PlGetchar(Int *); */
#endif
#ifdef MACYAP
STATIC_PROTO(typedef int, (*SignalProc) ());
STATIC_PROTO(SignalProc skel_signal, (int, SignalProc));
STATIC_PROTO(int chdir, (char *));
#endif
#ifdef SFUNC
STATIC_PROTO(int p_softfunctor, (void));
#endif /* SFUNC */
#ifdef USERPREDS
/* These are some examples of user-defined functions */
/*
* unify(A,B) --> unification with occurs-check it uses the functions
* full_unification and occurs_in
*
* occurs_check(V,S) :- var(S), !, S \== V. occurs_check(V,S) :- primitive(S),
* !. occurs_check(V,[H|T]) :- !, occurs_check(V,H), occurs_check(V,T).
* occurs_check(V,St) :- functor(T,_,N), occurs_check_struct(N,V,St).
*
* occurs_check_struct(1,V,T) :- !, arg(1,T,A), occurs_check(V,A).
* occurs_check_struct(N,V,T) :- N1 is N-1, occurs_check_structure(N1,V,T),
* arg(N,T,A), occurs_check(V,A).
*
* unify(X,Y) :- var(X), var(Y), !, X = Y. unify(X,Y) :- var(X), !,
* occurs_check(X,Y), X = Y. unify(X,Y) :- var(Y), !, occurs_check(Y,X), X =
* Y. unify([H0|T0],[H1|T1]) :- !, unify(H0,H1), unify(T0,T1). unify(X,Y) :-
* functor(X,A,N), functor(Y,A,N), unify_structs(N,X,Y).
*
* unify_structs(1,X,Y) :- !, arg(1,X,A), arg(1,Y,B), unify(A,B).
* unify_structs(N,Y,Z) :- N1 is N-1, unify_structs(N1,X,Y), arg(N,X,A),
* arg(N,Y,B), unify(A,B).
*/
/* occurs-in --> checks if the variable V occurs in term S */
static int
occurs_check(V, T)
Term V, T;
{
/* V and S are always derefed */
if (IsVarTerm(T)) {
return (V != T);
} else if (IsPrimitiveTerm(T)) {
return (TRUE);
} else if (IsPairTerm(T)) {
return (occurs_check(V, HeadOfTerm(T))
&& occurs_check(V, TailOfTerm(T)));
} else if (IsApplTerm(T)) {
unsigned int i;
unsigned int arity = ArityOfFunctor(FunctorOfTerm(T));
for (i = 1; i <= arity; ++i)
if (!occurs_check(V, ArgOfTerm(i, T)))
return (FALSE);
return (TRUE);
}
return (FALSE);
}
/*
If you worry about coroutining the routine must receive the
arguments before dereferencing, otherwise unify() won't be
to wake possible bound variables
*/
static int
full_unification(T1, T2)
Term T1, T2;
{
Term t1 = Deref(T1);
Term t2 = Deref(T2);
if (IsVarTerm(t1)) { /* Testing for variables should be done first */
if (IsVarTerm(t2) || IsPrimitiveTerm(t2))
return (unify(T1, t2));
if (occurs_check(t1, t2))
return (unify(T1, t2));
return (FALSE);
}
if (IsVarTerm(t2)) {
if (occurs_check(t2, t1))
return (unify(T2, t1));
return (FALSE);
}
if (IsPrimitiveTerm(t1)) {
if (IsFloatTerm(t1))
return(IsFloatTerm(t2) && FloatOfTerm(t1) == FloatOfTerm(t2));
else if (IsRefTerm(t1))
return(IsRefTerm(t2) && RefOfTerm(t1) == RefOfTerm(t2));
if (IsLongIntTerm(t1))
return(IsLongIntTerm(t2) && LongIntOfTerm(t1) == LongIntOfTerm(t2));
else
return (t1 == t2);
}
if (IsPairTerm(t1)) {
if (!IsPairTerm(t2))
return (FALSE);
return (full_unification(HeadOfTermCell(t1), HeadOfTermCell(t2)) &&
full_unification(TailOfTermCell(t1), TailOfTermCell(t2)));
}
if (IsApplTerm(t1)) {
unsigned int i, arity;
if (!IsApplTerm(t2))
return (FALSE);
if (FunctorOfTerm(t1) != FunctorOfTerm(t2))
return (FALSE);
arity = ArityOfFunctor(FunctorOfTerm(t1));
for (i = 1; i <= arity; ++i)
if (!full_unification(ArgOfTermCell(i, t1), ArgOfTerm(i, t2)))
return (FALSE);
return (TRUE);
}
#ifdef lint
return (FALSE);
#endif
}
static int
p_occurs_check()
{ /* occurs_check(?,?) */
return (occurs_check(Deref(ARG1), Deref(DARG2)));
}
/* Out of date, use unify_with_occurs_check instead*/
static int
p_unify()
{ /* unify(?,?) */
/* routines that perform unification must receive the original arguments */
return (full_unification(ARG1, ARG2));
}
/*
* One example of a counter using the atom value functions counter(Atom,M,N)
*
* If the second argument is uninstantiated, then it will be unified with the
* current value of the counter, otherwyse the counter will be set to its
* value. The third argument then be unified with the next integer, which
* will become the current counter value.
*/
static int
p_counter()
{ /* counter(+Atom,?Number,?Next) */
Term TCount, TNext, T1, T2;
Atom a;
/* Int -> an YAP integer */
Int val;
T1 = Deref(ARG1);
ARG2 = Deref(ARG2);
/* No need to deref ARG3, we don't want to know what's in there */
if (IsVarTerm(T1) || !IsAtomTerm(T1))
return (FALSE);
a = AtomOfTerm(T1);
if (IsVarTerm(T2)) {
TCount = GetValue(a);
if (!IsIntTerm(TCount))
return (FALSE);
unify_constant(ARG2, TCount); /* always succeeds */
val = IntOfTerm(TCount);
} else {
if (!IsIntTerm(T2))
return (FALSE);
val = IntOfTerm(T2);
}
val++;
/* The atom will now take the incremented value */
PutValue(a, TNext = MkIntTerm(val));
return (unify_constant(ARG3, TNext));
}
/*
* Concatenate an instantiated list to another list, and unify with third
* argument
*/
/*
* In order to be more efficient, iconcat instead of unifying the terms in
* the old structure with the ones in the new one just copies them. This is a
* dangerous behaviour, though acceptable in this case, and you should try to
* avoid it whenever possible
*/
#ifdef COMMENT
static int
p_iconcat()
{ /* iconcat(+L1,+L2,-L) */
Term Tkeep[1025]; /* Will do it just for lists less
* than 1024 elements long */
register Term *Tkp = Tkeep;
register Term L0, L1;
Term T2;
L0 = Deref(ARG1);
*Tkp++ = Unsigned(0);
L1 = TermNil;
while (L0 != L1) {
/*
* Usually you should test if L1 a var, if (!IsPairTerm(L0))
* return(FALSE);
*/
*Tkp++ = HeadOfTerm(L0);
L0 = TailOfTerm(L0);
}
L1 = Deref(ARG2);
while (L0 = *--Tkp)
L1 = MkPairTerm(L0, L1);
T2 = L1;
return (unify(T2, ARG3));
}
#endif /* COMMENT */
static int
p_iconcat()
{ /* iconcat(+L1,+L2,-L) */
register Term *Tkp = H, *tp;
register Term L0, L1;
Term T2;
L0 = Deref(ARG1);
L1 = TermNil;
while (L0 != L1) {
/* if (!IsPairTerm(L0)) return(FALSE); */
tp = Tkp;
*tp = AbsPair(++Tkp);
*Tkp++ = HeadOfTerm(L0);
L0 = TailOfTerm(L0);
}
*Tkp++ = Deref(ARG2);
T2 = *H;
H = Tkp;
return (unify(T2, ARG3));
}
#endif /* USERPREDS */
#ifdef EUROTRA
static int
p_clean() /* predicate clean for ets */
/*
* clean(FB,CFB) :- FB =.. [fb|L],!, clean1(L,CL), CFB =.. [fb|CL].
* clean(FB,CFB) :- var(FB).
*
* clean1([],[]) :- !. clean1([H|T],[CH|CT]) :- H==$u,!, clean1(T,CT).
* clean1([H|T],[H|CT]) :- clean1(T,CT).
*/
{
unsigned int arity, i;
Term t, Args[255];
Term t1 = Deref(ARG1);
if (IsVarTerm(t1))
return (TRUE);
if (!(IsApplTerm(t1)
&& NameOfFunctor(FunctorOfTerm(t1)) == AtomFB))
return (FALSE);
arity = ArityOfFunctor(FunctorOfTerm(t1));
#ifdef SFUNC
if (arity == SFArity) {
CELL *pt = H, *ntp = ArgsOfSFTerm(t1);
Term tn = AbsAppl(H);
*pt++ = FunctorOfTerm(t1);
RESET_VARIABLE(pt);
pt++;
while (*pt++ = *ntp++)
if ((*pt++ = *ntp++) == MkAtomTerm(AtomDollarUndef))
pt -= 2;
H = pt;
return (unify(tn, ARG2));
}
#endif
for (i = 1; i <= arity; ++i) {
if ((t = ArgOfTerm(i, t1)) == TermDollarU)
t = MkVarTerm();
Args[i - 1] = t;
}
t = MkApplTerm(FunctorOfTerm(t1), arity, Args);
return (unify(ARG2, t));
}
static Term *subs_table;
static int subs_entries;
#define SUBS_TABLE_SIZE 500
static int
subsumes(T1, T2)
Term T1, T2;
{
int i;
if (IsVarTerm(T1)) {
if (!IsVarTerm(T2))
return (FALSE);
if (T1 == T2)
return (TRUE);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T2)
return (FALSE);
if (T2 < T1) { /* T1 gets instantiated with T2 */
unify(T1, T2);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T1) {
subs_table[i] = T2;
return (TRUE);
}
subs_table[subs_entries++] = T2;
return (TRUE);
}
/* T2 gets instantiated with T1 */
unify(T1, T2);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T1)
return (TRUE);
subs_table[subs_entries++] = T1;
return (TRUE);
}
if (IsVarTerm(T2)) {
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == T2)
return (FALSE);
return (unify(T1, T2));
}
if (IsPrimitiveTerm(T1)) {
if (IsFloatTerm(T1))
return(IsFloatTerm(T2) && FloatOfTerm(T1) == FloatOfTerm(T2));
else if (IsRefTerm(T1))
return(IsRefTerm(T2) && RefOfTerm(T1) == RefOfTerm(T2));
else if (IsLongIntTerm(T1))
return(IsLongIntTerm(T2) && LongIntOfTerm(T1) == LongIntOfTerm(T2));
else
return (T1 == T2);
}
if (IsPairTerm(T1)) {
if (!IsPairTerm(T2))
return (FALSE);
return (subsumes(HeadOfTerm(T1), HeadOfTerm(T2)) &&
subsumes(TailOfTerm(T1), TailOfTerm(T2)));
}
if (IsApplTerm(T1)) {
int arity;
if (!IsApplTerm(T2))
return (FALSE);
if (FunctorOfTerm(T1) != FunctorOfTerm(T2))
return (FALSE);
arity = ArityOfFunctor(FunctorOfTerm(T1));
#ifdef SFUNC
if (arity == SFArity) {
CELL *a1a = ArgsOfSFTerm(T1), *a2a = ArgsOfSFTerm(T2);
CELL *a1p = a1a - 1, *a2p = a2a - 1;
CELL *pt = H;
int flags = 0;
Term t1, t2;
*pt++ = FunctorOfTerm(T1);
RESET_VARIABLE(pt);
pt++;
while (1) {
if (*a2a < *a1a || *a1a == 0) {
if (*a2a) {
*pt++ = *a2a++;
t2 = Derefa(a2a);
++a2a;
if (!IsVarTerm(t2))
return (FALSE);
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == t2)
return (FALSE);
subs_table[subs_entries++] = t2;
*pt++ = t2;
flags |= 1;
} else { /* T2 is finished */
if ((flags & 1) == 0) { /* containned in first */
*a2p = Unsigned(a1p - 1);
if (a2p < HB)
*TR++ = Unsigned(a2p);
return (TRUE);
}
while ((*pt++ = *a1a++));
*a1p = Unsigned(H);
if (a1p < HB)
*TR++ = Unsigned(a1p);
*a2p = Unsigned(H);
if (a2p < HB)
*TR++ = Unsigned(a2p);
H = pt;
return (TRUE);
}
} else if (*a2a > *a1a || *a2a == 0) {
*pt++ = *a1a++;
t1 = Derefa(a1a);
++a1a;
if (IsVarTerm(t1)) {
for (i = 0; i < subs_entries; ++i)
if (subs_table[i] == t1)
break;
if (i >= subs_entries)
subs_table[subs_entries++] = t1;
}
*pt++ = t1;
flags |= 2;
} else if (*a1a == *a2a) {
*pt++ = *a1a++;
++a2a;
t1 = Derefa(a1a);
++a1a;
t2 = Derefa(a2a);
++a2a;
*pt++ = t1;
if (!subsumes(t1, t2))
return (FALSE);
}
}
}
#endif
for (i = 1; i <= arity; ++i)
if (!subsumes(ArgOfTerm(i, T1), ArgOfTerm(i, T2)))
return (FALSE);
return (TRUE);
}
return (FALSE);
}
static int
p_subsumes()
{
Term work_space[SUBS_TABLE_SIZE];
subs_table = work_space;
subs_entries = 0;
return (subsumes(Deref(ARG1), Deref(ARG2)));
}
static int
p_namelength()
{
register Term t = Deref(ARG1);
Term tf;
if (IsVarTerm(t)) {
return (FALSE);
}
if (IsAtomTerm(t)) {
Term tf = MkIntTerm(strlen(RepAtom(AtomOfTerm(t))->StrOfAE));
return (unify_constant(ARG2, tf));
} else if (IsIntTerm(t)) {
register int i = 1, k = IntOfTerm(t);
if (k < 0)
++i, k = -k;
while (k > 10)
++i, k /= 10;
tf = MkIntTerm(i);
return (unify_constant(ARG2, tf));
} else
return (FALSE);
}
static int
p_getpid()
{
#ifndef MPW
Term t = MkIntTerm(getpid());
#else
Term t = MkIntTerm(1);
#endif
return (unify_constant(ARG1, t));
}
static int
p_exit()
{
register Term t = Deref(ARG1);
if (IsVarTerm(t) || !IsIntTerm(t))
return (FALSE);
exit_yap((int) IntOfTerm(t), NIL);
return(FALSE);
}
static int current_pos;
static int
p_incrcounter()
{
register Term t = Deref(ARG1);
if (IsVarTerm(t) || !IsIntTerm(t))
return (FALSE);
current_pos += IntOfTerm(t);
return (TRUE);
}
static int
p_setcounter()
{
register Term t = Deref(ARG1);
if (IsVarTerm(t) || !IsIntTerm(t)) {
return (unify_constant(ARG1, MkIntTerm(current_pos)));
} else {
current_pos = IntOfTerm(t);
return (TRUE);
}
}
#include <signal.h>
#ifdef MACYAP
#define signal(A,B) skel_signal(A,B)
#endif
#ifndef EOF
#define EOF -1
#endif
static int
p_trapsignal(void)
{
#ifndef MPW
signal(SIGINT, SIG_IGN);
#endif
return (TRUE);
}
#define varstarter(ch) ((ch>='A' && ch<='Z') || ch=='_')
#define idstarter(ch) (ch>='a' && ch<='z')
#define idchar(ch) ((ch>='0' && ch<='9') || (ch>='A' && ch<='Z') || \
(ch>='a' && ch<='z') || ch=='_')
static int
p_grab_tokens()
{
Term *p = ASP - 20, *p0, t;
Atom IdAtom, VarAtom;
Functor IdFunctor, VarFunctor;
char ch, IdChars[255], *chp;
IdAtom = LookupAtom("id");
IdFunctor = MkFunctor(IdAtom, 1);
VarAtom = LookupAtom("var");
VarFunctor = MkFunctor(VarAtom, 1);
p0 = p;
ch = PlGetchar();
while (1) {
while (ch <= ' ' && ch != EOF)
ch = PlGetchar();
if (ch == '.' || ch == EOF)
break;
if (ch == '%') {
while ((ch = PlGetchar()) != 10);
ch = PlGetchar();
continue;
}
if (ch == '\'') {
chp = IdChars;
while (1) {
ch = PlGetchar();
if (ch == '\'')
break;
*chp++ = ch;
}
*chp = 0;
t = MkAtomTerm(LookupAtom(IdChars));
*p-- = MkApplTerm(IdFunctor, 1, &t);
ch = PlGetchar();
continue;
}
if (varstarter(ch)) {
chp = IdChars;
*chp++ = ch;
while (1) {
ch = PlGetchar();
if (!idchar(ch))
break;
*chp++ = ch;
}
*chp = 0;
t = MkAtomTerm(LookupAtom(IdChars));
*p-- = MkApplTerm(VarFunctor, 1, &t);
continue;
}
if (idstarter(ch)) {
chp = IdChars;
*chp++ = ch;
while (1) {
ch = PlGetchar();
if (!idchar(ch))
break;
*chp++ = ch;
}
*chp = 0;
t = MkAtomTerm(LookupAtom(IdChars));
*p-- = MkApplTerm(IdFunctor, 1, &t);
continue;
}
IdChars[0] = ch;
IdChars[1] = 0;
*p-- = MkAtomTerm(LookupAtom(IdChars));
ch = PlGetchar();
}
t = MkAtomTerm(AtomNil);
while (p != p0) {
t = MkPairTerm(*++p, t);
}
return (unify(ARG1, t));
}
#endif /* EUROTRA */
#ifdef SFUNC
static
p_softfunctor()
{
Term nilvalue = 0;
SFEntry *pe;
Prop p0;
Atom a;
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
if (IsAtomTerm(t2))
nilvalue = t2;
if (!IsAtomTerm(t1))
return (FALSE);
a = AtomOfTerm(t1);
WRITE_LOCK(RepAtom(a)->ARWLock);
if ((p0 = GetAProp(a, SFProperty)) == NIL) {
pe = (SFEntry *) AllocAtomSpace(sizeof(*pe));
pe->NextOfPE = RepAtom(a)->PropOfAE;
pe->KindOfPE = SFProperty;
RepAtom(a)->PropOfAE = AbsSFProp(pe);
} else
pe = RepSFProp(p0);
WRITE_UNLOCK(RepAtom(a)->ARWLock);
pe->NilValue = nilvalue;
return (TRUE);
}
#endif /* SFUNC */
void
InitUserCPreds(void)
{
#ifdef XINTERFACE
InitXPreds();
#endif
#ifdef EUROTRA
InitCPred("clean", 2, p_clean, SafePredFlag|SyncPredFlag);
InitCPred("name_length", 2, p_namelength, SafePredFlag|SyncPredFlag);
InitCPred("get_pid", 1, p_getpid, SafePredFlag);
InitCPred("exit", 1, p_exit, SafePredFlag|SyncPredFlag);
InitCPred("incr_counter", 1, p_incrcounter, SafePredFlag|SyncPredFlag);
InitCPred("set_counter", 1, p_setcounter, SafePredFlag|SyncPredFlag);
InitCPred("trap_signal", 0, p_trapsignal, SafePredFlag|SyncPredFlag);
InitCPred("mark2_grab_tokens", 1, p_grab_tokens, SafePredFlag|SyncPredFlag);
InitCPred("subsumes", 2, p_subsumes, SafePredFlag);
#endif
#ifdef SFUNC
InitCPred("sparse_functor", 2, p_softfunctor, SafePredFlag);
#endif /* SFUNC */
/* InitCPred("unify",2,p_unify,SafePredFlag); */
/* InitCPred("occurs_check",2,p_occurs_check,SafePredFlag); */
/* InitCPred("counter",3,p_counter,SafePredFlag); */
/* InitCPred("iconcat",3,p_iconcat,SafePredFlag); */
}
void
InitUserBacks(void)
{
}

1561
C/utilpreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

654
C/write.c Normal file
View File

@@ -0,0 +1,654 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: write.c *
* Last rev: *
* mods: *
* comments: Writing a Prolog Term *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#if DEBUG
#if COROUTINING
#include "attvar.h"
#endif
#endif
#if HAVE_STRING_H
#include <string.h>
#endif
#if HAVE_CTYPE_H
#include <ctype.h>
#endif
/* describe the type of the previous term to have been written */
typedef enum {
separator, /* the previous term was a separator like ',', ')', ... */
alphanum, /* the previous term was an atom or number */
symbol /* the previous term was a symbol like +, -, *, .... */
} wtype;
static wtype lastw;
STATIC_PROTO(void wrputn, (Int));
STATIC_PROTO(void wrputs, (char *));
STATIC_PROTO(void wrputf, (Float));
STATIC_PROTO(void wrputref, (CODEADDR));
STATIC_PROTO(int legalAtom, (char *));
STATIC_PROTO(int LeftOpToProtect, (Atom, int));
STATIC_PROTO(int RightOpToProtect, (Atom, int));
STATIC_PROTO(wtype AtomIsSymbols, (char *));
STATIC_PROTO(void putAtom, (Atom));
STATIC_PROTO(void writeTerm, (Term, int, int, int));
static int (*writech) (int, int);
static int Quote_illegal, Ignore_ops, Handle_vars, Use_portray;
#define Quote_illegal_f 1
#define Ignore_ops_f 2
#define Handle_vars_f 4
#define Use_portray_f 8
#if DEBUG
#if COROUTINING
int Portray_delays = FALSE;
#endif
#endif
#define wrputc(X) ((*writech)(c_output_stream,X)) /* writes a character */
static void
wrputn(Int n) /* writes an integer */
{
char s[256], *s1=s; /* that should be enough for most integers */
if (n < 0) {
if (lastw == symbol)
wrputc(' ');
} else {
if (lastw == alphanum)
wrputc(' ');
}
#if HAVE_SNPRINTF
#if SHORT_INTS
snprintf(s, 256, "%ld", n);
#else
snprintf(s, 256, "%d", n);
#endif
#else
#if SHORT_INTS
sprintf(s, "%ld", n);
#else
sprintf(s, "%d", n);
#endif
#endif
while (*s1)
wrputc(*s1++);
lastw = alphanum;
}
static void
wrputs(char *s) /* writes a string */
{
while (*s)
wrputc(*s++);
}
static void
wrputf(Float f) /* writes a float */
{
char s[255], *pt = s, ch;
if (f < 0) {
if (lastw == symbol)
wrputc(' ');
} else {
if (lastw == alphanum)
wrputc(' ');
}
lastw = alphanum;
sprintf(s, "%.6g", f);
while (*pt == ' ')
pt++;
wrputs(pt);
if (*pt == '-') pt++;
while ((ch = *pt) != '\0') {
if (ch < '0' || ch > '9')
return;
pt++;
}
wrputs(".0");
}
static void
wrputref(CODEADDR ref) /* writes a data base reference */
{
char s[256];
#if SHORT_INTS
sprintf(s, "0x%p", ref);
#else
#ifdef linux
sprintf(s, "%p", ref);
#else
sprintf(s, "0x%p", ref);
#endif
#endif
wrputs(s);
lastw = alphanum;
}
static int
legalAtom(char *s) /* Is this a legal atom ? */
{
register int ch = *s;
if (ch == '\0')
return(FALSE);
if (chtype[ch] != LC) {
if (ch == '[')
return (*++s == ']' && !(*++s));
else if (ch == '{')
return (*++s == '}' && !(*++s));
else if (chtype[ch] == SL)
return (!*++s);
else if ((ch == ',' || ch == '.') && !s[1])
return (FALSE);
else
while (ch) {
if (chtype[ch] != SY) return (FALSE);
ch = *++s;
}
return (TRUE);
} else
while ((ch = *++s) != 0)
if (chtype[ch] > NU)
return (FALSE);
return (TRUE);
}
static int LeftOpToProtect(Atom at, int p)
{
int op, rp;
Prop opinfo = GetAProp(at, OpProperty);
return(opinfo && IsPrefixOp(opinfo, &op, &rp) );
}
static int RightOpToProtect(Atom at, int p)
{
int op, lp;
Prop opinfo = GetAProp(at, OpProperty);
return(opinfo && IsPosfixOp(opinfo, &op, &lp) );
}
static wtype
AtomIsSymbols(char *s) /* Is this atom just formed by symbols ? */
{
int ch;
if (chtype[(int)s[0]] == SL && s[1] == '\0')
return(separator);
while ((ch = *s++) != '\0') {
if (chtype[ch] != SY)
return(alphanum);
}
return(symbol);
}
static void
putAtom(Atom atom) /* writes an atom */
{
char *s = RepAtom(atom)->StrOfAE;
wtype atom_or_symbol = AtomIsSymbols(s);
if (lastw == atom_or_symbol && atom_or_symbol != separator /* solo */)
wrputc(' ');
lastw = atom_or_symbol;
if (!legalAtom(s) && Quote_illegal) {
wrputc('\'');
while (*s) {
int ch = *s++;
wrputc(ch);
if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES)
wrputc('\\'); /* be careful about backslashes */
else if (ch == '\'')
wrputc('\''); /* be careful about quotes */
}
wrputc('\'');
} else {
wrputs(s);
}
}
static int
IsStringTerm(Term string) /* checks whether this is a string */
{
if (IsVarTerm(string)) return(FALSE);
do {
Term hd;
int ch;
if (!IsPairTerm(string)) return(FALSE);
hd = HeadOfTerm(string);
if (IsVarTerm(hd)) return(FALSE);
if (!IsIntTerm(hd)) return(FALSE);
ch = IntOfTerm(HeadOfTerm(string));
if (ch < 0 || ch > 255)
return(FALSE);
string = TailOfTerm(string);
if (IsVarTerm(string)) return(FALSE);
} while (string != TermNil);
return(TRUE);
}
static void
putString(Term string) /* writes a string */
{
wrputc('"');
while (string != TermNil) {
int ch = IntOfTerm(HeadOfTerm(string));
wrputc(ch);
if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES)
wrputc('\\'); /* be careful about backslashes */
else if (ch == '"')
wrputc('"'); /* be careful about quotes */
string = TailOfTerm(string);
}
wrputc('"');
lastw = alphanum;
}
static void
putUnquotedString(Term string) /* writes a string */
{
while (string != TermNil) {
int ch = IntOfTerm(HeadOfTerm(string));
wrputc(ch);
string = TailOfTerm(string);
}
lastw = alphanum;
}
static void
write_var(CELL *t)
{
if (lastw == alphanum) {
wrputc(' ');
}
wrputc('_');
/* make sure we don't get no creepy spaces where they shouldn't be */
lastw = separator;
if (CellPtr(t) < H0) {
#if COROUTINING
#if DEBUG
if (Portray_delays) {
exts ext = ExtFromCell(t);
Portray_delays = FALSE;
if (ext == susp_ext) {
wrputs("$DL(");
write_var(t);
wrputc(')');
lastw = separator;
} else if (ext == attvars_ext) {
attvar_record *attv = (attvar_record *)t;
int i;
wrputs("$AT(");
write_var(t);
wrputc(',');
writeTerm((Term)&(attv->Value), 999, 1, FALSE);
for (i = 0; i < NUM_OF_ATTS; i ++) {
if (!IsVarTerm(attv->Atts[2*i+1])) {
wrputc(',');
writeTerm((Term)&(attv->Atts[2*i+1]), 999, 1, FALSE);
}
}
wrputc(')');
}
Portray_delays = TRUE;
return;
}
#endif
#endif
wrputc('D');
wrputn(((Int) (t- CellPtr(GlobalBase))));
} else {
wrputn(((Int) (t- H0)));
}
}
static void
writeTerm(Term t, int p, int depth, int rinfixarg)
/* term to write */
/* context priority */
{
if (*max_depth != 0 && depth > *max_depth) {
putAtom(LookupAtom("..."));
return;
}
t = Deref(t);
if (IsVarTerm(t)) {
write_var((CELL *)t);
} else if (IsIntTerm(t)) {
wrputn((Int) IntOfTerm(t));
} else if (IsAtomTerm(t)) {
putAtom(AtomOfTerm(t));
} else if (IsFloatTerm(t)) {
wrputf(FloatOfTerm(t));
} else if (IsRefTerm(t)) {
wrputref(RefOfTerm(t));
} else if (IsLongIntTerm(t)) {
wrputn(LongIntOfTerm(t));
#ifdef USE_GMP
} else if (IsBigIntTerm(t)) {
char *s = (char *)TR;
while (s+2+mpz_sizeinbase(BigIntOfTerm(t), 10) > (char *)TrailTop)
growtrail(64*1024);
mpz_get_str(s, 10, BigIntOfTerm(t));
wrputs(s);
#endif
} else if (IsPairTerm(t)) {
int eldepth = 1;
Term ti;
if (Use_portray) {
Term targs[1];
targs[0] = t;
PutValue(AtomPortray, MkAtomTerm(AtomNil));
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0);
Use_portray = TRUE;
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
return;
}
if (yap_flags[WRITE_QUOTED_STRING_FLAG] && IsStringTerm(t)) {
putString(t);
} else {
wrputc('[');
lastw = separator;
while (1) {
int new_depth = depth + 1;
if (*max_list && eldepth > *max_list) {
putAtom(LookupAtom("..."));
wrputc(']');
lastw = separator;
return;
} else
eldepth++;
writeTerm(HeadOfTermCell(t), 999, new_depth, FALSE);
ti = TailOfTerm(t);
if (IsVarTerm(ti))
break;
if (!IsPairTerm(ti))
break;
t = ti;
wrputc(',');
lastw = separator;
}
if (ti != MkAtomTerm(AtomNil)) {
wrputc('|');
lastw = separator;
writeTerm(TailOfTermCell(t), 999, depth + 1, FALSE);
}
wrputc(']');
lastw = separator;
}
} else { /* compound term */
Functor functor = FunctorOfTerm(t);
int Arity;
Atom atom;
Prop opinfo;
int op, lp, rp;
Arity = ArityOfFunctor(functor);
atom = NameOfFunctor(functor);
opinfo = GetAProp(atom, OpProperty);
#ifdef SFUNC
if (Arity == SFArity) {
int argno = 1;
CELL *p = ArgsOfSFTerm(t);
putAtom(atom);
wrputc('(');
lastw = separator;
while (*p) {
while (argno < *p) {
wrputc('_'), wrputc(',');
++argno;
}
*p++;
lastw = separator;
/* cannot use the term directly with the SBA */
writeTerm(Deref(p++), 999, depth + 1, FALSE);
if (*p)
wrputc(',');
argno++;
}
wrputc(')');
lastw = separator;
return;
}
#endif
if (Use_portray) {
Term targs[1];
targs[0] = t;
PutValue(AtomPortray, MkAtomTerm(AtomNil));
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0);
Use_portray = TRUE;
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
return;
}
if (!Ignore_ops &&
Arity == 1 && opinfo && IsPrefixOp(opinfo, &op,
&rp)
#ifdef DO_NOT_WRITE_PLUS_AND_MINUS_AS_PREFIX
&&
/* never write '+' and '-' as infix
operators */
( (RepAtom(atom)->StrOfAE[0] != '+' &&
RepAtom(atom)->StrOfAE[0] != '-') ||
RepAtom(atom)->StrOfAE[1] )
#endif /* DO_NOT_WRITE_PLUS_AND_MINUS_AS_PREFIX */
) {
Term tright = ArgOfTerm(1, t);
int bracket_right =
!IsVarTerm(tright) && IsAtomTerm(tright) &&
RightOpToProtect(AtomOfTerm(tright), rp);
if (op > p) {
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */
if (lastw != separator && !rinfixarg)
wrputc(' ');
wrputc('(');
lastw = separator;
}
putAtom(atom);
if (bracket_right) {
wrputc('(');
lastw = separator;
}
writeTerm(ArgOfTermCell(1,t), rp, depth + 1, FALSE);
if (bracket_right) {
wrputc(')');
lastw = separator;
}
if (op > p) {
wrputc(')');
lastw = separator;
}
} else if (!Ignore_ops &&
Arity == 1 && opinfo && IsPosfixOp(opinfo, &op, &lp)) {
Term tleft = ArgOfTerm(1, t);
int bracket_left =
!IsVarTerm(tleft) && IsAtomTerm(tleft) &&
LeftOpToProtect(AtomOfTerm(tleft), lp);
if (op > p) {
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */
if (lastw != separator && !rinfixarg)
wrputc(' ');
wrputc('(');
lastw = separator;
}
if (bracket_left) {
wrputc('(');
lastw = separator;
}
writeTerm(ArgOfTermCell(1,t), lp, depth + 1, rinfixarg);
if (bracket_left) {
wrputc(')');
lastw = separator;
}
putAtom(atom);
if (op > p) {
wrputc(')');
lastw = separator;
}
} else if (!Ignore_ops &&
Arity == 2 && opinfo && IsInfixOp(opinfo, &op, &lp,
&rp) ) {
Term tleft = ArgOfTerm(1, t);
Term tright = ArgOfTerm(2, t);
int bracket_left =
!IsVarTerm(tleft) && IsAtomTerm(tleft) &&
LeftOpToProtect(AtomOfTerm(tleft), lp);
int bracket_right =
!IsVarTerm(tright) && IsAtomTerm(tright) &&
RightOpToProtect(AtomOfTerm(tright), rp);
if (op > p) {
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */
if (lastw != separator && !rinfixarg)
wrputc(' ');
wrputc('(');
lastw = separator;
}
if (bracket_left) {
wrputc('(');
lastw = separator;
}
writeTerm(ArgOfTermCell(1, t), lp, depth + 1, rinfixarg);
if (bracket_left) {
wrputc(')');
lastw = separator;
}
/* avoid quoting commas */
if (strcmp(RepAtom(atom)->StrOfAE,","))
putAtom(atom);
else {
wrputc(',');
lastw = separator;
}
if (bracket_right) {
wrputc('(');
lastw = separator;
}
writeTerm(ArgOfTermCell(2, t), rp, depth + 1, TRUE);
if (bracket_right) {
wrputc(')');
lastw = separator;
}
if (op > p) {
wrputc(')');
lastw = separator;
}
} else if (Handle_vars && functor == FunctorVar) {
Term ti = ArgOfTerm(1, t);
if (lastw == alphanum) {
wrputc(' ');
}
if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsStringTerm(ti))) {
if (IsIntTerm(ti)) {
Int k = IntOfTerm(ti);
if (k == -1) {
wrputc('_');
lastw = alphanum;
return;
} else {
wrputc((k % 26) + 'A');
if (k >= 26) {
/* make sure we don't get confused about our context */
lastw = separator;
wrputn( k / 26 );
} else
lastw = alphanum;
}
} else {
putUnquotedString(ti);
}
} else {
wrputs("'$VAR'(");
lastw = separator;
writeTerm(ArgOfTermCell(1,t), 999, depth + 1, FALSE);
wrputc(')');
lastw = separator;
}
} else if (functor == FunctorBraces) {
wrputc('{');
lastw = separator;
writeTerm(ArgOfTermCell(1, t), 1200, depth + 1, FALSE);
wrputc('}');
lastw = separator;
} else if (atom == AtomArray) {
wrputc('{');
lastw = separator;
for (op = 1; op <= Arity; ++op) {
writeTerm(ArgOfTermCell(op, t), 999, depth + 1, FALSE);
if (op != Arity) {
wrputc(',');
lastw = separator;
}
}
wrputc('}');
lastw = separator;
} else {
putAtom(atom);
lastw = separator;
wrputc('(');
for (op = 1; op <= Arity; ++op) {
writeTerm(ArgOfTermCell(op, t), 999, depth + 1, FALSE);
if (op != Arity) {
wrputc(',');
lastw = separator;
}
}
wrputc(')');
lastw = separator;
}
}
}
void
plwrite(Term t, int (*mywrite) (int, int), int flags)
/* term to be written */
/* consumer */
/* write options */
{
writech = mywrite;
lastw = separator;
Quote_illegal = flags & Quote_illegal_f;
Handle_vars = flags & Handle_vars_f;
Use_portray = flags & Use_portray_f;
Ignore_ops = flags & Ignore_ops_f;
writeTerm(t, 1200, 1, FALSE);
}

1130
C/ypsocks.c Normal file
View File

File diff suppressed because it is too large Load Diff

307
C/ypstdio.c Normal file
View File

@@ -0,0 +1,307 @@
/*************************************************************************
* *
* YAP Prolog %W% %G%
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: io.h *
* Last rev: 19/2/88 *
* mods: *
* comments: simple replacement for stdio *
* *
*************************************************************************/
#include "Yap.h"
#ifdef YAP_STDIO
#include <malloc.h>
#if HAVE_FCNTL_H
#include <fcntl.h>
#endif
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if WINDOWS
#include <io.h>
#endif
#include <stdarg.h>
#ifndef O_BINARY
#define O_BINARY 0
#endif
YP_FILE yp_iob[YP_MAX_FILES];
static void
clear_iob(YP_FILE *f)
{
f->flags = f->cnt = 0;
f->buflen = 1;
f->ptr = f->base = (char *) &f->buf;
f->close = close;
f->read = read;
f->write = write;
}
void
init_yp_stdio()
{
int i;
/* mark all descriptors as free */
for(i=0; i<YP_MAX_FILES; ++i) {
yp_iob[i].check = i;
clear_iob(&yp_iob[i]);
}
/* initialize standard ones */
yp_iob[0].fd = 0;
yp_iob[0].flags = _YP_IO_FILE | _YP_IO_READ;
yp_iob[1].fd = 1;
yp_iob[1].flags = _YP_IO_FILE | _YP_IO_WRITE;
yp_iob[2].fd = 2;
yp_iob[2].flags = _YP_IO_FILE | _YP_IO_WRITE;
}
int
YP_fillbuf(YP_FILE *f)
{
if (!(f->flags & _YP_IO_READ)||(f->flags & (_YP_IO_ERR|_YP_IO_EOF)))
return -1;
if ((f->cnt = (f->read)(f->fd,f->base,f->buflen)) < 0) {
f->flags |= _YP_IO_ERR;
return -1;
}
if (f->cnt==0) {
f->flags |= _YP_IO_EOF;
return -1;
}
f->ptr = f->base;
return YP_getc(f);
}
int
YP_flushbuf(int c,YP_FILE *f)
{
if(!(f->flags & _YP_IO_WRITE)||(f->flags & _YP_IO_ERR)) return -1;
*(f->ptr++) = c;
{
int cnt = f->ptr-f->base;
int r = (f->write)(f->fd,f->base,cnt);
f->ptr = f->base;
if (r!=cnt) {
f->flags |= _YP_IO_ERR;
return -1;
}
f->ptr = f->base;
f->cnt = f->buflen-1;
}
return c;
}
int
YP_fflush(YP_FILE *f)
{
if(!(f->flags & _YP_IO_WRITE)||(f->flags & _YP_IO_ERR)) return -1;
if (f->ptr==f->base) return 0;
{
int cnt = f->ptr-f->base;
int r = (f->write)(f->fd,f->base,cnt);
f->ptr = f->base;
if (r!=cnt) {
f->flags |= _YP_IO_ERR;
return -1;
}
f->ptr = f->base;
f->cnt = f->buflen-1;
}
return 0;
}
int
YP_fputs(char *s, YP_FILE *f)
{
int count = 0;
while (*s) {
if (YP_putc(*s++,f)<0) return -1;
++count;
}
return count;
}
int
YP_puts(char *s)
{
return YP_fputs(s,YP_stdout);
}
char *
YP_fgets(char *s, int n, YP_FILE *f)
{
char *p=s;
if (f->flags & _YP_IO_ERR) return 0;
while(--n) {
int ch = YP_getc(f);
if (ch<0) return 0;
*p++ = ch;
if (ch=='\n') break;
}
*p = 0;
return s;
}
char *
YP_gets(char *s)
{
char *p=s;
while(1) {
int ch = YP_getchar();
if (ch<0) return 0;
if (ch=='\n') break;
*p++ = ch;
}
*p = 0;
return s;
}
YP_FILE*
YP_fopen(char *path, char *mode)
{
YP_FILE *f = 0;
int i, fd, flags, ch1, ch2;
for(i=3; i<YP_MAX_FILES; ++i)
if (!yp_iob[i].flags) {
f = &yp_iob[i];
break;
}
if (!f) return f;
/* try to open the file */
flags = 0;
ch1 = *mode++;
ch2 = *mode;
if(ch2=='b') {
flags = O_BINARY;
ch2 = *++mode;
}
if (ch2) return 0;
switch (ch1) {
case 'r':
flags |= O_RDONLY;
break;
case 'w':
flags |= O_WRONLY | O_TRUNC | O_CREAT;
break;
case 'a':
flags |= O_WRONLY | O_CREAT | O_APPEND;
break;
default:
return 0;
}
if ((fd=open(path,flags,0644))<0) return 0;
f->fd = fd;
f->flags = _YP_IO_FILE | (ch1=='r' ? _YP_IO_READ : _YP_IO_WRITE);
f->ptr = f->base;
/* todo: add buffers */
f->cnt = 0;
f->close = close;
f->read = read;
f->write = write;
return f;
}
int
YP_fclose(YP_FILE *f)
{
if (f != &yp_iob[f->check]) return -1;
if (f->flags & _YP_IO_WRITE) {
YP_fflush(f);
}
(f->close)(f->fd);
/* todo: release buffers */
clear_iob(f);
return 0;
}
#define MAXBSIZE 32768
int
YP_printf(char *format,...)
{
va_list ap;
char *buf = (char *) alloca(MAXBSIZE);
int r;
va_start(ap,format);
vsprintf(buf,format,ap);
r = YP_puts(buf);
va_end(ap);
return r;
}
int
YP_fprintf(YP_FILE *f, char *format,...)
{
va_list ap;
char *buf = (char *) alloca(MAXBSIZE);
int r;
va_start(ap,format);
vsprintf(buf,format,ap);
r = YP_fputs(buf,f);
va_end(ap);
return r;
}
int
YP_fileno(YP_FILE *f)
{
return f->fd;
}
int
YP_clearerr(YP_FILE *f)
{
f->flags &= ~ _YP_IO_ERR | _YP_IO_EOF;
return 0;
}
int
YP_feof(YP_FILE *f)
{
return f->flags & _YP_IO_EOF ? 1 : 0;
}
int
YP_setbuf(YP_FILE *f, char *b)
{
return 0;
}
int
YP_fseek(YP_FILE *f, int offset, int whence)
{
/* todo: implement fseek */
return 0;
}
int
YP_ftell(YP_FILE*f)
{
return 0;
}
#endif /* YAP_STDIO */