418fb0680a
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@173 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
1647 lines
41 KiB
C
1647 lines
41 KiB
C
/*************************************************************************
|
|
* *
|
|
* YAP Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: arrays.c *
|
|
* Last rev: *
|
|
* mods: *
|
|
* comments: Array Manipulation Routines *
|
|
* *
|
|
*************************************************************************/
|
|
|
|
#include "Yap.h"
|
|
#include "Yatom.h"
|
|
#include "Heap.h"
|
|
#include "eval.h"
|
|
#include "heapgc.h"
|
|
#if HAVE_ERRNO_H
|
|
#include <errno.h>
|
|
#else
|
|
extern int errno;
|
|
#endif
|
|
#if HAVE_STRING_H
|
|
#include <string.h>
|
|
#endif
|
|
|
|
#if __simplescalar__
|
|
#ifdef HAVE_MMAP
|
|
#undef HAVE_MMAP
|
|
#endif
|
|
#endif
|
|
|
|
STATIC_PROTO(Int p_compile_array_refs, (void));
|
|
STATIC_PROTO(Int p_array_refs_compiled, (void));
|
|
STATIC_PROTO(Int p_sync_mmapped_arrays, (void));
|
|
|
|
/*
|
|
*
|
|
* This file works together with pl/arrays.yap and arrays.h.
|
|
*
|
|
* YAP now supports a very simple notion of arrays. Arrays may be
|
|
* allocated dynamically or statically:
|
|
*
|
|
* o anonymous arrays are created during execution and allocated
|
|
* in the heap. They have the lifetime of any other other heap
|
|
* object. Any term can be an argument to a dynamic array.
|
|
*
|
|
* Dynamic arrays are named as a free variable and are
|
|
* initialised with free variables.
|
|
*
|
|
* o named arrays are created during execution but allocated
|
|
* in the code space. They have the lifetime of an heap
|
|
* object. Any term can be an argument to a dynamic array.
|
|
*
|
|
* Named arrays are named with atoms and are initialised with
|
|
* free variables.
|
|
*
|
|
* o static arrays are allocated in the heap. Their space is
|
|
* never recovered unless explictly said so by the
|
|
* program. Arguments to these arrays must have fixed size,
|
|
* and can only be atomic (at least for now).
|
|
*
|
|
* Static arrays can be named through an atom. They are
|
|
* initialised with [].
|
|
*
|
|
* Users create arrays by a declaration X array Arity. If X is an atom
|
|
* A, then this it is a static array and A's the array name, otherwise
|
|
* X refers to a dynamic array.
|
|
*
|
|
* As in C, arrays start counting from 0.
|
|
*
|
|
* Users access arrays by a token X[I] or a[I], this token can appear
|
|
* anywhere within the computation, so a[2] = X[3*4] means that the
|
|
* second element of global array a should unify with the 12th element
|
|
* of array X. The mechanism used to implement this is the same
|
|
* mechanism used to implement suspension variables.
|
|
*
|
|
* Representation:
|
|
*
|
|
* Dynamic Arrays are represented as a compound term of arity N, where
|
|
* N is the size of the array. Even so, I will not include array bound
|
|
* checking for now.
|
|
*
|
|
* |--------------------------------------------------------------|
|
|
* | $ARRAY/N|....
|
|
* |______________________________________________________________
|
|
*
|
|
*
|
|
* Unbound Var is used as a place to point to.
|
|
*
|
|
* Static Arrays are represented as a special property for an atom,
|
|
* with field size and
|
|
*
|
|
* A term of the form X[I] is represented as a Reference pointing to
|
|
* the compound term:
|
|
*
|
|
* '$array_arg'(X,I)
|
|
*
|
|
* Dereferecing will automatically find X[I].
|
|
*
|
|
* The only exception is the compiler, which uses a different
|
|
* dereferencing routine. The clause cl(a[2], Y[X], Y) will be
|
|
* compiled as:
|
|
*
|
|
* cl(A, B, Y) :- '$access_array'(a, A, 2), '$access_array'(Y, B, X).
|
|
*
|
|
* There are three operations to access arrays:
|
|
*
|
|
* X[I] = A, This is normal unification.
|
|
*
|
|
* X[I] := A, This is multiassignment, and therefore
|
|
* backtrackable.
|
|
*
|
|
* X[I] ::= A, This is non-backtrackable multiassignment, ans most
|
|
* useful for static arrays.
|
|
*
|
|
* The LHS of := and of ::= must be an array element!
|
|
*
|
|
*/
|
|
|
|
STATIC_PROTO(Term AccessNamedArray, (Atom, Int));
|
|
STATIC_PROTO(void InitNamedArray, (ArrayEntry *, Int));
|
|
STATIC_PROTO(void CreateNamedArray, (PropEntry *, Int, AtomEntry *));
|
|
STATIC_PROTO(void ResizeStaticArray, (StaticArrayEntry *, Int));
|
|
#if HAVE_MMAP
|
|
STATIC_PROTO(Int CloseMmappedArray, (StaticArrayEntry *, void *));
|
|
STATIC_PROTO(void ResizeMmappedArray, (StaticArrayEntry *, Int, void *));
|
|
#endif
|
|
STATIC_PROTO(Int p_create_array, (void));
|
|
STATIC_PROTO(Int p_create_mmapped_array, (void));
|
|
STATIC_PROTO(void replace_array_references_complex, (CELL *, CELL *, CELL *, Term));
|
|
STATIC_PROTO(Term replace_array_references, (Term));
|
|
STATIC_PROTO(Int p_array_references, (void));
|
|
STATIC_PROTO(Int p_create_static_array, (void));
|
|
STATIC_PROTO(Int p_resize_static_array, (void));
|
|
STATIC_PROTO(Int p_close_static_array, (void));
|
|
STATIC_PROTO(Int p_access_array, (void));
|
|
STATIC_PROTO(Int p_assign_static, (void));
|
|
|
|
static Term
|
|
AccessNamedArray(Atom a, Int indx)
|
|
{
|
|
AtomEntry *ae = RepAtom(a);
|
|
ArrayEntry *pp;
|
|
|
|
READ_LOCK(ae->ARWLock);
|
|
pp = RepArrayProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
|
pp = RepArrayProp(pp->NextOfPE);
|
|
READ_UNLOCK(ae->ARWLock);
|
|
|
|
if (!EndOfPAEntr(pp)) {
|
|
if (ArrayIsDynamic(pp)) {
|
|
Term out;
|
|
READ_LOCK(pp->ArRWLock);
|
|
if (IsVarTerm(pp->ValueOfVE)) {
|
|
READ_UNLOCK(pp->ArRWLock);
|
|
return(FALSE);
|
|
}
|
|
out = RepAppl(pp->ValueOfVE)[indx+1];
|
|
READ_UNLOCK(pp->ArRWLock);
|
|
return(out);
|
|
} else {
|
|
StaticArrayEntry *ptr = (StaticArrayEntry *)pp;
|
|
|
|
READ_LOCK(ptr->ArRWLock);
|
|
if (-(pp->ArrayEArity) <= indx || indx < 0) {
|
|
/* Error(DOMAIN_ERROR_ARRAY_OVERFLOW, MkIntegerTerm(indx), "access_array");*/
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
P = (yamop *)FAILCODE;
|
|
return(TermNil);
|
|
}
|
|
switch (ptr->ArrayType) {
|
|
|
|
case array_of_ints:
|
|
{
|
|
Term out;
|
|
out = MkIntegerTerm(ptr->ValueOfVE.ints[indx]);
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
return (out);
|
|
}
|
|
case array_of_doubles:
|
|
{
|
|
Term out;
|
|
out = MkEvalFl(ptr->ValueOfVE.floats[indx]);
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
return (out);
|
|
}
|
|
case array_of_ptrs:
|
|
{
|
|
Term out;
|
|
out = MkIntegerTerm((Int)(ptr->ValueOfVE.ptrs[indx]));
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
return (out);
|
|
}
|
|
case array_of_atoms:
|
|
{
|
|
Term out;
|
|
out = ptr->ValueOfVE.atoms[indx];
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
if (out == 0L)
|
|
out = TermNil;
|
|
else
|
|
return(out);
|
|
}
|
|
/* just return the atom */
|
|
case array_of_chars:
|
|
{
|
|
Term out;
|
|
out = MkIntegerTerm((Int)(ptr->ValueOfVE.chars[indx]));
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
return (out);
|
|
}
|
|
case array_of_uchars:
|
|
{
|
|
Term out;
|
|
out = MkIntegerTerm((Int)(ptr->ValueOfVE.uchars[indx]));
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
return (out);
|
|
}
|
|
case array_of_dbrefs:
|
|
{
|
|
/* The object is now in use */
|
|
Term TRef = ptr->ValueOfVE.dbrefs[indx];
|
|
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
if (TRef != 0L) {
|
|
DBRef ref = DBRefOfTerm(TRef);
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
LOCK(ref->lock);
|
|
INC_DBREF_COUNT(ref);
|
|
TRAIL_REF(ref); /* So that fail will erase it */
|
|
UNLOCK(ref->lock);
|
|
#else
|
|
if (!(ref->Flags & InUseMask)) {
|
|
ref->Flags |= InUseMask;
|
|
TRAIL_REF(ref); /* So that fail will erase it */
|
|
}
|
|
#endif
|
|
} else {
|
|
P = (yamop *)FAILCODE;
|
|
TRef = TermNil;
|
|
}
|
|
return (TRef);
|
|
}
|
|
case array_of_terms:
|
|
{
|
|
/* The object is now in use */
|
|
DBRef ref = ptr->ValueOfVE.terms[indx];
|
|
Term TRef;
|
|
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
if (ref != NULL) {
|
|
TRef = FetchTermFromDB(ref,3);
|
|
} else {
|
|
P = (yamop *)FAILCODE;
|
|
TRef = TermNil;
|
|
}
|
|
return (TRef);
|
|
}
|
|
default:
|
|
READ_UNLOCK(ptr->ArRWLock);
|
|
return(TermNil);
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
Error(EXISTENCE_ERROR_ARRAY,MkAtomTerm(a),"named array");
|
|
return (TermNil);
|
|
}
|
|
|
|
}
|
|
|
|
static Int
|
|
p_access_array(void)
|
|
{
|
|
Term t = Deref(ARG1);
|
|
Term ti = Deref(ARG2);
|
|
Term tf;
|
|
UInt indx;
|
|
|
|
if (IsNonVarTerm(ti)) {
|
|
union arith_ret v;
|
|
if (IsIntTerm(ti))
|
|
indx = IntOfTerm(ti);
|
|
else if (Eval(ti, &v) == long_int_e)
|
|
indx = v.Int;
|
|
else {
|
|
Error(TYPE_ERROR_INTEGER,ti,"access_array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
else {
|
|
Error(INSTANTIATION_ERROR,ti,"access_array");
|
|
return (TermNil);
|
|
}
|
|
|
|
if (IsNonVarTerm(t)) {
|
|
if (IsApplTerm(t)) {
|
|
if (indx >= ArityOfFunctor(FunctorOfTerm(t))) {
|
|
/* Error(DOMAIN_ERROR_ARRAY_OVERFLOW, MkIntegerTerm(indx), "access_array");*/
|
|
P = (yamop *)FAILCODE;
|
|
return(FALSE);
|
|
}
|
|
tf = (RepAppl(t))[indx + 1];
|
|
} else if (IsAtomTerm(t)) {
|
|
tf = AccessNamedArray(AtomOfTerm(t), indx);
|
|
} else {
|
|
Error(TYPE_ERROR_ARRAY,t,"access_array");
|
|
return(FALSE);
|
|
}
|
|
} else {
|
|
Error(INSTANTIATION_ERROR,t,"access_array");
|
|
return(FALSE);
|
|
}
|
|
return (unify(tf, ARG3));
|
|
}
|
|
|
|
static Int
|
|
p_array_arg(void)
|
|
{
|
|
register Term ti = Deref(ARG3), t;
|
|
register Int indx;
|
|
|
|
if (IsNonVarTerm(ti)) {
|
|
union arith_ret v;
|
|
if (IsIntTerm(ti))
|
|
indx = IntOfTerm(ti);
|
|
else if (Eval(ti, &v) == long_int_e)
|
|
indx = v.Int;
|
|
else {
|
|
Error(TYPE_ERROR_INTEGER,ti,"array_arg");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
else {
|
|
Error(INSTANTIATION_ERROR,ti,"array_arg");
|
|
return (FALSE);
|
|
}
|
|
|
|
t = Deref(ARG2);
|
|
if (IsNonVarTerm(t)) {
|
|
if (IsApplTerm(t)) {
|
|
return (unify(((RepAppl(t))[indx + 1]), ARG1));
|
|
}
|
|
else if (IsAtomTerm(t)) {
|
|
Term tf = AccessNamedArray(AtomOfTerm(t), indx);
|
|
|
|
return (unify(tf, ARG1));
|
|
}
|
|
else
|
|
Error(TYPE_ERROR_ARRAY,t,"array_arg");
|
|
}
|
|
else
|
|
Error(INSTANTIATION_ERROR,t,"array_arg");
|
|
|
|
return (FALSE);
|
|
|
|
}
|
|
|
|
static void
|
|
InitNamedArray(ArrayEntry * p, Int dim)
|
|
{
|
|
Term *tp;
|
|
|
|
WRITE_LOCK(p->ArRWLock);
|
|
/* Leave a pointer so that we can reclaim array space when
|
|
* we backtrack or when we abort */
|
|
/* place terms in reverse order */
|
|
Bind_Global(&(p->ValueOfVE),AbsAppl(H));
|
|
tp = H;
|
|
tp[0] = (CELL)MkFunctor(AtomArray, dim);
|
|
tp++;
|
|
p->ArrayEArity = dim;
|
|
/* Initialise the array as a set of variables */
|
|
H = tp+dim;
|
|
for (; tp < H; tp++) {
|
|
RESET_VARIABLE(tp);
|
|
}
|
|
WRITE_UNLOCK(p->ArRWLock);
|
|
}
|
|
|
|
/* we assume the atom ae is already locked */
|
|
static void
|
|
CreateNamedArray(PropEntry * pp, Int dim, AtomEntry *ae)
|
|
{
|
|
ArrayEntry *p;
|
|
|
|
p = (ArrayEntry *) AllocAtomSpace(sizeof(*p));
|
|
p->KindOfPE = ArrayProperty;
|
|
p->NextOfPE = ae->PropsOfAE;
|
|
INIT_RWLOCK(p->ArRWLock);
|
|
ae->PropsOfAE = AbsArrayProp(p);
|
|
|
|
InitNamedArray(p, dim);
|
|
|
|
}
|
|
|
|
static void
|
|
AllocateStaticArraySpace(StaticArrayEntry *p, static_array_types atype, Int array_size)
|
|
{
|
|
Int asize = 0;
|
|
switch (atype) {
|
|
case array_of_doubles:
|
|
asize = array_size*sizeof(Float);
|
|
break;
|
|
case array_of_ints:
|
|
asize = array_size*sizeof(Int);
|
|
break;
|
|
case array_of_chars:
|
|
asize = array_size*sizeof(char);
|
|
break;
|
|
case array_of_uchars:
|
|
asize = array_size*sizeof(unsigned char);
|
|
break;
|
|
case array_of_ptrs:
|
|
asize = array_size*sizeof(AtomEntry *);
|
|
break;
|
|
case array_of_dbrefs:
|
|
case array_of_atoms:
|
|
asize = array_size*sizeof(Term);
|
|
break;
|
|
case array_of_terms:
|
|
asize = array_size*sizeof(DBRef);
|
|
break;
|
|
}
|
|
while ((p->ValueOfVE.floats = (Float *) AllocAtomSpace(asize) ) == NULL) {
|
|
YAPLeaveCriticalSection();
|
|
if (!growheap(FALSE)) {
|
|
Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
|
|
return;
|
|
}
|
|
YAPEnterCriticalSection();
|
|
}
|
|
}
|
|
|
|
/* ae and p are assumed to be locked, if they exist */
|
|
static void
|
|
CreateStaticArray(AtomEntry *ae, Int dim, static_array_types type, CODEADDR start_addr, StaticArrayEntry *p)
|
|
{
|
|
if (EndOfPAEntr(p)) {
|
|
p = (StaticArrayEntry *) AllocAtomSpace(sizeof(*p));
|
|
p->KindOfPE = ArrayProperty;
|
|
p->NextOfPE = ae->PropsOfAE;
|
|
INIT_RWLOCK(p->ArRWLock);
|
|
WRITE_LOCK(p->ArRWLock);
|
|
}
|
|
p->ArrayEArity = -dim;
|
|
p->ArrayType = type;
|
|
ae->PropsOfAE = AbsArrayProp((ArrayEntry *)p);
|
|
WRITE_UNLOCK(ae->ARWLock);
|
|
if (start_addr == NULL) {
|
|
int i;
|
|
|
|
AllocateStaticArraySpace(p, type, dim);
|
|
switch(type) {
|
|
case array_of_ints:
|
|
for (i = 0; i < dim; i++)
|
|
p->ValueOfVE.ints[i] = 0;
|
|
break;
|
|
case array_of_chars:
|
|
for (i = 0; i < dim; i++)
|
|
p->ValueOfVE.chars[i] = '\0';
|
|
break;
|
|
case array_of_uchars:
|
|
for (i = 0; i < dim; i++)
|
|
p->ValueOfVE.uchars[i] = '\0';
|
|
break;
|
|
case array_of_doubles:
|
|
for (i = 0; i < dim; i++)
|
|
p->ValueOfVE.floats[i] = 0.0;
|
|
break;
|
|
case array_of_ptrs:
|
|
for (i = 0; i < dim; i++)
|
|
p->ValueOfVE.ptrs[i] = NULL;
|
|
break;
|
|
case array_of_atoms:
|
|
case array_of_dbrefs:
|
|
for (i = 0; i < dim; i++)
|
|
p->ValueOfVE.atoms[i] = 0L;
|
|
break;
|
|
case array_of_terms:
|
|
for (i = 0; i < dim; i++)
|
|
p->ValueOfVE.terms[i] = NULL;
|
|
break;
|
|
}
|
|
} else {
|
|
/* external array */
|
|
p->ValueOfVE.chars = (char *)start_addr;
|
|
}
|
|
WRITE_UNLOCK(p->ArRWLock);
|
|
}
|
|
|
|
static void
|
|
ResizeStaticArray(StaticArrayEntry *pp, Int dim)
|
|
{
|
|
statarray_elements old_v = pp->ValueOfVE;
|
|
static_array_types type = pp->ArrayType;
|
|
Int old_dim = - pp->ArrayEArity;
|
|
Int mindim = (dim < old_dim ? dim : old_dim), i;
|
|
|
|
WRITE_LOCK(pp->ArRWLock);
|
|
/* change official size */
|
|
if (pp->ArrayEArity >= 0)
|
|
return;
|
|
pp->ArrayEArity = -dim;
|
|
#if HAVE_MMAP
|
|
if (pp->ValueOfVE.chars < (char *)HeapBase ||
|
|
pp->ValueOfVE.chars > (char *)HeapTop) {
|
|
ResizeMmappedArray(pp, dim, (void *)(pp->ValueOfVE.chars));
|
|
return;
|
|
}
|
|
#endif
|
|
AllocateStaticArraySpace(pp, type, dim);
|
|
switch(type) {
|
|
case array_of_ints:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.ints[i] = old_v.ints[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.ints[i] = 0;
|
|
break;
|
|
case array_of_chars:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.chars[i] = old_v.chars[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.chars[i] = '\0';
|
|
break;
|
|
case array_of_uchars:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.uchars[i] = old_v.uchars[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.uchars[i] = '\0';
|
|
break;
|
|
case array_of_doubles:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.floats[i] = old_v.floats[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.floats[i] = 0.0;
|
|
break;
|
|
case array_of_ptrs:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.ptrs[i] = old_v.ptrs[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.ptrs[i] = NULL;
|
|
break;
|
|
case array_of_atoms:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.atoms[i] = old_v.atoms[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.atoms[i] = TermNil;
|
|
break;
|
|
case array_of_dbrefs:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.dbrefs[i] = old_v.dbrefs[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.dbrefs[i] = 0L;
|
|
break;
|
|
case array_of_terms:
|
|
for (i = 0; i <mindim; i++)
|
|
pp->ValueOfVE.terms[i] = old_v.terms[i];
|
|
for (i = mindim; i<dim; i++)
|
|
pp->ValueOfVE.terms[i] = NULL;
|
|
break;
|
|
}
|
|
WRITE_UNLOCK(pp->ArRWLock);
|
|
}
|
|
|
|
CELL *
|
|
ClearNamedArray(CELL *pt0)
|
|
{
|
|
/* given a key to an array, just take it off-line */
|
|
PropEntry *pp;
|
|
AtomEntry *ae = (AtomEntry *)RepAppl(pt0[-1]);
|
|
|
|
READ_LOCK(ae->ARWLock);
|
|
pp = RepProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) {
|
|
pp = RepProp(pp->NextOfPE);
|
|
}
|
|
READ_UNLOCK(ae->ARWLock);
|
|
WRITE_LOCK(((ArrayEntry *)pp)->ArRWLock);
|
|
if (!EndOfPAEntr(pp)) {
|
|
((ArrayEntry *) pp)->ArrayEArity = 0;
|
|
/* tell backtracking to skip two cells */
|
|
WRITE_UNLOCK(((ArrayEntry *)pp)->ArRWLock);
|
|
return(pt0-2);
|
|
} else {
|
|
WRITE_UNLOCK(((ArrayEntry *)pp)->ArRWLock);
|
|
Error(EXISTENCE_ERROR_ARRAY,TermNil,"clear array");
|
|
return(pt0); /* just make GCC happy */
|
|
}
|
|
}
|
|
|
|
/* create an array (?Name, + Size) */
|
|
static Int
|
|
p_create_array(void)
|
|
{
|
|
Term ti;
|
|
Term t;
|
|
Int size;
|
|
|
|
restart:
|
|
ti = Deref(ARG2);
|
|
t = Deref(ARG1);
|
|
{
|
|
union arith_ret v;
|
|
if (IsIntTerm(ti))
|
|
size = IntOfTerm(ti);
|
|
else if (Eval(ti, &v) == long_int_e)
|
|
size = v.Int;
|
|
else {
|
|
Error(TYPE_ERROR_INTEGER,ti,"create_array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
if (IsVarTerm(t)) {
|
|
/* Create an anonymous array */
|
|
Functor farray;
|
|
|
|
farray = MkFunctor(AtomArray, size);
|
|
if (H+1+size > ASP-1024) {
|
|
if (!gc(2, ENV, P)) {
|
|
Error(SYSTEM_ERROR,TermNil,"YAP could not grow stack in array/2");
|
|
return(FALSE);
|
|
} else {
|
|
if (H+1+size > ASP-1024) {
|
|
growstack( sizeof(CELL) * (size+1-(H-ASP-1024)));
|
|
}
|
|
}
|
|
goto restart;
|
|
}
|
|
t = AbsAppl(H);
|
|
*H++ = (CELL) farray;
|
|
for (; size >= 0; size--) {
|
|
RESET_VARIABLE(H);
|
|
H++;
|
|
}
|
|
return (unify(t, ARG1));
|
|
}
|
|
else if (IsAtomTerm(t)) {
|
|
/* Create a named array */
|
|
AtomEntry *ae = RepAtom(AtomOfTerm(t));
|
|
PropEntry *pp;
|
|
|
|
WRITE_LOCK(ae->ARWLock);
|
|
pp = RepProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
|
pp = RepProp(pp->NextOfPE);
|
|
if (EndOfPAEntr(pp)) {
|
|
if (H+1+size > ASP-1024) {
|
|
WRITE_UNLOCK(ae->ARWLock);
|
|
if (!gc(2, ENV, P)) {
|
|
Error(SYSTEM_ERROR,TermNil,"YAP could not grow stack in array/2");
|
|
return(FALSE);
|
|
} else
|
|
goto restart;
|
|
}
|
|
CreateNamedArray(pp, size, ae);
|
|
WRITE_UNLOCK(ae->ARWLock);
|
|
return (TRUE);
|
|
} else {
|
|
ArrayEntry *app = (ArrayEntry *) pp;
|
|
|
|
WRITE_UNLOCK(ae->ARWLock);
|
|
if (!IsUnboundVar(app->ValueOfVE))
|
|
Error(PERMISSION_ERROR_CREATE_ARRAY,t,"create_array",
|
|
ae->StrOfAE);
|
|
else {
|
|
if (H+1+size > ASP-1024) {
|
|
if (!gc(2, ENV, P)) {
|
|
Error(SYSTEM_ERROR,TermNil,"YAP could not grow stack in array/2");
|
|
return(FALSE);
|
|
} else
|
|
goto restart;
|
|
}
|
|
InitNamedArray(app, size);
|
|
return (TRUE);
|
|
}
|
|
}
|
|
}
|
|
return (FALSE);
|
|
}
|
|
|
|
/* create an array (+Name, + Size, +Props) */
|
|
static Int
|
|
p_create_static_array(void)
|
|
{
|
|
Term ti = Deref(ARG2);
|
|
Term t = Deref(ARG1);
|
|
Term tprops = Deref(ARG3);
|
|
Int size;
|
|
static_array_types props;
|
|
|
|
if (IsVarTerm(ti)) {
|
|
Error(INSTANTIATION_ERROR,ti,"create static array");
|
|
return (FALSE);
|
|
} else if (IsIntTerm(ti))
|
|
size = IntOfTerm(ti);
|
|
else {
|
|
union arith_ret v;
|
|
if (Eval(ti, &v) == long_int_e) {
|
|
size = v.Int;
|
|
}
|
|
else {
|
|
Error(TYPE_ERROR_INTEGER,ti,"create static array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
if (IsVarTerm(tprops)) {
|
|
Error(INSTANTIATION_ERROR,tprops,"create static array");
|
|
return (FALSE);
|
|
} else if (IsAtomTerm(tprops)) {
|
|
char *atname = RepAtom(AtomOfTerm(tprops))->StrOfAE;
|
|
if (!strcmp(atname, "int"))
|
|
props = array_of_ints;
|
|
else if (!strcmp(atname, "dbref"))
|
|
props = array_of_dbrefs;
|
|
else if (!strcmp(atname, "float"))
|
|
props = array_of_doubles;
|
|
else if (!strcmp(atname, "ptr"))
|
|
props = array_of_ptrs;
|
|
else if (!strcmp(atname, "atom"))
|
|
props = array_of_atoms;
|
|
else if (!strcmp(atname, "byte"))
|
|
props = array_of_chars;
|
|
else if (!strcmp(atname, "unsigned_byte"))
|
|
props = array_of_uchars;
|
|
else if (!strcmp(atname, "term"))
|
|
props = array_of_terms;
|
|
else {
|
|
Error(DOMAIN_ERROR_ARRAY_TYPE,tprops,"create static array");
|
|
return(FALSE);
|
|
}
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,tprops,"create static array");
|
|
return (FALSE);
|
|
}
|
|
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"create static array");
|
|
return (FALSE);
|
|
}
|
|
else if (IsAtomTerm(t)) {
|
|
/* Create a named array */
|
|
AtomEntry *ae = RepAtom(AtomOfTerm(t));
|
|
StaticArrayEntry *pp;
|
|
|
|
WRITE_LOCK(ae->ARWLock);
|
|
pp = RepStaticArrayProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
|
pp = RepStaticArrayProp(pp->NextOfPE);
|
|
if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
|
|
CreateStaticArray(ae, size, props, NULL, pp);
|
|
return (TRUE);
|
|
} else {
|
|
WRITE_UNLOCK(ae->ARWLock);
|
|
Error(PERMISSION_ERROR_CREATE_ARRAY,t,"create static array");
|
|
return(FALSE);
|
|
}
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,t,"create static array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
/* has a static array associated (+Name) */
|
|
static Int
|
|
p_has_static_array(void)
|
|
{
|
|
Term t = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t)) {
|
|
return (FALSE);
|
|
}
|
|
else if (IsAtomTerm(t)) {
|
|
/* Create a named array */
|
|
AtomEntry *ae = RepAtom(AtomOfTerm(t));
|
|
StaticArrayEntry *pp;
|
|
|
|
READ_LOCK(ae->ARWLock);
|
|
pp = RepStaticArrayProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
|
pp = RepStaticArrayProp(pp->NextOfPE);
|
|
if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
|
|
READ_UNLOCK(ae->ARWLock);
|
|
return (FALSE);
|
|
} else {
|
|
READ_UNLOCK(ae->ARWLock);
|
|
return(TRUE);
|
|
}
|
|
} else {
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
/* resize a static array (+Name, + Size, +Props) */
|
|
/* does not work for mmap arrays yet */
|
|
static Int
|
|
p_resize_static_array(void)
|
|
{
|
|
Term ti = Deref(ARG3);
|
|
Term t = Deref(ARG1);
|
|
Int size;
|
|
|
|
if (IsVarTerm(ti)) {
|
|
Error(INSTANTIATION_ERROR,ti,"resize a static array");
|
|
return (FALSE);
|
|
} else if (IsIntTerm(ti))
|
|
size = IntOfTerm(ti);
|
|
else {
|
|
union arith_ret v;
|
|
if (Eval(ti, &v) == long_int_e) {
|
|
size = v.Int;
|
|
}
|
|
else {
|
|
Error(TYPE_ERROR_INTEGER,ti,"resize a static array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"resize a static array");
|
|
return (FALSE);
|
|
}
|
|
else if (IsAtomTerm(t)) {
|
|
/* resize a named array */
|
|
Atom a = AtomOfTerm(t);
|
|
StaticArrayEntry *pp = RepStaticArrayProp(RepAtom(a)->PropsOfAE);
|
|
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
|
pp = RepStaticArrayProp(pp->NextOfPE);
|
|
if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
|
|
Error(PERMISSION_ERROR_RESIZE_ARRAY,t,"resize a static array");
|
|
return(FALSE);
|
|
} else {
|
|
Int osize = - pp->ArrayEArity;
|
|
ResizeStaticArray(pp, size);
|
|
return(unify(ARG2,MkIntegerTerm(osize)));
|
|
}
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,t,"resize a static array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
/* Close a named array (+Name) */
|
|
static Int
|
|
p_close_static_array(void)
|
|
{
|
|
/* does not work for mmap arrays yet */
|
|
Term t = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"close static array");
|
|
return (FALSE);
|
|
}
|
|
else if (IsAtomTerm(t)) {
|
|
/* Create a named array */
|
|
AtomEntry *ae = RepAtom(AtomOfTerm(t));
|
|
PropEntry *pp;
|
|
|
|
READ_LOCK(ae->ARWLock);
|
|
pp = RepProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
|
pp = RepProp(pp->NextOfPE);
|
|
READ_UNLOCK(ae->ARWLock);
|
|
if (EndOfPAEntr(pp)) {
|
|
return (FALSE);
|
|
} else {
|
|
StaticArrayEntry *ptr = (StaticArrayEntry *)pp;
|
|
if (ptr->ValueOfVE.ints != NULL) {
|
|
#if HAVE_MMAP
|
|
if (ptr->ValueOfVE.chars < (char *)HeapBase ||
|
|
ptr->ValueOfVE.chars > (char *)HeapTop) {
|
|
return(CloseMmappedArray(ptr, (void *)ptr->ValueOfVE.chars));
|
|
}
|
|
#endif
|
|
FreeAtomSpace((char *)(ptr->ValueOfVE.ints));
|
|
ptr->ValueOfVE.ints = NULL;
|
|
ptr->ArrayEArity = 0;
|
|
return(TRUE);
|
|
} else {
|
|
return(FALSE);
|
|
}
|
|
}
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,t,"close static array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
#if HAVE_MMAP
|
|
|
|
#if HAVE_UNISTD_H
|
|
#include <unistd.h>
|
|
#endif
|
|
#if HAVE_SYS_MMAN_H
|
|
#include <sys/mman.h>
|
|
#endif
|
|
#if HAVE_SYS_STAT_H
|
|
#include <sys/stat.h>
|
|
#endif
|
|
#if HAVE_FCNTL_H
|
|
#include <fcntl.h>
|
|
#endif
|
|
|
|
STATIC_PROTO(void ResizeMmappedArray, (StaticArrayEntry *,Int ,void *));
|
|
|
|
/* keep a list of mmaped blocks to synch on exit */
|
|
|
|
typedef struct MMAP_ARRAY_BLOCK {
|
|
Atom name;
|
|
void *start;
|
|
size_t size;
|
|
Int items;
|
|
int fd;
|
|
struct MMAP_ARRAY_BLOCK *next;
|
|
} mmap_array_block;
|
|
|
|
static mmap_array_block *mmap_arrays = NULL;
|
|
|
|
static Int
|
|
CloseMmappedArray(StaticArrayEntry *pp, void *area)
|
|
{
|
|
mmap_array_block *ptr = mmap_arrays, *optr = mmap_arrays;
|
|
|
|
while (ptr != NULL && ptr->start != area) {
|
|
ptr = ptr->next;
|
|
optr = ptr;
|
|
}
|
|
if (ptr == NULL) {
|
|
Error(SYSTEM_ERROR,ARG1,"close_mmapped_array (array chain incoherent)", strerror(errno));
|
|
return(FALSE);
|
|
}
|
|
if (munmap(ptr->start, ptr->size) == -1) {
|
|
Error(SYSTEM_ERROR,ARG1,"close_mmapped_array (munmap: %s)", strerror(errno));
|
|
return(FALSE);
|
|
}
|
|
optr->next = ptr->next;
|
|
pp->ValueOfVE.ints = NULL;
|
|
pp->ArrayEArity = 0;
|
|
if (close(ptr->fd) < 0) {
|
|
Error(SYSTEM_ERROR,ARG1,"close_mmapped_array (close: %s)", strerror(errno));
|
|
return(FALSE);
|
|
}
|
|
FreeAtomSpace((char *)ptr);
|
|
return(TRUE);
|
|
}
|
|
|
|
static void
|
|
ResizeMmappedArray(StaticArrayEntry *pp, Int dim, void *area)
|
|
{
|
|
mmap_array_block *ptr = mmap_arrays;
|
|
size_t total_size;
|
|
while (ptr != NULL && ptr->start != area) {
|
|
ptr = ptr->next;
|
|
}
|
|
if (ptr == NULL)
|
|
return;
|
|
/* This is a very stupid algorithm to change size for an array.
|
|
|
|
First, we unmap it, then we actually change the size for the file,
|
|
and last we initialise again
|
|
*/
|
|
if (munmap(ptr->start, ptr->size) == -1) {
|
|
Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (munmap: %s)", strerror(errno));
|
|
return;
|
|
}
|
|
total_size = (ptr->size / ptr->items)*dim;
|
|
if (ftruncate(ptr->fd, total_size) < 0) {
|
|
Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (ftruncate: %s)", strerror(errno));
|
|
return;
|
|
}
|
|
if (lseek(ptr->fd, total_size-1, SEEK_SET) < 0) {
|
|
Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (lseek: %s)", strerror(errno));
|
|
return;
|
|
}
|
|
if (write(ptr->fd, "", 1) < 0) {
|
|
Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (write: %s)", strerror(errno));
|
|
return;
|
|
}
|
|
if ((ptr->start = (void *)mmap(0, (size_t) total_size, PROT_READ | PROT_WRITE, MAP_SHARED, ptr->fd, 0)) == (void *) - 1) {
|
|
Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (mmap: %s)", strerror(errno));
|
|
return;
|
|
}
|
|
ptr->size = total_size;
|
|
ptr->items = dim;
|
|
pp->ValueOfVE.chars = ptr->start;
|
|
}
|
|
|
|
#endif
|
|
|
|
/* create an array (+Name, + Size, +Props) */
|
|
static Int
|
|
p_create_mmapped_array(void)
|
|
{
|
|
#ifdef HAVE_MMAP
|
|
Term ti = Deref(ARG2);
|
|
Term t = Deref(ARG1);
|
|
Term tprops = Deref(ARG3);
|
|
Term tfile = Deref(ARG4);
|
|
Int size;
|
|
static_array_types props;
|
|
size_t total_size;
|
|
CODEADDR array_addr;
|
|
int fd;
|
|
|
|
if (IsVarTerm(ti)) {
|
|
Error(INSTANTIATION_ERROR,ti,"create_mmapped_array");
|
|
return (FALSE);
|
|
} else if (IsIntTerm(ti))
|
|
size = IntOfTerm(ti);
|
|
else {
|
|
union arith_ret v;
|
|
if (Eval(ti, &v) == long_int_e) {
|
|
size = v.Int;
|
|
}
|
|
else {
|
|
Error(TYPE_ERROR_INTEGER,ti,"create_mmapped_array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
if (IsVarTerm(tprops)) {
|
|
Error(INSTANTIATION_ERROR,tprops,"create_mmapped_array");
|
|
return (FALSE);
|
|
} else if (IsAtomTerm(tprops)) {
|
|
char *atname = RepAtom(AtomOfTerm(tprops))->StrOfAE;
|
|
if (!strcmp(atname, "int")) {
|
|
props = array_of_ints;
|
|
total_size = size*sizeof(Int);
|
|
} else if (!strcmp(atname, "dbref")) {
|
|
props = array_of_dbrefs;
|
|
total_size = size*sizeof(Int);
|
|
} else if (!strcmp(atname, "float")) {
|
|
props = array_of_doubles;
|
|
total_size = size*sizeof(Float);
|
|
} else if (!strcmp(atname, "ptr")) {
|
|
props = array_of_ptrs;
|
|
total_size = size*sizeof(AtomEntry *);
|
|
} else if (!strcmp(atname, "atom")) {
|
|
props = array_of_atoms;
|
|
total_size = size*sizeof(Term);
|
|
} else if (!strcmp(atname, "byte")) {
|
|
props = array_of_chars;
|
|
total_size = size*sizeof(char);
|
|
} else if (!strcmp(atname, "unsigned_byte")) {
|
|
props = array_of_uchars;
|
|
total_size = size*sizeof(unsigned char);
|
|
} else {
|
|
Error(DOMAIN_ERROR_ARRAY_TYPE,tprops,"create_mmapped_array");
|
|
return(FALSE);
|
|
}
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,tprops,"create_mmapped_array");
|
|
return (FALSE);
|
|
}
|
|
|
|
if (IsVarTerm(tfile)) {
|
|
Error(INSTANTIATION_ERROR,tfile,"create_mmapped_array");
|
|
return (FALSE);
|
|
} else if (IsAtomTerm(tfile)) {
|
|
char *filename = RepAtom(AtomOfTerm(tfile))->StrOfAE;
|
|
|
|
|
|
fd = open(filename, O_RDWR|O_CREAT, S_IRUSR|S_IWUSR);
|
|
if (fd == -1) {
|
|
Error(SYSTEM_ERROR,ARG1,"create_mmapped_array (open: %s)", strerror(errno));
|
|
return(FALSE);
|
|
}
|
|
if (lseek(fd, total_size-1, SEEK_SET) < 0)
|
|
Error(SYSTEM_ERROR,tfile,"create_mmapped_array (lseek: %s)", strerror(errno));
|
|
if (write(fd, "", 1) < 0)
|
|
Error(SYSTEM_ERROR,tfile,"create_mmapped_array (write: %s)", strerror(errno));
|
|
/*
|
|
if (ftruncate(fd, total_size) < 0)
|
|
Error(SYSTEM_ERROR,tfile,"create_mmapped_array");
|
|
*/
|
|
if ((array_addr = (CODEADDR)mmap(0, (size_t) total_size, PROT_READ | PROT_WRITE, MAP_SHARED, fd, 0)) == (CODEADDR) - 1)
|
|
Error(SYSTEM_ERROR,tfile,"create_mmapped_array (mmap: %s)", strerror(errno));
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,tfile,"create_mmapped_array");
|
|
return (FALSE);
|
|
}
|
|
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"create_mmapped_array");
|
|
return (FALSE);
|
|
}
|
|
else if (IsAtomTerm(t)) {
|
|
/* Create a named array */
|
|
AtomEntry *ae = RepAtom(AtomOfTerm(t));
|
|
StaticArrayEntry *pp;
|
|
|
|
WRITE_LOCK(ae->ARWLock);
|
|
pp = RepStaticArrayProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
|
pp = RepStaticArrayProp(pp->NextOfPE);
|
|
if (!EndOfPAEntr(pp)) {
|
|
WRITE_LOCK(pp->ArRWLock);
|
|
}
|
|
if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
|
|
mmap_array_block *ptr;
|
|
|
|
CreateStaticArray(ae, size, props, array_addr, pp);
|
|
ptr = (mmap_array_block *)AllocAtomSpace(sizeof(mmap_array_block));
|
|
ptr->name = AbsAtom(ae);
|
|
ptr->size = total_size;
|
|
ptr->items = size;
|
|
ptr->start = (void *)array_addr;
|
|
ptr->fd = fd;
|
|
ptr->next = mmap_arrays;
|
|
mmap_arrays = ptr;
|
|
return(TRUE);
|
|
} else {
|
|
WRITE_UNLOCK(pp->ArRWLock);
|
|
WRITE_UNLOCK(ae->ARWLock);
|
|
Error(DOMAIN_ERROR_ARRAY_TYPE,t,"create_mmapped_array", ae->StrOfAE);
|
|
return(FALSE);
|
|
}
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,t,"create_mmapped_array");
|
|
return (FALSE);
|
|
}
|
|
#else
|
|
Error(SYSTEM_ERROR,ARG1,"create_mmapped_array (mmap)");
|
|
return (FALSE);
|
|
#endif
|
|
}
|
|
|
|
/* This routine verifies whether a complex has variables. */
|
|
static void
|
|
replace_array_references_complex(register CELL *pt0,
|
|
register CELL *pt0_end,
|
|
register CELL *ptn,
|
|
Term Var)
|
|
{
|
|
|
|
register CELL **to_visit = (CELL **) PreAllocCodeSpace();
|
|
CELL **to_visit_base = to_visit;
|
|
|
|
loop:
|
|
while (pt0 < pt0_end) {
|
|
register CELL d0;
|
|
|
|
++pt0;
|
|
d0 = Derefa(pt0);
|
|
if (IsVarTerm(d0)) {
|
|
*ptn++ = d0;
|
|
}
|
|
else if (IsPairTerm(d0)) {
|
|
/* store the terms to visit */
|
|
*ptn++ = AbsPair(H);
|
|
#ifdef RATIONAL_TREES
|
|
to_visit[0] = pt0;
|
|
to_visit[1] = pt0_end;
|
|
to_visit[2] = ptn;
|
|
to_visit[3] = (CELL *)*pt0;
|
|
to_visit += 4;
|
|
*pt0 = TermNil;
|
|
#else
|
|
if (pt0 < pt0_end) {
|
|
to_visit[0] = pt0;
|
|
to_visit[1] = pt0_end;
|
|
to_visit[2] = ptn;
|
|
to_visit += 3;
|
|
}
|
|
#endif
|
|
pt0 = RepPair(d0) - 1;
|
|
pt0_end = RepPair(d0) + 1;
|
|
/* write the head and tail of the list */
|
|
ptn = H;
|
|
H += 2;
|
|
}
|
|
else if (IsApplTerm(d0)) {
|
|
register Functor f;
|
|
|
|
f = FunctorOfTerm(d0);
|
|
/* store the terms to visit */
|
|
if (IsExtensionFunctor(f)) {
|
|
{
|
|
*ptn++ = d0;
|
|
continue;
|
|
}
|
|
}
|
|
*ptn++ = AbsAppl(H);
|
|
/* store the terms to visit */
|
|
#ifdef RATIONAL_TREES
|
|
to_visit[0] = pt0;
|
|
to_visit[1] = pt0_end;
|
|
to_visit[2] = ptn;
|
|
to_visit[3] = (CELL *)*pt0;
|
|
to_visit += 4;
|
|
*pt0 = TermNil;
|
|
#else
|
|
if (pt0 < pt0_end) {
|
|
to_visit[0] = pt0;
|
|
to_visit[1] = pt0_end;
|
|
to_visit[2] = ptn;
|
|
to_visit += 3;
|
|
}
|
|
#endif
|
|
pt0 = RepAppl(d0);
|
|
d0 = ArityOfFunctor(f);
|
|
pt0_end = pt0 + d0;
|
|
/* start writing the compound term */
|
|
ptn = H;
|
|
*ptn++ = (CELL) f;
|
|
H += d0 + 1;
|
|
}
|
|
else { /* AtomOrInt */
|
|
*ptn++ = d0;
|
|
}
|
|
/* just continue the loop */
|
|
}
|
|
|
|
/* Do we still have compound terms to visit */
|
|
if (to_visit > (CELL **) to_visit_base) {
|
|
#ifdef RATIONAL_TREES
|
|
to_visit -= 4;
|
|
pt0 = to_visit[0];
|
|
pt0_end = to_visit[1];
|
|
ptn = to_visit[2];
|
|
*pt0 = (CELL)to_visit[3];
|
|
#else
|
|
to_visit -= 3;
|
|
pt0 = to_visit[0];
|
|
pt0_end = to_visit[1];
|
|
ptn = to_visit[2];
|
|
#endif
|
|
goto loop;
|
|
}
|
|
|
|
Bind_Global(PtrOfTerm(Var), TermNil);
|
|
ReleasePreAllocCodeSpace((ADDR)to_visit);
|
|
}
|
|
|
|
/*
|
|
*
|
|
* Given a term t0, build a new term tf of the form ta+tb, where ta is
|
|
* obtained by replacing the array references in t0 by empty
|
|
* variables, and tb is a list of array references and corresponding
|
|
* variables.
|
|
*/
|
|
static Term
|
|
replace_array_references(Term t0)
|
|
{
|
|
Term t;
|
|
|
|
t = Deref(t0);
|
|
do {
|
|
if (IsVarTerm(t)) {
|
|
/* we found a variable */
|
|
return (MkPairTerm(t, TermNil));
|
|
}
|
|
else if (IsAtomOrIntTerm(t)) {
|
|
return (MkPairTerm(t, TermNil));
|
|
}
|
|
else if (IsPairTerm(t)) {
|
|
Term VList = MkVarTerm();
|
|
CELL *h0 = H;
|
|
|
|
H += 2;
|
|
replace_array_references_complex(RepPair(t) - 1, RepPair(t) + 1, h0,
|
|
VList);
|
|
return (MkPairTerm(AbsPair(h0), VList));
|
|
}
|
|
else {
|
|
Term VList = MkVarTerm();
|
|
CELL *h0 = H;
|
|
Functor f = FunctorOfTerm(t);
|
|
|
|
*H++ = (CELL) (f);
|
|
H += ArityOfFunctor(f);
|
|
replace_array_references_complex(RepAppl(t),
|
|
RepAppl(t) + ArityOfFunctor(FunctorOfTerm(t)), h0 + 1,
|
|
VList);
|
|
return (MkPairTerm(AbsAppl(h0), VList));
|
|
}
|
|
} while (TRUE);
|
|
/* make lcc happy */
|
|
return(FALSE);
|
|
}
|
|
|
|
static Int
|
|
p_array_references(void)
|
|
{
|
|
Term t = replace_array_references(ARG1);
|
|
Term t1 = HeadOfTerm(t);
|
|
Term t2 = TailOfTerm(t);
|
|
|
|
return (unify(t1, ARG2) && unify(t2, ARG3));
|
|
}
|
|
|
|
static Int
|
|
p_assign_static(void)
|
|
{
|
|
Term t1, t2, t3;
|
|
StaticArrayEntry *ptr;
|
|
Int indx;
|
|
|
|
t2 = Deref(ARG2);
|
|
if (IsNonVarTerm(t2)) {
|
|
if (IsIntTerm(t2))
|
|
indx = IntOfTerm(t2);
|
|
else {
|
|
union arith_ret v;
|
|
if (Eval(t2, &v) == long_int_e) {
|
|
indx = v.Int;
|
|
} else {
|
|
Error(TYPE_ERROR_INTEGER,t2,"update_array");
|
|
return (FALSE);
|
|
}
|
|
}
|
|
} else {
|
|
Error(INSTANTIATION_ERROR,t2,"update_array");
|
|
return (FALSE);
|
|
}
|
|
t3 = Deref(ARG3);
|
|
|
|
t1 = Deref(ARG1);
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR,t1,"update_array");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(t1)) {
|
|
if (IsApplTerm(t1)) {
|
|
CELL *ptr;
|
|
Functor f = FunctorOfTerm(t1);
|
|
/* store the terms to visit */
|
|
if (IsExtensionFunctor(f)) {
|
|
Error(TYPE_ERROR_ARRAY,t1,"update_array");
|
|
return(FALSE);
|
|
}
|
|
if (indx > 0 && (UInt)indx > ArityOfFunctor(f)) {
|
|
Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"update_array");
|
|
return(FALSE);
|
|
}
|
|
ptr = RepAppl(t1)+indx+1;
|
|
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
|
MaBind(ptr, t3);
|
|
return(TRUE);
|
|
#else
|
|
Error(SYSTEM_ERROR,t2,"update_array");
|
|
return(FALSE);
|
|
#endif
|
|
} else {
|
|
Error(TYPE_ERROR_ATOM,t1,"update_array");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
{
|
|
AtomEntry *ae = RepAtom(AtomOfTerm(t1));
|
|
|
|
READ_LOCK(ae->ARWLock);
|
|
ptr = RepStaticArrayProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
|
|
ptr = RepStaticArrayProp(ptr->NextOfPE);
|
|
READ_UNLOCK(ae->ARWLock);
|
|
}
|
|
|
|
if (EndOfPAEntr(ptr)) {
|
|
Error(EXISTENCE_ERROR_ARRAY,t1,"assign_static %s", RepAtom(AtomOfTerm(t1))->StrOfAE);
|
|
return(FALSE);
|
|
}
|
|
|
|
WRITE_LOCK(ptr->ArRWLock);
|
|
if (ArrayIsDynamic((ArrayEntry *)ptr)) {
|
|
ArrayEntry *pp = (ArrayEntry *)ptr;
|
|
CELL *pt;
|
|
if (indx < 0 || indx >= pp->ArrayEArity) {
|
|
Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static");
|
|
READ_UNLOCK(((ArrayEntry *)ptr)->ArRWLock);
|
|
return(FALSE);
|
|
}
|
|
pt = RepAppl(pp->ValueOfVE) + indx + 1;
|
|
WRITE_UNLOCK(((ArrayEntry *)ptr)->ArRWLock);
|
|
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
|
/* the evil deed is to be done now */
|
|
MaBind(pt, t3);
|
|
return(TRUE);
|
|
#else
|
|
Error(SYSTEM_ERROR,t2,"update_array");
|
|
return(FALSE);
|
|
#endif
|
|
}
|
|
|
|
/* a static array */
|
|
if (IsVarTerm(t3)) {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(INSTANTIATION_ERROR,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
if (indx < 0 || indx >= - ptr->ArrayEArity) {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static");
|
|
}
|
|
switch (ptr->ArrayType) {
|
|
case array_of_ints:
|
|
{
|
|
Int i;
|
|
union arith_ret v;
|
|
|
|
if (IsIntTerm(t3))
|
|
i = IntOfTerm(t3);
|
|
else if (Eval(t3, &v) == long_int_e)
|
|
i = v.Int;
|
|
else {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_INTEGER,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
ptr->ValueOfVE.ints[indx]= i;
|
|
}
|
|
break;
|
|
|
|
case array_of_chars:
|
|
{
|
|
Int i;
|
|
union arith_ret v;
|
|
|
|
if (IsIntTerm(t3))
|
|
i = IntOfTerm(t3);
|
|
else if (Eval(t3, &v) == long_int_e)
|
|
i = v.Int;
|
|
else {
|
|
Error(TYPE_ERROR_INTEGER,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
if (i > 127 || i < -128) {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_BYTE,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
ptr->ValueOfVE.chars[indx]= i;
|
|
}
|
|
break;
|
|
|
|
case array_of_uchars:
|
|
{
|
|
Int i;
|
|
union arith_ret v;
|
|
|
|
if (IsIntTerm(t3))
|
|
i = IntOfTerm(t3);
|
|
else if (Eval(t3, &v) == long_int_e)
|
|
i = v.Int;
|
|
else {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_INTEGER,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
if (i > 255 || i < 0) {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_UBYTE,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
ptr->ValueOfVE.chars[indx]= i;
|
|
}
|
|
break;
|
|
|
|
case array_of_doubles:
|
|
{
|
|
Float f;
|
|
union arith_ret v;
|
|
|
|
if (IsFloatTerm(t3))
|
|
f = FloatOfTerm(t3);
|
|
else if (Eval(t3, &v) == double_e)
|
|
f = v.dbl;
|
|
else {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_FLOAT,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
ptr->ValueOfVE.floats[indx]= f;
|
|
}
|
|
break;
|
|
|
|
case array_of_ptrs:
|
|
{
|
|
Int r;
|
|
|
|
if (IsIntegerTerm(t3))
|
|
r = IntegerOfTerm(t3);
|
|
else {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_PTR,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
ptr->ValueOfVE.ptrs[indx]= (AtomEntry *)r;
|
|
}
|
|
break;
|
|
|
|
case array_of_atoms:
|
|
{
|
|
if (!IsAtomTerm(t3)) {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_ATOM,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
ptr->ValueOfVE.atoms[indx]= t3;
|
|
}
|
|
break;
|
|
|
|
case array_of_dbrefs:
|
|
{
|
|
|
|
Term t0 = ptr->ValueOfVE.dbrefs[indx];
|
|
|
|
if (!IsDBRefTerm(t3)) {
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
Error(TYPE_ERROR_DBREF,t3,"assign_static");
|
|
return (FALSE);
|
|
}
|
|
ptr->ValueOfVE.dbrefs[indx]= t3;
|
|
if (t0 != 0L)
|
|
DBRefOfTerm(t0)->NOfRefsTo--;
|
|
DBRefOfTerm(t3)->NOfRefsTo++;
|
|
}
|
|
break;
|
|
|
|
case array_of_terms:
|
|
{
|
|
|
|
DBRef ref = ptr->ValueOfVE.terms[indx];
|
|
|
|
if (ref != NULL) {
|
|
ReleaseTermFromDB(ref);
|
|
}
|
|
ptr->ValueOfVE.terms[indx] = StoreTermInDB(t3,3);
|
|
}
|
|
break;
|
|
}
|
|
WRITE_UNLOCK(ptr->ArRWLock);
|
|
return(TRUE);
|
|
}
|
|
|
|
int compile_arrays = FALSE;
|
|
|
|
|
|
static Int
|
|
p_compile_array_refs(void)
|
|
{
|
|
compile_arrays = TRUE;
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_array_refs_compiled(void)
|
|
{
|
|
return (compile_arrays);
|
|
}
|
|
|
|
static Int
|
|
p_sync_mmapped_arrays(void)
|
|
{
|
|
#ifdef HAVE_MMAP
|
|
mmap_array_block *ptr = mmap_arrays;
|
|
while (ptr != NULL) {
|
|
msync(ptr->start, ptr->size, MS_SYNC);
|
|
ptr = ptr->next;
|
|
}
|
|
#endif
|
|
return(TRUE);
|
|
}
|
|
|
|
/*
|
|
This is a hack, to steal the first element of a key.
|
|
|
|
It first fetches the first element in the chain, and then erases it
|
|
through its reference.
|
|
|
|
Be careful when using this routine. It is especially evil because if
|
|
the term is ground it should be copied to the stack, as space for
|
|
the entry may be deleted. For the moment, the terms I want are just
|
|
integers, so no problemo, amigo.
|
|
|
|
*/
|
|
static Term
|
|
StealFirstFromDB(DBRef ref)
|
|
{
|
|
Term TermDB, out;
|
|
|
|
if ((TermDB = FetchTermFromDB(ref,3)) == (CELL)0) {
|
|
/* oops, we are in trouble, not enough stack space */
|
|
return(TermNil);
|
|
}
|
|
if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
|
|
/* it's not a wonderful world afterall */
|
|
return(TermNil);
|
|
out = ArgOfTerm(1,TermDB);
|
|
/* now, return what once was there, only nevermore */
|
|
return(out);
|
|
}
|
|
|
|
Int
|
|
SetDBForThrow(Term Message)
|
|
{
|
|
Term cut_pt_term;
|
|
Atom a = FullLookupAtom("$catch_queue");
|
|
AtomEntry *ae = RepAtom(a);
|
|
StaticArrayEntry *ptr;
|
|
DBRef ref;
|
|
READ_LOCK(ae->ARWLock);
|
|
ptr = RepStaticArrayProp(ae->PropsOfAE);
|
|
while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
|
|
ptr = RepStaticArrayProp(ptr->NextOfPE);
|
|
READ_UNLOCK(ae->ARWLock);
|
|
ref = ptr->ValueOfVE.terms[0];
|
|
|
|
cut_pt_term = StealFirstFromDB(ref);
|
|
if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
|
|
/* ooops, babe we are in trouble */
|
|
return(-1);
|
|
}
|
|
/* OK, we've got the place to cut to, next store the new throw */
|
|
ptr->ValueOfVE.terms[1] = StoreTermInDB(Message,3);
|
|
return(IntegerOfTerm(cut_pt_term));
|
|
}
|
|
|
|
void
|
|
InitArrayPreds(void)
|
|
{
|
|
InitCPred("$create_array", 2, p_create_array, SyncPredFlag);
|
|
InitCPred("$array_references", 3, p_array_references, SafePredFlag);
|
|
InitCPred("$array_arg", 3, p_array_arg, SafePredFlag);
|
|
InitCPred("static_array", 3, p_create_static_array, SafePredFlag|SyncPredFlag);
|
|
InitCPred("resize_static_array", 3, p_resize_static_array, SafePredFlag|SyncPredFlag);
|
|
InitCPred("mmapped_array", 4, p_create_mmapped_array, SafePredFlag|SyncPredFlag);
|
|
InitCPred("update_array", 3, p_assign_static, SafePredFlag);
|
|
InitCPred("array_element", 3, p_access_array, 0);
|
|
InitCPred("close_static_array", 1, p_close_static_array, SafePredFlag);
|
|
InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag);
|
|
InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);
|
|
InitCPred("$array_refs_compiled", 0, p_array_refs_compiled, SafePredFlag);
|
|
InitCPred("$has_static_array", 1, p_has_static_array, TestPredFlag|SafePredFlag);
|
|
}
|
|
|