b289d9ac9c
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@177 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2208 lines
53 KiB
C
2208 lines
53 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: stdpreds.c *
|
|
* Last rev: *
|
|
* mods: *
|
|
* comments: General-purpose C implemented system predicates *
|
|
* *
|
|
*************************************************************************/
|
|
#ifdef SCCS
|
|
static char SccsId[] = "%W% %G%";
|
|
#endif
|
|
|
|
|
|
/*
|
|
* This file includes the definition of a miscellania of standard predicates
|
|
* for yap refering to: Consulting, Executing a C predicate from call,
|
|
* Comparisons (both general and numeric), Structure manipulation, Direct
|
|
* access to atoms and predicates, Basic support for the debugger
|
|
*
|
|
* It also includes a table where all C-predicates are initializated
|
|
*
|
|
*/
|
|
|
|
#include "Yap.h"
|
|
#include "Yatom.h"
|
|
#include "Heap.h"
|
|
#include "eval.h"
|
|
#include "yapio.h"
|
|
#include <stdio.h>
|
|
#if HAVE_STRING_H
|
|
#include <string.h>
|
|
#endif
|
|
|
|
STD_PROTO(static Int p_setval, (void));
|
|
STD_PROTO(static Int p_value, (void));
|
|
STD_PROTO(static Int p_values, (void));
|
|
STD_PROTO(static Int p_flipflop, (void));
|
|
STD_PROTO(static Int p_setflop, (void));
|
|
#ifdef undefined
|
|
STD_PROTO(static CODEADDR *FindAtom, (CODEADDR, int *));
|
|
#endif /* undefined */
|
|
STD_PROTO(static Int p_opdec, (void));
|
|
STD_PROTO(static Term get_num, (char *));
|
|
STD_PROTO(static Int p_name, (void));
|
|
STD_PROTO(static Int p_atom_chars, (void));
|
|
STD_PROTO(static Int p_atom_codes, (void));
|
|
STD_PROTO(static Int p_atom_length, (void));
|
|
STD_PROTO(static Int p_atom_split, (void));
|
|
STD_PROTO(static Int p_number_chars, (void));
|
|
STD_PROTO(static Int p_number_codes, (void));
|
|
STD_PROTO(static Int p_univ, (void));
|
|
STD_PROTO(static Int p_abort, (void));
|
|
STD_PROTO(static Int p_halt, (void));
|
|
STD_PROTO(static Int p_halt0, (void));
|
|
STD_PROTO(static Int init_current_atom, (void));
|
|
STD_PROTO(static Int cont_current_atom, (void));
|
|
STD_PROTO(static Int init_current_predicate, (void));
|
|
STD_PROTO(static Int cont_current_predicate, (void));
|
|
STD_PROTO(static OpEntry *NextOp, (OpEntry *));
|
|
STD_PROTO(static Int init_current_op, (void));
|
|
STD_PROTO(static Int cont_current_op, (void));
|
|
#ifdef DEBUG
|
|
STD_PROTO(static Int p_debug, (void));
|
|
#endif
|
|
STD_PROTO(static Int p_flags, (void));
|
|
STD_PROTO(static int AlreadyHidden, (char *));
|
|
STD_PROTO(static Int p_hide, (void));
|
|
STD_PROTO(static Int p_hidden, (void));
|
|
STD_PROTO(static Int p_unhide, (void));
|
|
STD_PROTO(static Int TrailMax, (void));
|
|
STD_PROTO(static Int GlobalMax, (void));
|
|
STD_PROTO(static Int LocalMax, (void));
|
|
STD_PROTO(static Int p_statistics_heap_max, (void));
|
|
STD_PROTO(static Int p_statistics_global_max, (void));
|
|
STD_PROTO(static Int p_statistics_local_max, (void));
|
|
STD_PROTO(static Int p_statistics_heap_info, (void));
|
|
STD_PROTO(static Int p_statistics_stacks_info, (void));
|
|
STD_PROTO(static Int p_statistics_trail_info, (void));
|
|
STD_PROTO(static Term mk_argc_list, (void));
|
|
STD_PROTO(static Int p_argv, (void));
|
|
STD_PROTO(static Int p_cputime, (void));
|
|
STD_PROTO(static Int p_runtime, (void));
|
|
STD_PROTO(static Int p_walltime, (void));
|
|
STD_PROTO(static Int p_access_yap_flags, (void));
|
|
STD_PROTO(static Int p_set_yap_flags, (void));
|
|
|
|
|
|
static Int
|
|
p_setval(void)
|
|
{ /* '$set_value'(+Atom,+Atomic) */
|
|
Term t1 = Deref(ARG1), t2 = Deref(ARG2);
|
|
if (!IsVarTerm(t1) && IsAtomTerm(t1) &&
|
|
(!IsVarTerm(t2) && (IsAtomTerm(t2) || IsNumTerm(t2)))) {
|
|
PutValue(AtomOfTerm(t1), t2);
|
|
return (TRUE);
|
|
}
|
|
return (FALSE);
|
|
}
|
|
|
|
static Int
|
|
p_value(void)
|
|
{ /* '$get_value'(+Atom,?Val) */
|
|
Term t1 = Deref(ARG1);
|
|
if (!IsAtomTerm(t1))
|
|
return (FALSE);
|
|
return (unify_constant(ARG2, GetValue(AtomOfTerm(t1))));
|
|
}
|
|
|
|
|
|
static Int
|
|
p_values(void)
|
|
{ /* '$values'(Atom,Old,New) */
|
|
Term t1 = Deref(ARG1), t3 = Deref(ARG3);
|
|
|
|
if (!IsAtomTerm(t1))
|
|
return (FALSE);
|
|
if (!unify_constant(ARG2, GetValue(AtomOfTerm(t1))))
|
|
return (FALSE);
|
|
if (!IsVarTerm(t3)) {
|
|
if (IsAtomTerm(t3) || IsNumTerm(t3)) {
|
|
PutValue(AtomOfTerm(t1), t3);
|
|
} else
|
|
return (FALSE);
|
|
}
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_flipflop(void)
|
|
{ /* '$flipflop' */
|
|
Atom at;
|
|
PredEntry *pred;
|
|
|
|
at = FullLookupAtom("$spy");
|
|
pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0));
|
|
SpyCode = pred;
|
|
return ((int) (FlipFlop = (1 - FlipFlop)));
|
|
}
|
|
|
|
static Int
|
|
p_setflop(void)
|
|
{ /* '$setflop'(N) */
|
|
Term t = Deref(ARG1);
|
|
|
|
if (IsIntTerm(t)) {
|
|
FlipFlop = IntOfTerm(t) & 1;
|
|
return (TRUE);
|
|
}
|
|
return (FALSE);
|
|
}
|
|
|
|
Int
|
|
p_creep(void)
|
|
{
|
|
Atom at;
|
|
PredEntry *pred;
|
|
|
|
at = FullLookupAtom("$creep");
|
|
pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0));
|
|
CreepCode = pred;
|
|
CreepFlag = Unsigned(LCL0)-Unsigned(H0);
|
|
return (TRUE);
|
|
}
|
|
|
|
#ifdef undefined
|
|
|
|
/*
|
|
* Returns where some particular piece of code is, it may take its time but
|
|
* then you only need it while creeping, so why bother ?
|
|
*/
|
|
static CODEADDR *
|
|
FindAtom(codeToFind, arity)
|
|
CODEADDR codeToFind;
|
|
unsigned int *arityp;
|
|
{
|
|
Atom a;
|
|
int i;
|
|
|
|
for (i = 0; i < MaxHash; ++i) {
|
|
READ_LOCK(HashChain[i].AeRWLock);
|
|
a = HashChain[i].Entry;
|
|
READ_UNLOCK(HashChain[i].AeRWLock);
|
|
while (a != NIL) {
|
|
register PredEntry *pp;
|
|
AtomEntry *ae = RepAtom(a);
|
|
READ_LOCK(ae->ARWLock);
|
|
pp = RepPredProp(RepAtom(a)->PropsOfAE);
|
|
while (!EndOfPAEntr(pp) && ((pp->KindOfPE & 0x8000)
|
|
|| (pp->CodeOfPred != codeToFind)))
|
|
pp = RepPredProp(pp->NextOfPE);
|
|
if (pp != NIL) {
|
|
CODEADDR *out;
|
|
READ_LOCK(pp->PRWLock);
|
|
out = &(pp->CodeOfPred)
|
|
*arityp = pp->ArityOfPE;
|
|
READ_UNLOCK(pp->PRWLock);
|
|
READ_UNLOCK(ae->ARWLock);
|
|
return (out);
|
|
}
|
|
a = RepAtom(a)->NextOfAE;
|
|
READ_UNLOCK(ae->ARWLock);
|
|
}
|
|
}
|
|
*arityp = 0;
|
|
return (0);
|
|
}
|
|
|
|
/*
|
|
* This is called when you want to creep a C-predicate or a predicate written
|
|
* in assembly
|
|
*/
|
|
CELL
|
|
FindWhatCreep(toCreep)
|
|
CELL toCreep;
|
|
{
|
|
unsigned int arity;
|
|
Atom at;
|
|
CODEADDR *place;
|
|
|
|
if (toCreep > 64) { /* written in C */
|
|
int i;
|
|
place = FindAtom((CODEADDR) toCreep, &arity);
|
|
*--ASP = Unsigned(P);
|
|
*--ASP = N = arity;
|
|
for (i = 1; i <= arity; ++i)
|
|
*--ASP = X[i];
|
|
/* P = CellPtr(CCREEPCODE); */
|
|
return (Unsigned(place));
|
|
}
|
|
}
|
|
|
|
#endif /* undefined */
|
|
|
|
static Int
|
|
p_opdec(void)
|
|
{ /* '$op'(p,type,atom) */
|
|
/* we know the arguments are integer, atom, atom */
|
|
Term p = Deref(ARG1), t = Deref(ARG2), at = Deref(ARG3);
|
|
return (OpDec((int) IntOfTerm(p), RepAtom(AtomOfTerm(t))->StrOfAE,
|
|
AtomOfTerm(at)));
|
|
}
|
|
|
|
|
|
#ifdef NO_STRTOD
|
|
|
|
#if HAVE_CTYPE_H
|
|
#include <ctype.h>
|
|
#endif
|
|
|
|
double
|
|
strtod(s, pe)
|
|
char *s, **pe;
|
|
{
|
|
double r = atof(s);
|
|
*pe = s;
|
|
while (*s == ' ')
|
|
++s;
|
|
if (*s == '+' || *s == '-')
|
|
++s;
|
|
if (!isdigit(*s))
|
|
return (r);
|
|
while (isdigit(*s))
|
|
++s;
|
|
if (*s == '.')
|
|
++s;
|
|
while (isdigit(*s))
|
|
++s;
|
|
if (*s == 'e' || *s == 'E')
|
|
++s;
|
|
if (*s == '+' || *s == '-')
|
|
++s;
|
|
while (isdigit(*s))
|
|
++s;
|
|
*pe = s;
|
|
return (r);
|
|
}
|
|
|
|
#else
|
|
|
|
#include <stdlib.h>
|
|
|
|
#endif
|
|
|
|
static char *cur_char_ptr;
|
|
|
|
static int
|
|
get_char_from_string(int sno)
|
|
{
|
|
if (cur_char_ptr[0] == '\0')
|
|
return(-1);
|
|
cur_char_ptr++;
|
|
return((int)(cur_char_ptr[-1]));
|
|
}
|
|
|
|
|
|
static Term
|
|
get_num(char *t)
|
|
{
|
|
Term out;
|
|
|
|
cur_char_ptr = t;
|
|
out = scan_num(get_char_from_string);
|
|
/* not ever iso */
|
|
if (out == TermNil && yap_flags[LANGUAGE_MODE_FLAG] != 1) {
|
|
int sign = 1;
|
|
if (t[0] == '+') {
|
|
t++;
|
|
}
|
|
if (t[0] == '-') {
|
|
t++;
|
|
sign = -1;
|
|
}
|
|
if(strcmp(t,"inf") == 0) {
|
|
Term ta[1];
|
|
ta[0] = MkAtomTerm(LookupAtom("inf"));
|
|
if (sign > 0) {
|
|
return(MkApplTerm(MkFunctor(AtomPlus, 1), 1, ta));
|
|
}
|
|
return(MkApplTerm(MkFunctor(AtomMinus, 1), 1, ta));
|
|
}
|
|
if(strcmp(t,"nan") == 0) {
|
|
Term ta[1];
|
|
ta[0] = MkAtomTerm(LookupAtom("nan"));
|
|
if (sign > 0) {
|
|
return(MkApplTerm(MkFunctor(AtomPlus, 1), 1, ta));
|
|
}
|
|
return(MkApplTerm(MkFunctor(AtomMinus, 1), 1, ta));
|
|
}
|
|
}
|
|
if (cur_char_ptr[0] == '\0')
|
|
return(out);
|
|
else
|
|
return(TermNil);
|
|
}
|
|
|
|
Int
|
|
runtime(void)
|
|
{
|
|
return(cputime()-total_gc_time()-total_stack_shift_time());
|
|
}
|
|
|
|
Int last_gc_time = 0;
|
|
Int last_ss_time = 0;
|
|
|
|
/* $runtime(-SinceInterval,-SinceStart) */
|
|
static Int
|
|
p_runtime(void)
|
|
{
|
|
Int now, interval,
|
|
gc_time,
|
|
ss_time;
|
|
|
|
cputime_interval(&now, &interval);
|
|
gc_time = total_gc_time();
|
|
ss_time = total_stack_shift_time();
|
|
now -= gc_time+ss_time;
|
|
interval -= (gc_time-last_gc_time)+(ss_time-last_ss_time);
|
|
last_gc_time = gc_time;
|
|
last_ss_time = ss_time;
|
|
return( unify_constant(ARG1, MkIntegerTerm(now)) &&
|
|
unify_constant(ARG2, MkIntegerTerm(interval)) );
|
|
}
|
|
|
|
/* $cputime(-SinceInterval,-SinceStart) */
|
|
static Int
|
|
p_cputime(void)
|
|
{
|
|
Int now, interval;
|
|
cputime_interval(&now, &interval);
|
|
return( unify_constant(ARG1, MkIntegerTerm(now)) &&
|
|
unify_constant(ARG2, MkIntegerTerm(interval)) );
|
|
}
|
|
|
|
static Int
|
|
p_walltime(void)
|
|
{
|
|
Int now, interval;
|
|
walltime_interval(&now, &interval);
|
|
return( unify_constant(ARG1, MkIntegerTerm(now)) &&
|
|
unify_constant(ARG2, MkIntegerTerm(interval)) );
|
|
}
|
|
|
|
static Int
|
|
p_char_code(void)
|
|
{
|
|
Int t0 = Deref(ARG1);
|
|
if (IsVarTerm(t0)) {
|
|
Term t1 = Deref(ARG2);
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR,t0,"char_code/2");
|
|
return(FALSE);
|
|
} else if (!IsIntegerTerm(t1)) {
|
|
Error(TYPE_ERROR_INTEGER,t1,"char_code/2");
|
|
return(FALSE);
|
|
} else {
|
|
Int code = IntegerOfTerm(t1);
|
|
char codes[2];
|
|
Term tout;
|
|
|
|
if (code < 0 || code > 256) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,t1,"char_code/2");
|
|
return(FALSE);
|
|
}
|
|
codes[0] = code;
|
|
codes[1] = '\0';
|
|
tout = MkAtomTerm(LookupAtom(codes));
|
|
return(unify(ARG1,tout));
|
|
}
|
|
} else if (!IsAtomTerm(t0)) {
|
|
Error(TYPE_ERROR_CHARACTER,t0,"char_code/2");
|
|
return(FALSE);
|
|
} else {
|
|
char *c = RepAtom(AtomOfTerm(t0))->StrOfAE;
|
|
if (c[1] != '\0') {
|
|
Error(TYPE_ERROR_CHARACTER,t0,"char_code/2");
|
|
return(FALSE);
|
|
}
|
|
return(unify(ARG2,MkIntTerm((Int)(c[0]))));
|
|
}
|
|
}
|
|
|
|
static Int
|
|
p_name(void)
|
|
{ /* name(?Atomic,?String) */
|
|
char *String = (char *)TR, *s; /* alloc temp space on trail */
|
|
Term t, NewT, AtomNameT = Deref(ARG1);
|
|
|
|
ARG2 = Deref(ARG2);
|
|
if (!IsVarTerm(AtomNameT)) {
|
|
if (IsAtomTerm(AtomNameT)) {
|
|
s = RepAtom(AtomOfTerm(AtomNameT))->StrOfAE;
|
|
NewT = StringToList(s);
|
|
if (!IsVarTerm(ARG2) && !IsPairTerm(ARG2)) {
|
|
Error(TYPE_ERROR_LIST,ARG2,
|
|
"name/2");
|
|
return(FALSE);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsIntTerm(AtomNameT)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", IntOfTerm(AtomNameT));
|
|
#else
|
|
sprintf(String, "%d", IntOfTerm(AtomNameT));
|
|
#endif
|
|
NewT = StringToList(String);
|
|
if (!IsVarTerm(ARG2) && !IsPairTerm(ARG2)) {
|
|
Error(TYPE_ERROR_LIST,ARG2,"name/2");
|
|
return(FALSE);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsFloatTerm(AtomNameT)) {
|
|
sprintf(String, "%f", FloatOfTerm(AtomNameT));
|
|
NewT = StringToList(String);
|
|
if (!IsVarTerm(ARG2) && !IsPairTerm(ARG2)) {
|
|
Error(TYPE_ERROR_LIST,ARG2,"name/2");
|
|
return(FALSE);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsLongIntTerm(AtomNameT)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", LongIntOfTerm(AtomNameT));
|
|
#else
|
|
sprintf(String, "%d", LongIntOfTerm(AtomNameT));
|
|
#endif
|
|
NewT = StringToList(String);
|
|
if (!IsVarTerm(ARG2) && !IsPairTerm(ARG2)) {
|
|
Error(TYPE_ERROR_LIST,ARG2,"name/2");
|
|
return(FALSE);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
} else {
|
|
Error(TYPE_ERROR_ATOMIC,AtomNameT,"name/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
t = ARG2;
|
|
s = String;
|
|
if (!IsVarTerm(t) && t == MkAtomTerm(AtomNil)) {
|
|
return (unify_constant(ARG1, MkAtomTerm(LookupAtom(""))));
|
|
}
|
|
while (!IsVarTerm(t) && IsPairTerm(t)) {
|
|
Term Head;
|
|
Int i;
|
|
Head = HeadOfTerm(t);
|
|
if (IsVarTerm(Head)) {
|
|
Error(INSTANTIATION_ERROR,Head,"name/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsIntTerm(Head)) {
|
|
Error(TYPE_ERROR_INTEGER,Head,"name/2");
|
|
return(FALSE);
|
|
}
|
|
i = IntOfTerm(Head);
|
|
if (i < 0 || i > 255) {
|
|
if (i<0)
|
|
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,Head,"name/2");
|
|
return(FALSE);
|
|
}
|
|
*s++ = i;
|
|
t = TailOfTerm(t);
|
|
}
|
|
*s = '\0';
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"name/2");
|
|
return(FALSE);
|
|
}
|
|
if (IsAtomTerm(t) && AtomOfTerm(t) == AtomNil) {
|
|
if ((NewT = get_num(String)) == TermNil) {
|
|
NewT = MkAtomTerm(LookupAtom(String));
|
|
}
|
|
return (unify_constant(ARG1, NewT));
|
|
} else {
|
|
Error(TYPE_ERROR_LIST,t,"name/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
|
|
static Int
|
|
p_atom_chars(void)
|
|
{
|
|
Term t1 = Deref(ARG1);
|
|
if (!IsVarTerm(t1)) {
|
|
Term NewT;
|
|
if (!IsAtomTerm(t1)) {
|
|
Error(TYPE_ERROR_ATOM, t1, "atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
|
|
NewT = StringToList(RepAtom(AtomOfTerm(t1))->StrOfAE);
|
|
} else {
|
|
NewT = StringToListOfAtoms(RepAtom(AtomOfTerm(t1))->StrOfAE);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
} else {
|
|
/* ARG1 unbound */
|
|
char *String = (char *)TR; /* alloc temp space on trail */
|
|
register Term t = Deref(ARG2);
|
|
register char *s = String;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR, t1, "atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
if (t == TermNil) {
|
|
return (unify_constant(t1, MkAtomTerm(LookupAtom(""))));
|
|
}
|
|
if (!IsPairTerm(t)) {
|
|
Error(TYPE_ERROR_LIST, t, "atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
|
|
while (t != TermNil) {
|
|
register Term Head;
|
|
register Int i;
|
|
Head = HeadOfTerm(t);
|
|
if (IsVarTerm(Head)) {
|
|
Error(INSTANTIATION_ERROR,Head,"atom_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsIntTerm(Head)) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
i = IntOfTerm(Head);
|
|
if (i < 0 || i > 255) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
*s++ = i;
|
|
t = TailOfTerm(t);
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"atom_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsPairTerm(t) && t != TermNil) {
|
|
Error(TYPE_ERROR_LIST, t, "atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
} else {
|
|
/* ISO Prolog Mode */
|
|
while (t != TermNil) {
|
|
register Term Head;
|
|
register char *is;
|
|
|
|
Head = HeadOfTerm(t);
|
|
if (IsVarTerm(Head)) {
|
|
Error(INSTANTIATION_ERROR,Head,"atom_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsAtomTerm(Head)) {
|
|
Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
is = RepAtom(AtomOfTerm(Head))->StrOfAE;
|
|
if (is[1] != '\0') {
|
|
Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
*s++ = is[0];
|
|
t = TailOfTerm(t);
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"atom_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsPairTerm(t) && t != TermNil) {
|
|
Error(TYPE_ERROR_LIST, t, "atom_chars/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
}
|
|
*s++ = '\0';
|
|
return (unify_constant(ARG1, MkAtomTerm(LookupAtom(String))));
|
|
}
|
|
}
|
|
|
|
static Int
|
|
p_atom_concat(void)
|
|
{
|
|
Term t1 = Deref(ARG1);
|
|
char *cptr = (char *)PreAllocCodeSpace(), *cpt0;
|
|
char *top = (char *)AuxSp;
|
|
char *atom_str;
|
|
UInt sz;
|
|
|
|
restart:
|
|
cpt0 = cptr;
|
|
/* we need to have a list */
|
|
if (IsVarTerm(t1)) {
|
|
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
|
Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
|
|
return(FALSE);
|
|
}
|
|
while (IsPairTerm(t1)) {
|
|
Term thead = HeadOfTerm(t1);
|
|
if (IsVarTerm(thead)) {
|
|
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
|
Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(thead)) {
|
|
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
|
Error(TYPE_ERROR_ATOM, ARG1, "atom_concat/2");
|
|
return(FALSE);
|
|
}
|
|
atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE;
|
|
/* check for overflows */
|
|
sz = strlen(atom_str);
|
|
if (cptr+sz >= top-1024) {
|
|
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
|
if (!growheap(FALSE)) {
|
|
Abort("[ SYSTEM ERROR: YAP could not grow heap in recorda/3 ]\n");
|
|
return(FALSE);
|
|
}
|
|
goto restart;
|
|
}
|
|
memcpy((void *)cptr, (void *)atom_str, sz);
|
|
cptr += sz;
|
|
t1 = TailOfTerm(t1);
|
|
if (IsVarTerm(t1)) {
|
|
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
|
Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
if (t1 == TermNil) {
|
|
Term tout;
|
|
cptr[0] = '\0';
|
|
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
|
tout = MkAtomTerm(LookupAtom(cpt0));
|
|
return(unify(ARG2, tout));
|
|
}
|
|
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
|
Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2");
|
|
return(FALSE);
|
|
}
|
|
|
|
static Int
|
|
p_atom_codes(void)
|
|
{
|
|
Term t1 = Deref(ARG1);
|
|
if (!IsVarTerm(t1)) {
|
|
Term NewT;
|
|
if (!IsAtomTerm(t1)) {
|
|
Error(TYPE_ERROR_ATOM, t1, "atom_codes/2");
|
|
return(FALSE);
|
|
}
|
|
NewT = StringToList(RepAtom(AtomOfTerm(t1))->StrOfAE);
|
|
return (unify(NewT, ARG2));
|
|
} else {
|
|
/* ARG1 unbound */
|
|
char *String = (char *)TR; /* alloc temp space on trail */
|
|
register Term t = Deref(ARG2);
|
|
register char *s = String;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR, t1, "atom_codes/2");
|
|
return(FALSE);
|
|
}
|
|
if (t == TermNil) {
|
|
return (unify_constant(t1, MkAtomTerm(LookupAtom(""))));
|
|
}
|
|
if (!IsPairTerm(t)) {
|
|
Error(TYPE_ERROR_LIST, t, "atom_codes/2");
|
|
return(FALSE);
|
|
}
|
|
while (t != TermNil) {
|
|
register Term Head;
|
|
register Int i;
|
|
Head = HeadOfTerm(t);
|
|
if (IsVarTerm(Head)) {
|
|
Error(INSTANTIATION_ERROR,Head,"atom_codes/2");
|
|
return(FALSE);
|
|
} else if (!IsIntTerm(Head)) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_codes/2");
|
|
return(FALSE);
|
|
}
|
|
i = IntOfTerm(Head);
|
|
if (i < 0 || i > 255) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_codes/2");
|
|
return(FALSE);
|
|
}
|
|
*s++ = i;
|
|
t = TailOfTerm(t);
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"atom_codes/2");
|
|
return(FALSE);
|
|
} else if (!IsPairTerm(t) && t != TermNil) {
|
|
Error(TYPE_ERROR_LIST, t, "atom_codes/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
*s++ = '\0';
|
|
return (unify_constant(ARG1, MkAtomTerm(LookupAtom(String))));
|
|
}
|
|
}
|
|
|
|
static Int
|
|
p_atom_length(void)
|
|
{
|
|
Term t1 = Deref(ARG1);
|
|
Term t2 = Deref(ARG2);
|
|
Int len;
|
|
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR, t1, "atom_length/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(t1)) {
|
|
Error(TYPE_ERROR_ATOM, t1, "atom_length/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsVarTerm(t2)) {
|
|
if (!IsIntTerm(t2)) {
|
|
Error(TYPE_ERROR_INTEGER, t2, "atom_length/2");
|
|
return(FALSE);
|
|
}
|
|
if ((len = IntOfTerm(t2)) < 0) {
|
|
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "atom_length/2");
|
|
return(FALSE);
|
|
}
|
|
return((Int)strlen(RepAtom(AtomOfTerm(t1))->StrOfAE) == len);
|
|
} else {
|
|
Term tj = MkIntTerm(strlen(RepAtom(AtomOfTerm(t1))->StrOfAE));
|
|
return(unify_constant(t2,tj));
|
|
}
|
|
}
|
|
|
|
|
|
/* split an atom into two sub-atoms */
|
|
static Int
|
|
p_atom_split(void)
|
|
{
|
|
Term t1 = Deref(ARG1);
|
|
Term t2 = Deref(ARG2);
|
|
Int len;
|
|
char *s, *s1;
|
|
int i;
|
|
Term to1, to2;
|
|
|
|
s1 = (char *)H;
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR, t1, "$atom_split/4");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(t1)) {
|
|
Error(TYPE_ERROR_ATOM, t1, "$atom_split/4");
|
|
return(FALSE);
|
|
}
|
|
if (IsVarTerm(t2)) {
|
|
Error(INSTANTIATION_ERROR, t2, "$atom_split/4");
|
|
return(FALSE);
|
|
}
|
|
if (!IsIntTerm(t2)) {
|
|
Error(TYPE_ERROR_INTEGER, t2, "$atom_split/4");
|
|
return(FALSE);
|
|
}
|
|
if ((len = IntOfTerm(t2)) < 0) {
|
|
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "$atom_split/4");
|
|
return(FALSE);
|
|
}
|
|
s = RepAtom(AtomOfTerm(t1))->StrOfAE;
|
|
if (len > (Int)strlen(s)) return(FALSE);
|
|
for (i = 0; i< len; i++) {
|
|
if (s1 > (char *)LCL0-1024)
|
|
Error(SYSTEM_ERROR,t1,"$atom_split/4");
|
|
s1[i] = s[i];
|
|
}
|
|
s1[len] = '\0';
|
|
to1 = MkAtomTerm(LookupAtom(s1));
|
|
to2 = MkAtomTerm(LookupAtom(s+len));
|
|
return(unify_constant(ARG3,to1) && unify_constant(ARG4,to2));
|
|
}
|
|
|
|
|
|
static Int
|
|
p_number_chars(void)
|
|
{
|
|
char *String = (char *)TR; /* alloc temp space on Trail */
|
|
register Term t = Deref(ARG2);
|
|
Term NewT;
|
|
register char *s = String;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Term t1 = Deref(ARG1);
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR, t1, "number_chars/2");
|
|
return(FALSE);
|
|
} else {
|
|
Term NewT;
|
|
if (!IsNumTerm(t1)) {
|
|
Error(TYPE_ERROR_NUMBER, t1, "number_chars/2");
|
|
return(FALSE);
|
|
} else if (IsIntTerm(t1)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", IntOfTerm(t1));
|
|
#else
|
|
sprintf(String, "%d", IntOfTerm(t1));
|
|
#endif
|
|
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
|
|
NewT = StringToList(String);
|
|
} else {
|
|
NewT = StringToListOfAtoms(String);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsFloatTerm(t1)) {
|
|
sprintf(String, "%f", FloatOfTerm(t1));
|
|
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
|
|
NewT = StringToList(String);
|
|
} else {
|
|
NewT = StringToListOfAtoms(String);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsLongIntTerm(t1)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", LongIntOfTerm(t1));
|
|
#else
|
|
sprintf(String, "%d", LongIntOfTerm(t1));
|
|
#endif
|
|
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
|
|
NewT = StringToList(String);
|
|
} else {
|
|
NewT = StringToListOfAtoms(String);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
#if USE_GMP
|
|
} else if (IsBigIntTerm(t1)) {
|
|
mpz_get_str(String, 10, BigIntOfTerm(t1));
|
|
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
|
|
NewT = StringToList(String);
|
|
} else {
|
|
NewT = StringToListOfAtoms(String);
|
|
}
|
|
return (unify(NewT, ARG2));
|
|
#endif
|
|
}
|
|
}
|
|
}
|
|
if (t == TermNil) {
|
|
return (FALSE);
|
|
}
|
|
if (!IsPairTerm(t)) {
|
|
Error(TYPE_ERROR_LIST, t, "number_chars/2");
|
|
return(FALSE);
|
|
}
|
|
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
|
|
while (t != TermNil) {
|
|
register Term Head;
|
|
register Int i;
|
|
Head = HeadOfTerm(t);
|
|
if (IsVarTerm(Head)) {
|
|
Error(INSTANTIATION_ERROR,Head,"number_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsIntTerm(Head)) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"number_chars/2");
|
|
return(FALSE);
|
|
}
|
|
i = IntOfTerm(Head);
|
|
if (i < 0 || i > 255) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"number_chars/2");
|
|
return(FALSE);
|
|
}
|
|
*s++ = i;
|
|
t = TailOfTerm(t);
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"number_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsPairTerm(t) && t != TermNil) {
|
|
Error(TYPE_ERROR_LIST, t, "number_chars/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
} else {
|
|
/* ISO code */
|
|
while (t != TermNil) {
|
|
register Term Head;
|
|
register char *is;
|
|
|
|
Head = HeadOfTerm(t);
|
|
if (IsVarTerm(Head)) {
|
|
Error(INSTANTIATION_ERROR,Head,"number_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsAtomTerm(Head)) {
|
|
Error(TYPE_ERROR_CHARACTER,Head,"number_chars/2");
|
|
return(FALSE);
|
|
}
|
|
is = RepAtom(AtomOfTerm(Head))->StrOfAE;
|
|
if (is[1] != '\0') {
|
|
Error(TYPE_ERROR_CHARACTER,Head,"number_chars/2");
|
|
return(FALSE);
|
|
}
|
|
*s++ = is[0];
|
|
t = TailOfTerm(t);
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"number_chars/2");
|
|
return(FALSE);
|
|
} else if (!IsPairTerm(t) && t != TermNil) {
|
|
Error(TYPE_ERROR_LIST, t, "number_chars/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
}
|
|
*s++ = '\0';
|
|
if ((NewT = get_num(String)) == TermNil) {
|
|
Error(SYNTAX_ERROR, Deref(ARG2), "number_chars/2", String);
|
|
return (FALSE);
|
|
}
|
|
return (unify(ARG1, NewT));
|
|
}
|
|
|
|
static Int
|
|
p_number_atom(void)
|
|
{
|
|
char *String = (char *)TR; /* alloc temp space on Trail */
|
|
register Term t = Deref(ARG2);
|
|
Term NewT;
|
|
register char *s = String;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Term t1 = Deref(ARG1);
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR, t1, "number_chars/2");
|
|
return(FALSE);
|
|
} else {
|
|
Term NewT;
|
|
|
|
if (IsIntTerm(t1)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", IntOfTerm(t1));
|
|
#else
|
|
sprintf(String, "%d", IntOfTerm(t1));
|
|
#endif
|
|
NewT = MkAtomTerm(LookupAtom(String));
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsFloatTerm(t1)) {
|
|
sprintf(String, "%f", FloatOfTerm(t1));
|
|
NewT = MkAtomTerm(LookupAtom(String));
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsLongIntTerm(t1)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", LongIntOfTerm(t1));
|
|
#else
|
|
sprintf(String, "%d", LongIntOfTerm(t1));
|
|
#endif
|
|
NewT = MkAtomTerm(LookupAtom(String));
|
|
return (unify(NewT, ARG2));
|
|
#if USE_GMP
|
|
} else if (IsBigIntTerm(t1)) {
|
|
mpz_get_str(String, 10, BigIntOfTerm(t1));
|
|
NewT = MkAtomTerm(LookupAtom(String));
|
|
return (unify(NewT, ARG2));
|
|
#endif
|
|
} else {
|
|
Error(TYPE_ERROR_NUMBER, t1, "number_atom/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
}
|
|
if (t == TermNil) {
|
|
return (FALSE);
|
|
}
|
|
if (!IsAtomTerm(t)) {
|
|
Error(TYPE_ERROR_LIST, t, "number_atom/2");
|
|
return(FALSE);
|
|
}
|
|
s = RepAtom(AtomOfTerm(t))->StrOfAE;
|
|
if ((NewT = get_num(s)) == TermNil) {
|
|
Error(SYNTAX_ERROR, Deref(ARG2), "number_atom/2", String);
|
|
return (FALSE);
|
|
}
|
|
return (unify(ARG1, NewT));
|
|
}
|
|
|
|
static Int
|
|
p_number_codes(void)
|
|
{
|
|
char *String = (char *)TR; /* alloc temp space on Trail */
|
|
register Term t = Deref(ARG2);
|
|
Term NewT;
|
|
register char *s = String;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Term t1;
|
|
Term NewT;
|
|
|
|
if (IsVarTerm(t1 = Deref(ARG1))) {
|
|
Error(INSTANTIATION_ERROR, t1, "number_codes/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsNumTerm(t1)) {
|
|
Error(TYPE_ERROR_NUMBER, t1, "number_codes/2");
|
|
return(FALSE);
|
|
} else if (IsIntTerm(t1)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", IntOfTerm(t1));
|
|
#else
|
|
sprintf(String, "%d", IntOfTerm(t1));
|
|
#endif
|
|
NewT = StringToList(String);
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsFloatTerm(t1)) {
|
|
sprintf(String, "%f", FloatOfTerm(t1));
|
|
NewT = StringToList(String);
|
|
return (unify(NewT, ARG2));
|
|
} else if (IsLongIntTerm(t1)) {
|
|
#if SHORT_INTS
|
|
sprintf(String, "%ld", LongIntOfTerm(t1));
|
|
#else
|
|
sprintf(String, "%d", LongIntOfTerm(t1));
|
|
#endif
|
|
NewT = StringToList(String);
|
|
return (unify(NewT, ARG2));
|
|
#if USE_GMP
|
|
} else if (IsBigIntTerm(t1)) {
|
|
mpz_get_str(String, 10, BigIntOfTerm(t1));
|
|
NewT = StringToList(String);
|
|
return (unify(NewT, ARG2));
|
|
#endif
|
|
}
|
|
}
|
|
if (t == TermNil) {
|
|
return (FALSE);
|
|
}
|
|
if (!IsPairTerm(t)) {
|
|
Error(TYPE_ERROR_LIST, t, "number_codes/2");
|
|
return(FALSE);
|
|
}
|
|
while (t != TermNil) {
|
|
register Term Head;
|
|
register Int i;
|
|
|
|
Head = HeadOfTerm(t);
|
|
if (IsVarTerm(Head)) {
|
|
Error(INSTANTIATION_ERROR,Head,"number_codes/2");
|
|
return(FALSE);
|
|
} else if (!IsIntTerm(Head)) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"number_codes/2");
|
|
return(FALSE);
|
|
}
|
|
i = IntOfTerm(Head);
|
|
if (i < 0 || i > 255) {
|
|
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"number_codes/2");
|
|
return(FALSE);
|
|
}
|
|
*s++ = i;
|
|
t = TailOfTerm(t);
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"number_codes/2");
|
|
return(FALSE);
|
|
} else if (!IsPairTerm(t) && t != TermNil) {
|
|
Error(TYPE_ERROR_LIST, t, "number_codes/2");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
*s++ = '\0';
|
|
if ((NewT = get_num(String)) == TermNil) {
|
|
Error(SYNTAX_ERROR, Deref(ARG2), "number_chars/2", String);
|
|
return (FALSE);
|
|
}
|
|
return (unify(ARG1, NewT));
|
|
}
|
|
|
|
static Int
|
|
p_univ(void)
|
|
{ /* A =.. L */
|
|
unsigned int arity;
|
|
register Term tin;
|
|
Term twork, t2;
|
|
Atom at;
|
|
|
|
tin = Deref(ARG1);
|
|
t2 = Deref(ARG2);
|
|
if (IsVarTerm(tin)) {
|
|
/* we need to have a list */
|
|
Term *Ar;
|
|
if (IsVarTerm(t2)) {
|
|
Error(INSTANTIATION_ERROR, t2, "(=..)/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsPairTerm(t2)) {
|
|
if (t2 == TermNil)
|
|
Error(DOMAIN_ERROR_NON_EMPTY_LIST, t2, "(=..)/2");
|
|
else
|
|
Error(TYPE_ERROR_LIST, ARG2, "(=..)/2");
|
|
return (FALSE);
|
|
}
|
|
twork = HeadOfTerm(t2);
|
|
if (IsVarTerm(twork)) {
|
|
Error(INSTANTIATION_ERROR, twork, "(=..)/2");
|
|
return(FALSE);
|
|
}
|
|
if (IsNumTerm(twork)) {
|
|
Term tt = TailOfTerm(t2);
|
|
if (IsVarTerm(tt) || tt != MkAtomTerm(AtomNil)) {
|
|
Error(TYPE_ERROR_ATOM, twork, "(=..)/2");
|
|
return (FALSE);
|
|
}
|
|
return (unify_constant(ARG1, twork));
|
|
}
|
|
if (!IsAtomTerm(twork)) {
|
|
Error(TYPE_ERROR_ATOM, twork, "(=..)/2");
|
|
return (FALSE);
|
|
}
|
|
at = AtomOfTerm(twork);
|
|
twork = TailOfTerm(t2);
|
|
if (IsVarTerm(twork)) {
|
|
Error(INSTANTIATION_ERROR, twork, "(=..)/2");
|
|
return(FALSE);
|
|
} else if (!IsPairTerm(twork)) {
|
|
if (twork != TermNil) {
|
|
Error(TYPE_ERROR_LIST, ARG2, "(=..)/2");
|
|
return(FALSE);
|
|
}
|
|
return (unify_constant(ARG1, MkAtomTerm(at)));
|
|
}
|
|
/* build the term directly on the heap */
|
|
Ar = H;
|
|
H++;
|
|
|
|
while (!IsVarTerm(twork) && IsPairTerm(twork)) {
|
|
*H++ = HeadOfTerm(twork);
|
|
twork = TailOfTerm(twork);
|
|
}
|
|
if (IsVarTerm(twork)) {
|
|
Error(INSTANTIATION_ERROR, twork, "(=..)/2");
|
|
return(FALSE);
|
|
}
|
|
if (twork != TermNil) {
|
|
Error(TYPE_ERROR_LIST, ARG2, "(=..)/2");
|
|
return (FALSE);
|
|
}
|
|
#ifdef SFUNC
|
|
DOES_NOT_WORK();
|
|
{
|
|
SFEntry *pe = (SFEntry *) GetAProp(at, SFProperty);
|
|
if (pe)
|
|
twork = MkSFTerm(MkFunctor(at, SFArity),
|
|
arity, CellPtr(TR), pe->NilValue);
|
|
else
|
|
twork = MkApplTerm(MkFunctor(at, arity),
|
|
arity, CellPtr(TR));
|
|
}
|
|
#else
|
|
arity = H-Ar-1;
|
|
if (at == AtomDot && arity == 2) {
|
|
Ar[0] = Ar[1];
|
|
Ar[1] = Ar[2];
|
|
H --;
|
|
twork = AbsPair(Ar);
|
|
} else {
|
|
*Ar = (CELL)(MkFunctor(at, arity));
|
|
twork = AbsAppl(Ar);
|
|
}
|
|
#endif
|
|
return (unify(ARG1, twork));
|
|
}
|
|
if (IsAtomicTerm(tin)) {
|
|
twork = MkPairTerm(tin, MkAtomTerm(AtomNil));
|
|
return (unify(twork, ARG2));
|
|
}
|
|
if (IsRefTerm(tin))
|
|
return (FALSE);
|
|
if (IsApplTerm(tin)) {
|
|
Functor fun = FunctorOfTerm(tin);
|
|
arity = ArityOfFunctor(fun);
|
|
at = NameOfFunctor(fun);
|
|
#ifdef SFUNC
|
|
if (arity == SFArity) {
|
|
CELL *p = CellPtr(TR);
|
|
CELL *q = ArgsOfSFTerm(tin);
|
|
int argno = 1;
|
|
while (*q) {
|
|
while (*q > argno++)
|
|
*p++ = MkVarTerm();
|
|
++q;
|
|
*p++ = Deref(*q++);
|
|
}
|
|
twork = ArrayToList(CellPtr(TR), argno - 1);
|
|
} else
|
|
#endif
|
|
twork = ArrayToList(RepAppl(tin) + 1, arity);
|
|
} else {
|
|
/* We found a list */
|
|
at = AtomDot;
|
|
twork = ArrayToList(RepPair(tin), 2);
|
|
}
|
|
twork = MkPairTerm(MkAtomTerm(at), twork);
|
|
return (unify(ARG2, twork));
|
|
}
|
|
|
|
static Int
|
|
p_abort(void)
|
|
{ /* abort */
|
|
/* make sure we won't go creeping around */
|
|
CreepFlag = CalculateStackGap();
|
|
yap_flags[SPY_CREEP_FLAG] = 0;
|
|
Abort("");
|
|
return(FALSE);
|
|
}
|
|
|
|
static Int
|
|
p_halt(void)
|
|
{ /* halt */
|
|
Term t = Deref(ARG1);
|
|
Int out;
|
|
|
|
if (IsVarTerm(t)) {
|
|
Error(INSTANTIATION_ERROR,t,"halt/1");
|
|
return(FALSE);
|
|
}
|
|
if (!IsIntegerTerm(t)) {
|
|
Error(TYPE_ERROR_INTEGER,t,"halt/1");
|
|
return(FALSE);
|
|
}
|
|
out = IntegerOfTerm(t);
|
|
if (yap_flags[HALT_AFTER_CONSULT_FLAG]) {
|
|
exit_yap(out, "");
|
|
} else {
|
|
exit_yap(out, "\n\n[ Prolog execution halted ]\n");
|
|
}
|
|
return (TRUE);
|
|
}
|
|
|
|
|
|
static Int
|
|
p_halt0(void)
|
|
{ /* halt */
|
|
if (yap_flags[HALT_AFTER_CONSULT_FLAG]) {
|
|
exit_yap(0, "");
|
|
} else {
|
|
exit_yap(0, "\n\n[ Prolog execution halted ]\n");
|
|
}
|
|
return (TRUE);
|
|
}
|
|
|
|
|
|
static Int
|
|
cont_current_atom(void)
|
|
{
|
|
Atom catom;
|
|
Int i = IntOfTerm(EXTRA_CBACK_ARG(1,2));
|
|
AtomEntry *ap; /* nasty hack for gcc on hpux */
|
|
|
|
/* protect current hash table line */
|
|
if (IsAtomTerm(EXTRA_CBACK_ARG(1,1)))
|
|
catom = AtomOfTerm(EXTRA_CBACK_ARG(1,1));
|
|
else
|
|
catom = NIL;
|
|
if (catom == NIL){
|
|
i++;
|
|
/* move away from current hash table line */
|
|
while (i < MaxHash) {
|
|
READ_LOCK(HashChain[i].AERWLock);
|
|
catom = HashChain[i].Entry;
|
|
if (catom != NIL) {
|
|
break;
|
|
}
|
|
READ_UNLOCK(HashChain[i].AERWLock);
|
|
i++;
|
|
}
|
|
if (i == MaxHash) {
|
|
cut_fail();
|
|
} else {
|
|
READ_UNLOCK(HashChain[i].AERWLock);
|
|
}
|
|
}
|
|
ap = RepAtom(catom);
|
|
if (unify_constant(ARG1, MkAtomTerm(catom))) {
|
|
if (ap->NextOfAE == NIL) {
|
|
i++;
|
|
while (i < MaxHash) {
|
|
READ_LOCK(HashChain[i].AERWLock);
|
|
catom = HashChain[i].Entry;
|
|
READ_UNLOCK(HashChain[i].AERWLock);
|
|
if (catom != NIL) {
|
|
break;
|
|
}
|
|
i++;
|
|
}
|
|
if (i == MaxHash) {
|
|
cut_succeed();
|
|
} else {
|
|
EXTRA_CBACK_ARG(1,1) = MkAtomTerm(catom);
|
|
}
|
|
} else {
|
|
READ_LOCK(ap->ARWLock);
|
|
EXTRA_CBACK_ARG(1,1) = MkAtomTerm(ap->NextOfAE);
|
|
READ_UNLOCK(ap->ARWLock);
|
|
}
|
|
EXTRA_CBACK_ARG(1,2) = MkIntTerm(i);
|
|
return(TRUE);
|
|
} else {
|
|
return(FALSE);
|
|
}
|
|
}
|
|
|
|
static Int
|
|
init_current_atom(void)
|
|
{ /* current_atom(?Atom) */
|
|
Term t1 = Deref(ARG1);
|
|
if (!IsVarTerm(t1)) {
|
|
if (IsAtomTerm(t1))
|
|
cut_succeed();
|
|
else
|
|
cut_fail();
|
|
}
|
|
READ_LOCK(HashChain[0].AERWLock);
|
|
if (HashChain[0].Entry != NIL) {
|
|
EXTRA_CBACK_ARG(1,1) = MkAtomTerm(HashChain[0].Entry);
|
|
} else {
|
|
EXTRA_CBACK_ARG(1,1) = MkIntTerm(0);
|
|
}
|
|
READ_UNLOCK(HashChain[0].AERWLock);
|
|
EXTRA_CBACK_ARG(1,2) = MkIntTerm(0);
|
|
return (cont_current_atom());
|
|
}
|
|
|
|
static Int
|
|
cont_current_predicate(void)
|
|
{
|
|
PredEntry *pp = (PredEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(3,1));
|
|
UInt Arity;
|
|
Atom name;
|
|
|
|
if (pp == NULL)
|
|
cut_fail();
|
|
EXTRA_CBACK_ARG(3,1) = (CELL)MkIntegerTerm((Int)(pp->NextPredOfModule));
|
|
Arity = pp->ArityOfPE;
|
|
if (Arity)
|
|
name = NameOfFunctor(pp->FunctorOfPred);
|
|
else
|
|
name = (Atom)pp->FunctorOfPred;
|
|
return (unify(ARG2,MkAtomTerm(name)) &&
|
|
unify(ARG3, MkIntegerTerm(Arity)));
|
|
}
|
|
|
|
static Int
|
|
init_current_predicate(void)
|
|
{
|
|
Term t1 = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t1) || !IsAtomTerm(t1)) cut_fail();
|
|
EXTRA_CBACK_ARG(3,1) = (CELL)MkIntegerTerm((Int)ModulePred[LookupModule(t1)]);
|
|
return (cont_current_predicate());
|
|
}
|
|
|
|
static OpEntry *
|
|
NextOp(OpEntry *pp)
|
|
{
|
|
while (!EndOfPAEntr(pp) && pp->KindOfPE != OpProperty)
|
|
pp = RepOpProp(pp->NextOfPE);
|
|
return (pp);
|
|
}
|
|
|
|
|
|
static Int
|
|
cont_current_op(void)
|
|
{
|
|
int prio;
|
|
Atom a = AtomOfTerm(EXTRA_CBACK_ARG(3,1));
|
|
Int i = IntOfTerm(EXTRA_CBACK_ARG(3,2));
|
|
Int fix = IntOfTerm(EXTRA_CBACK_ARG(3,3));
|
|
Term TType;
|
|
OpEntry *pp = NIL;
|
|
/* fix hp gcc bug */
|
|
AtomEntry *at = RepAtom(a);
|
|
|
|
if (fix > 3) {
|
|
a = AtomOfTerm(Deref(ARG3));
|
|
READ_LOCK(RepAtom(a)->ARWLock);
|
|
if (EndOfPAEntr(pp = NextOp(RepOpProp(RepAtom(a)->PropsOfAE)))) {
|
|
READ_UNLOCK(RepAtom(a)->ARWLock);
|
|
cut_fail();
|
|
}
|
|
READ_LOCK(pp->OpRWLock);
|
|
READ_UNLOCK(RepAtom(a)->ARWLock);
|
|
if (fix == 4 && pp->Prefix == 0)
|
|
fix = 5;
|
|
if (fix == 5 && pp->Posfix == 0)
|
|
fix = 6;
|
|
if (fix == 6 && pp->Infix == 0)
|
|
cut_fail();
|
|
TType = MkAtomTerm(GetOp(pp, &prio, (int) (fix - 4)));
|
|
fix++;
|
|
if (fix == 5 && pp->Posfix == 0)
|
|
fix = 6;
|
|
if (fix == 6 && pp->Infix == 0)
|
|
fix = 7;
|
|
READ_UNLOCK(pp->OpRWLock);
|
|
EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(fix);
|
|
if (fix < 7)
|
|
return (unify_constant(ARG1, MkIntTerm(prio))
|
|
&& unify_constant(ARG2, TType));
|
|
if (unify_constant(ARG1, MkIntTerm(prio)) && unify_constant(ARG2, TType))
|
|
cut_succeed();
|
|
else
|
|
cut_fail();
|
|
}
|
|
if (fix == 3) {
|
|
do {
|
|
if ((a = at->NextOfAE) == NIL) {
|
|
i++;
|
|
while (TRUE) {
|
|
READ_LOCK(HashChain[i].AERWLock);
|
|
a = HashChain[i].Entry;
|
|
READ_UNLOCK(HashChain[i].AERWLock);
|
|
if (a != NIL) {
|
|
break;
|
|
}
|
|
i++;
|
|
}
|
|
if (i == MaxHash)
|
|
cut_fail();
|
|
EXTRA_CBACK_ARG(3,2) = (CELL) MkIntTerm(i);
|
|
}
|
|
at = RepAtom(a);
|
|
READ_LOCK(at->ARWLock);
|
|
pp = NextOp(RepOpProp(at->PropsOfAE));
|
|
READ_UNLOCK(at->ARWLock);
|
|
} while (EndOfPAEntr(pp));
|
|
fix = 0;
|
|
EXTRA_CBACK_ARG(3,1) = (CELL) MkAtomTerm(a);
|
|
} else {
|
|
pp = NextOp(RepOpProp(at->PropsOfAE));
|
|
}
|
|
READ_LOCK(pp->OpRWLock);
|
|
if (fix == 0 && pp->Prefix == 0)
|
|
fix = 1;
|
|
if (fix == 1 && pp->Posfix == 0)
|
|
fix = 2;
|
|
TType = MkAtomTerm(GetOp(pp, &prio, (int) fix));
|
|
fix++;
|
|
if (fix == 1 && pp->Posfix == 0)
|
|
fix = 2;
|
|
if (fix == 2 && pp->Infix == 0)
|
|
fix = 3;
|
|
READ_UNLOCK(pp->OpRWLock);
|
|
EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(fix);
|
|
return (unify_constant(ARG1, MkIntTerm(prio)) &&
|
|
unify_constant(ARG2, TType) &&
|
|
unify_constant(ARG3, MkAtomTerm(a)));
|
|
}
|
|
|
|
static Int
|
|
init_current_op(void)
|
|
{ /* current_op(-Precedence,-Type,-Atom) */
|
|
Int i = 0;
|
|
Atom a;
|
|
Term tprio = Deref(ARG1);
|
|
Term topsec = Deref(ARG2);
|
|
Term top = Deref(ARG3);
|
|
|
|
if (!IsVarTerm(tprio)) {
|
|
Int prio;
|
|
if (!IsIntTerm(tprio)) {
|
|
Error(DOMAIN_ERROR_OPERATOR_PRIORITY,tprio,"current_op/3");
|
|
return(FALSE);
|
|
}
|
|
prio = IntOfTerm(tprio);
|
|
if (prio < 1 || prio > 1200) {
|
|
Error(DOMAIN_ERROR_OPERATOR_PRIORITY,tprio,"current_op/3");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
if (!IsVarTerm(topsec)) {
|
|
char *opsec;
|
|
if (!IsAtomTerm(topsec)) {
|
|
Error(DOMAIN_ERROR_OPERATOR_SPECIFIER,topsec,"current_op/3");
|
|
return(FALSE);
|
|
}
|
|
opsec = RepAtom(AtomOfTerm(topsec))->StrOfAE;
|
|
if (!IsOpType(opsec)) {
|
|
Error(DOMAIN_ERROR_OPERATOR_SPECIFIER,topsec,"current_op/3");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
if (!IsVarTerm(top)) {
|
|
if (!IsAtomTerm(top)) {
|
|
Error(TYPE_ERROR_ATOM,top,"current_op/3");
|
|
return(FALSE);
|
|
}
|
|
}
|
|
while (TRUE) {
|
|
READ_LOCK(HashChain[i].AERWLock);
|
|
a = HashChain[i].Entry;
|
|
READ_UNLOCK(HashChain[i].AERWLock);
|
|
if (a != NIL) {
|
|
break;
|
|
}
|
|
i++;
|
|
}
|
|
EXTRA_CBACK_ARG(3,1) = (CELL) MkAtomTerm(a);
|
|
EXTRA_CBACK_ARG(3,2) = (CELL) MkIntTerm(i);
|
|
if (IsVarTerm(top))
|
|
EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(3);
|
|
else if (IsAtomTerm(top))
|
|
EXTRA_CBACK_ARG(3,3) = (CELL) MkIntTerm(4);
|
|
else
|
|
cut_fail();
|
|
return (cont_current_op());
|
|
}
|
|
|
|
#ifdef DEBUG
|
|
static Int
|
|
p_debug()
|
|
{ /* $debug(+Flag) */
|
|
int i = IntOfTerm(Deref(ARG1));
|
|
|
|
if (i >= 'a' && i <= 'z')
|
|
Option[i - 96] = !Option[i - 96];
|
|
return (1);
|
|
}
|
|
#endif
|
|
|
|
static Int
|
|
p_flags(void)
|
|
{ /* $flags(+Functor,+Mod,?OldFlags,?NewFlags) */
|
|
PredEntry *pe;
|
|
Int newFl;
|
|
Term t1 = Deref(ARG1);
|
|
Term t2 = Deref(ARG2);
|
|
int mod;
|
|
|
|
if (IsVarTerm(t1))
|
|
return (FALSE);
|
|
if (!IsAtomTerm(t2)) {
|
|
return(FALSE);
|
|
}
|
|
mod = LookupModule(t2);
|
|
if (IsVarTerm(t1))
|
|
return (FALSE);
|
|
if (IsAtomTerm(t1)) {
|
|
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod));
|
|
} else if (IsApplTerm(t1)) {
|
|
Functor funt = FunctorOfTerm(t1);
|
|
pe = RepPredProp(PredPropByFunc(funt, mod));
|
|
} else
|
|
return (FALSE);
|
|
if (EndOfPAEntr(pe))
|
|
return (FALSE);
|
|
WRITE_LOCK(pe->PRWLock);
|
|
if (!unify_constant(ARG3, MkIntTerm(pe->PredFlags))) {
|
|
WRITE_UNLOCK(pe->PRWLock);
|
|
return(FALSE);
|
|
}
|
|
ARG4 = Deref(ARG4);
|
|
if (IsVarTerm(ARG4)) {
|
|
WRITE_UNLOCK(pe->PRWLock);
|
|
return (TRUE);
|
|
} else if (!IsIntTerm(ARG4)) {
|
|
union arith_ret v;
|
|
|
|
if (Eval(ARG4, &v) == long_int_e) {
|
|
newFl = v.Int;
|
|
} else {
|
|
WRITE_UNLOCK(pe->PRWLock);
|
|
Error(TYPE_ERROR_INTEGER, ARG4, "flags");
|
|
return(FALSE);
|
|
}
|
|
} else
|
|
newFl = IntOfTerm(ARG4);
|
|
pe->PredFlags = (SMALLUNSGN) newFl;
|
|
WRITE_UNLOCK(pe->PRWLock);
|
|
return (TRUE);
|
|
}
|
|
|
|
static int
|
|
AlreadyHidden(char *name)
|
|
{
|
|
AtomEntry *chain;
|
|
|
|
READ_LOCK(INVISIBLECHAIN.AERWLock);
|
|
chain = RepAtom(INVISIBLECHAIN.Entry);
|
|
READ_UNLOCK(INVISIBLECHAIN.AERWLock);
|
|
while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, name) != 0)
|
|
chain = RepAtom(chain->NextOfAE);
|
|
if (EndOfPAEntr(chain))
|
|
return (FALSE);
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_hide(void)
|
|
{ /* hide(+Atom) */
|
|
Atom atomToInclude;
|
|
Term t1 = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR,t1,"hide/1");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(t1)) {
|
|
Error(TYPE_ERROR_ATOM,t1,"hide/1");
|
|
return(FALSE);
|
|
}
|
|
atomToInclude = AtomOfTerm(t1);
|
|
if (AlreadyHidden(RepAtom(atomToInclude)->StrOfAE)) {
|
|
Error(SYSTEM_ERROR,t1,"an atom of name %s was already hidden",
|
|
RepAtom(atomToInclude)->StrOfAE);
|
|
return(FALSE);
|
|
}
|
|
ReleaseAtom(atomToInclude);
|
|
WRITE_LOCK(INVISIBLECHAIN.AERWLock);
|
|
WRITE_LOCK(RepAtom(atomToInclude)->ARWLock);
|
|
RepAtom(atomToInclude)->NextOfAE = INVISIBLECHAIN.Entry;
|
|
WRITE_UNLOCK(RepAtom(atomToInclude)->ARWLock);
|
|
INVISIBLECHAIN.Entry = atomToInclude;
|
|
WRITE_UNLOCK(INVISIBLECHAIN.AERWLock);
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_hidden(void)
|
|
{ /* '$hidden'(+F) */
|
|
Atom at;
|
|
AtomEntry *chain;
|
|
Term t1 = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t1))
|
|
return (FALSE);
|
|
if (IsAtomTerm(t1))
|
|
at = AtomOfTerm(t1);
|
|
else if (IsApplTerm(t1))
|
|
at = NameOfFunctor(FunctorOfTerm(t1));
|
|
else
|
|
return (FALSE);
|
|
READ_LOCK(INVISIBLECHAIN.AERWLock);
|
|
chain = RepAtom(INVISIBLECHAIN.Entry);
|
|
while (!EndOfPAEntr(chain) && AbsAtom(chain) != at)
|
|
chain = RepAtom(chain->NextOfAE);
|
|
READ_UNLOCK(INVISIBLECHAIN.AERWLock);
|
|
if (EndOfPAEntr(chain))
|
|
return (FALSE);
|
|
return (TRUE);
|
|
}
|
|
|
|
|
|
static Int
|
|
p_unhide(void)
|
|
{ /* unhide(+Atom) */
|
|
AtomEntry *atom, *old, *chain;
|
|
Term t1 = Deref(ARG1);
|
|
|
|
if (IsVarTerm(t1)) {
|
|
Error(INSTANTIATION_ERROR,t1,"unhide/1");
|
|
return(FALSE);
|
|
}
|
|
if (!IsAtomTerm(t1)) {
|
|
Error(TYPE_ERROR_ATOM,t1,"unhide/1");
|
|
return(FALSE);
|
|
}
|
|
atom = RepAtom(AtomOfTerm(t1));
|
|
WRITE_LOCK(atom->ARWLock);
|
|
if (atom->PropsOfAE != NIL) {
|
|
Error(SYSTEM_ERROR,t1,"cannot unhide an atom in use");
|
|
return(FALSE);
|
|
}
|
|
WRITE_LOCK(INVISIBLECHAIN.AERWLock);
|
|
chain = RepAtom(INVISIBLECHAIN.Entry);
|
|
old = NIL;
|
|
while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom->StrOfAE) != 0) {
|
|
old = chain;
|
|
chain = RepAtom(chain->NextOfAE);
|
|
}
|
|
if (EndOfPAEntr(chain))
|
|
return (FALSE);
|
|
atom->PropsOfAE = chain->PropsOfAE;
|
|
if (old == NIL)
|
|
INVISIBLECHAIN.Entry = chain->NextOfAE;
|
|
else
|
|
old->NextOfAE = chain->NextOfAE;
|
|
WRITE_UNLOCK(INVISIBLECHAIN.AERWLock);
|
|
WRITE_UNLOCK(atom->ARWLock);
|
|
return (TRUE);
|
|
}
|
|
|
|
static Int
|
|
p_statistics_heap_max(void)
|
|
{
|
|
Term tmax = MkIntegerTerm(HeapMax);
|
|
|
|
return(unify(tmax, ARG1));
|
|
}
|
|
|
|
/* The results of the next routines are not to be trusted too */
|
|
/* much. Basically, any stack shifting will seriously confuse the */
|
|
/* results */
|
|
|
|
static Int TrailTide = -1, LocalTide = -1, GlobalTide = -1;
|
|
|
|
/* maximum Trail usage */
|
|
static Int
|
|
TrailMax(void)
|
|
{
|
|
Int i;
|
|
Int TrWidth = Unsigned(TrailTop) - Unsigned(TrailBase);
|
|
CELL *pt;
|
|
|
|
if (TrailTide != TrWidth) {
|
|
pt = (CELL *)TR;
|
|
while (pt+2 < (CELL *)TrailTop) {
|
|
if (pt[0] == 0 &&
|
|
pt[1] == 0 &&
|
|
pt[2] == 0)
|
|
break;
|
|
else
|
|
pt++;
|
|
}
|
|
if (pt+2 < (CELL *)TrailTop)
|
|
i = Unsigned(pt) - Unsigned(TrailBase);
|
|
else
|
|
i = TrWidth;
|
|
} else
|
|
return(TrWidth);
|
|
if (TrailTide > i)
|
|
i = TrailTide;
|
|
else
|
|
TrailTide = i;
|
|
return(i);
|
|
}
|
|
|
|
static Int
|
|
p_statistics_trail_max(void)
|
|
{
|
|
Term tmax = MkIntegerTerm(TrailMax());
|
|
|
|
return(unify(tmax, ARG1));
|
|
|
|
}
|
|
|
|
/* maximum Global usage */
|
|
static Int
|
|
GlobalMax(void)
|
|
{
|
|
Int i;
|
|
Int StkWidth = Unsigned(LCL0) - Unsigned(H0);
|
|
CELL *pt;
|
|
|
|
if (GlobalTide != StkWidth) {
|
|
pt = H;
|
|
while (pt+2 < ASP) {
|
|
if (pt[0] == 0 &&
|
|
pt[1] == 0 &&
|
|
pt[2] == 0)
|
|
break;
|
|
else
|
|
pt++;
|
|
}
|
|
if (pt+2 < ASP)
|
|
i = Unsigned(pt) - Unsigned(H0);
|
|
else
|
|
/* so that both Local and Global have reached maximum width */
|
|
GlobalTide = LocalTide = i = StkWidth;
|
|
} else
|
|
return(StkWidth);
|
|
if (GlobalTide > i)
|
|
i = GlobalTide;
|
|
else
|
|
GlobalTide = i;
|
|
return(i);
|
|
}
|
|
|
|
static Int
|
|
p_statistics_global_max(void)
|
|
{
|
|
Term tmax = MkIntegerTerm(GlobalMax());
|
|
|
|
return(unify(tmax, ARG1));
|
|
|
|
}
|
|
|
|
|
|
static Int
|
|
LocalMax(void)
|
|
{
|
|
Int i;
|
|
Int StkWidth = Unsigned(LCL0) - Unsigned(H0);
|
|
CELL *pt;
|
|
|
|
if (LocalTide != StkWidth) {
|
|
pt = LCL0;
|
|
while (pt-3 > H) {
|
|
if (pt[-1] == 0 &&
|
|
pt[-2] == 0 &&
|
|
pt[-3] == 0)
|
|
break;
|
|
else
|
|
--pt;
|
|
}
|
|
if (pt-3 > H)
|
|
i = Unsigned(LCL0) - Unsigned(pt);
|
|
else
|
|
/* so that both Local and Global have reached maximum width */
|
|
GlobalTide = LocalTide = i = StkWidth;
|
|
} else
|
|
return(StkWidth);
|
|
if (LocalTide > i)
|
|
i = LocalTide;
|
|
else
|
|
LocalTide = i;
|
|
return(i);
|
|
}
|
|
|
|
static Int
|
|
p_statistics_local_max(void)
|
|
{
|
|
Term tmax = MkIntegerTerm(LocalMax());
|
|
|
|
return(unify(tmax, ARG1));
|
|
|
|
}
|
|
|
|
|
|
|
|
static Int
|
|
p_statistics_heap_info(void)
|
|
{
|
|
Term tmax = MkIntegerTerm(Unsigned(H0) - Unsigned(HeapBase));
|
|
Term tusage = MkIntegerTerm(HeapUsed);
|
|
|
|
return(unify(tmax, ARG1) && unify(tusage,ARG2));
|
|
|
|
}
|
|
|
|
|
|
static Int
|
|
p_statistics_stacks_info(void)
|
|
{
|
|
Term tmax = MkIntegerTerm(Unsigned(LCL0) - Unsigned(H0));
|
|
Term tgusage = MkIntegerTerm(Unsigned(H) - Unsigned(H0));
|
|
Term tlusage = MkIntegerTerm(Unsigned(LCL0) - Unsigned(ASP));
|
|
|
|
return(unify(tmax, ARG1) && unify(tgusage,ARG2) && unify(tlusage,ARG3));
|
|
|
|
}
|
|
|
|
|
|
static Int
|
|
p_statistics_trail_info(void)
|
|
{
|
|
Term tmax = MkIntegerTerm(Unsigned(TrailTop) - Unsigned(TrailBase));
|
|
Term tusage = MkIntegerTerm(Unsigned(TR) - Unsigned(TrailBase));
|
|
|
|
return(unify(tmax, ARG1) && unify(tusage,ARG2));
|
|
|
|
}
|
|
|
|
static Term
|
|
mk_argc_list(void)
|
|
{
|
|
int i =0;
|
|
Term t = TermNil;
|
|
while (i < yap_argc) {
|
|
char *arg = yap_args[i];
|
|
/* check for -L -- */
|
|
if (arg[0] == '-' && arg[1] == 'L') {
|
|
arg += 2;
|
|
while (*arg != '\0' && (*arg == ' ' || *arg == '\t'))
|
|
arg++;
|
|
if (*arg == '-' && arg[1] == '-' && arg[2] == '\0') {
|
|
/* we found the separator */
|
|
int j;
|
|
for (j = yap_argc-1; j > i+1; --j) {
|
|
t = MkPairTerm(MkAtomTerm(LookupAtom(yap_args[j])),t);
|
|
}
|
|
return(t);
|
|
}
|
|
}
|
|
if (arg[0] == '-' && arg[1] == '-' && arg[2] == '\0') {
|
|
/* we found the separator */
|
|
int j;
|
|
for (j = yap_argc-1; j > i; --j) {
|
|
t = MkPairTerm(MkAtomTerm(LookupAtom(yap_args[j])),t);
|
|
}
|
|
return(t);
|
|
}
|
|
i++;
|
|
}
|
|
return(t);
|
|
}
|
|
|
|
static Int
|
|
p_argv(void)
|
|
{
|
|
Term t = mk_argc_list();
|
|
return(unify(t, ARG1));
|
|
}
|
|
|
|
static Int
|
|
p_access_yap_flags(void)
|
|
{
|
|
Term tflag = Deref(ARG1);
|
|
Int flag;
|
|
Term tout;
|
|
|
|
if (IsVarTerm(tflag)) {
|
|
Error(INSTANTIATION_ERROR, tflag, "access_yap_flags/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsIntTerm(tflag)) {
|
|
Error(TYPE_ERROR_INTEGER, tflag, "access_yap_flags/2");
|
|
return(FALSE);
|
|
}
|
|
flag = IntOfTerm(tflag);
|
|
if (flag < 0 || flag > NUMBER_OF_YAP_FLAGS) {
|
|
return(FALSE);
|
|
}
|
|
tout = MkIntegerTerm(yap_flags[flag]);
|
|
return(unify(ARG2, tout));
|
|
}
|
|
|
|
static Int
|
|
p_host_type(void)
|
|
{
|
|
return(unify(ARG1,MkAtomTerm(LookupAtom(HOST_ALIAS))));
|
|
}
|
|
|
|
static Int
|
|
p_has_yap_or(void)
|
|
{
|
|
#ifdef YAPOR
|
|
return(TRUE);
|
|
#else
|
|
return(FALSE);
|
|
#endif
|
|
}
|
|
|
|
|
|
static Int
|
|
p_set_yap_flags(void)
|
|
{
|
|
Term tflag = Deref(ARG1);
|
|
Term tvalue = Deref(ARG2);
|
|
Int flag, value;
|
|
|
|
if (IsVarTerm(tflag)) {
|
|
Error(INSTANTIATION_ERROR, tflag, "set_yap_flags/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsIntTerm(tflag)) {
|
|
Error(TYPE_ERROR_INTEGER, tflag, "set_yap_flags/2");
|
|
return(FALSE);
|
|
}
|
|
flag = IntOfTerm(tflag);
|
|
if (IsVarTerm(tvalue)) {
|
|
Error(INSTANTIATION_ERROR, tvalue, "set_yap_flags/2");
|
|
return(FALSE);
|
|
}
|
|
if (!IsIntTerm(tvalue)) {
|
|
Error(TYPE_ERROR_INTEGER, tvalue, "set_yap_flags/2");
|
|
return(FALSE);
|
|
}
|
|
value = IntOfTerm(tvalue);
|
|
/* checking should have been performed */
|
|
switch(flag) {
|
|
case CHAR_CONVERSION_FLAG:
|
|
if (value != 0 && value != 1)
|
|
return(FALSE);
|
|
yap_flags[CHAR_CONVERSION_FLAG] = value;
|
|
break;
|
|
case YAP_DOUBLE_QUOTES_FLAG:
|
|
if (value < 0 || value > 2)
|
|
return(FALSE);
|
|
yap_flags[YAP_DOUBLE_QUOTES_FLAG] = value;
|
|
break;
|
|
case YAP_TO_CHARS_FLAG:
|
|
if (value != 0 && value != 1)
|
|
return(FALSE);
|
|
yap_flags[YAP_TO_CHARS_FLAG] = value;
|
|
break;
|
|
case LANGUAGE_MODE_FLAG:
|
|
if (value < 0 || value > 2)
|
|
return(FALSE);
|
|
if (value == 1) {
|
|
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(AtomMetaCall,4),0));
|
|
set_fpu_exceptions(TRUE);
|
|
} else {
|
|
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(AtomMetaCall,4),0));
|
|
set_fpu_exceptions(FALSE);
|
|
}
|
|
yap_flags[LANGUAGE_MODE_FLAG] = value;
|
|
break;
|
|
case STRICT_ISO_FLAG:
|
|
if (value != 0 && value != 1)
|
|
return(FALSE);
|
|
yap_flags[STRICT_ISO_FLAG] = value;
|
|
break;
|
|
case SPY_CREEP_FLAG:
|
|
if (value != 0 && value != 1)
|
|
return(FALSE);
|
|
yap_flags[SPY_CREEP_FLAG] = value;
|
|
break;
|
|
case SOURCE_MODE_FLAG:
|
|
if (value != 0 && value != 1)
|
|
return(FALSE);
|
|
yap_flags[SOURCE_MODE_FLAG] = value;
|
|
break;
|
|
case CHARACTER_ESCAPE_FLAG:
|
|
if (value != ISO_CHARACTER_ESCAPES
|
|
&& value != CPROLOG_CHARACTER_ESCAPES
|
|
&& value != SICSTUS_CHARACTER_ESCAPES)
|
|
return(FALSE);
|
|
yap_flags[CHARACTER_ESCAPE_FLAG] = value;
|
|
break;
|
|
case WRITE_QUOTED_STRING_FLAG:
|
|
if (value != 0 && value != 1)
|
|
return(FALSE);
|
|
yap_flags[WRITE_QUOTED_STRING_FLAG] = value;
|
|
break;
|
|
case ALLOW_ASSERTING_STATIC_FLAG:
|
|
if (value != 0 && value != 1)
|
|
return(FALSE);
|
|
yap_flags[ALLOW_ASSERTING_STATIC_FLAG] = value;
|
|
break;
|
|
default:
|
|
return(FALSE);
|
|
}
|
|
return(TRUE);
|
|
}
|
|
|
|
#ifndef YAPOR
|
|
static Int
|
|
p_default_sequential(void) {
|
|
return(TRUE);
|
|
}
|
|
#endif
|
|
|
|
#ifdef DEBUG
|
|
extern void DumpActiveGoals(void);
|
|
|
|
static Int
|
|
p_dump_active_goals(void) {
|
|
DumpActiveGoals();
|
|
return(TRUE);
|
|
}
|
|
#endif
|
|
|
|
void
|
|
InitBackCPreds(void)
|
|
{
|
|
InitCPredBack("$current_atom", 1, 2, init_current_atom, cont_current_atom,
|
|
SafePredFlag|SyncPredFlag);
|
|
InitCPredBack("$current_predicate", 3, 1, init_current_predicate, cont_current_predicate,
|
|
SafePredFlag|SyncPredFlag);
|
|
InitCPredBack("current_op", 3, 3, init_current_op, cont_current_op,
|
|
SafePredFlag|SyncPredFlag);
|
|
InitBackIO();
|
|
InitBackDB();
|
|
InitUserBacks();
|
|
}
|
|
|
|
typedef void (*Proc)(void);
|
|
|
|
Proc E_Modules[]= {/* init_fc,*/ (Proc) 0 };
|
|
|
|
void
|
|
InitCPreds(void)
|
|
{
|
|
/* numerical comparison */
|
|
InitCPred("$set_value", 2, p_setval, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$get_value", 2, p_value, TestPredFlag|SafePredFlag|SyncPredFlag);
|
|
InitCPred("$values", 3, p_values, SafePredFlag|SyncPredFlag);
|
|
/* The flip-flop */
|
|
InitCPred("$flipflop", 0, p_flipflop, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$setflop", 1, p_setflop, SafePredFlag|SyncPredFlag);
|
|
/* general purpose */
|
|
InitCPred("$opdec", 3, p_opdec, SafePredFlag|SyncPredFlag);
|
|
InitCPred("name", 2, p_name, SafePredFlag);
|
|
InitCPred("char_code", 2, p_char_code, SafePredFlag);
|
|
InitCPred("atom_chars", 2, p_atom_chars, SafePredFlag);
|
|
InitCPred("atom_codes", 2, p_atom_codes, SafePredFlag);
|
|
InitCPred("atom_length", 2, p_atom_length, SafePredFlag);
|
|
InitCPred("$atom_split", 4, p_atom_split, SafePredFlag);
|
|
InitCPred("number_chars", 2, p_number_chars, SafePredFlag);
|
|
InitCPred("number_atom", 2, p_number_atom, SafePredFlag);
|
|
InitCPred("number_codes", 2, p_number_codes, SafePredFlag);
|
|
InitCPred("atom_concat", 2, p_atom_concat, SafePredFlag);
|
|
InitCPred("=..", 2, p_univ, SafePredFlag);
|
|
InitCPred("$statistics_trail_max", 1, p_statistics_trail_max, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$statistics_heap_max", 1, p_statistics_heap_max, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$statistics_global_max", 1, p_statistics_global_max, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$statistics_local_max", 1, p_statistics_local_max, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$statistics_heap_info", 2, p_statistics_heap_info, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$statistics_stacks_info", 3, p_statistics_stacks_info, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$statistics_trail_info", 2, p_statistics_trail_info, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$argv", 1, p_argv, SafePredFlag);
|
|
InitCPred("$runtime", 2, p_runtime, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$cputime", 2, p_cputime, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$walltime", 2, p_walltime, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$access_yap_flags", 2, p_access_yap_flags, SafePredFlag);
|
|
InitCPred("$set_yap_flags", 2, p_set_yap_flags, SafePredFlag|SyncPredFlag);
|
|
InitCPred("abort", 0, p_abort, SyncPredFlag);
|
|
InitCPred("halt", 1, p_halt, SyncPredFlag);
|
|
InitCPred("halt", 0, p_halt0, SyncPredFlag);
|
|
InitCPred("$host_type", 1, p_host_type, SyncPredFlag);
|
|
/* basic predicates for the prolog machine tracer */
|
|
/* they are defined in analyst.c */
|
|
/* Basic predicates for the debugger */
|
|
InitCPred("$creep", 0, p_creep, SafePredFlag|SyncPredFlag);
|
|
#ifdef DEBUG
|
|
InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag);
|
|
#endif
|
|
/* Accessing and changing the flags for a predicate */
|
|
InitCPred("$flags", 4, p_flags, SafePredFlag|SyncPredFlag);
|
|
/* hiding and unhiding some predicates */
|
|
InitCPred("hide", 1, p_hide, SafePredFlag|SyncPredFlag);
|
|
InitCPred("unhide", 1, p_unhide, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$hidden", 1, p_hidden, SafePredFlag|SyncPredFlag);
|
|
InitCPred("$has_yap_or", 0, p_has_yap_or, SafePredFlag|SyncPredFlag);
|
|
#ifndef YAPOR
|
|
InitCPred("$default_sequential", 1, p_default_sequential, SafePredFlag|SyncPredFlag);
|
|
#endif
|
|
#ifdef DEBUG
|
|
InitCPred("dump_active_goals", 0, p_dump_active_goals, SafePredFlag|SyncPredFlag);
|
|
#endif
|
|
|
|
InitUnify();
|
|
InitCdMgr();
|
|
InitExecFs();
|
|
InitIOPreds();
|
|
InitCmpPreds();
|
|
InitDBPreds();
|
|
InitBBPreds();
|
|
InitBigNums();
|
|
InitSysPreds();
|
|
InitSavePreds();
|
|
InitCoroutPreds();
|
|
InitArrayPreds();
|
|
InitLoadForeign();
|
|
InitUserCPreds();
|
|
InitUtilCPreds();
|
|
InitSortPreds();
|
|
InitMaVarCPreds();
|
|
#ifdef DEPTH_LIMIT
|
|
InitItDeepenPreds();
|
|
#endif
|
|
#ifdef ANALYST
|
|
InitAnalystPreds();
|
|
#endif
|
|
#ifdef LOW_LEVEL_TRACER
|
|
InitLowLevelTrace();
|
|
#endif
|
|
InitEval();
|
|
InitGrowPreds();
|
|
#if defined(YAPOR) || defined(TABLING)
|
|
init_optyap_preds();
|
|
#endif
|
|
{
|
|
void (*(*(p))) (void) = E_Modules;
|
|
while (*p)
|
|
(*(*p++)) ();
|
|
}
|
|
#if CAMACHO
|
|
{
|
|
extern void InitForeignPreds(void);
|
|
|
|
InitForeignPreds();
|
|
}
|
|
#endif
|
|
|
|
}
|
|
|
|
|