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

support for UNICODE, and other bug fixes.

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1725 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2006-11-27 17:42:03 +00:00
parent 0a21ac1b71
commit 0705ca0640
34 changed files with 2128 additions and 632 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
C/absmi.c
View File

@ -10,8 +10,12 @@
* * * *
* File: absmi.c * * File: absmi.c *
* comments: Portable abstract machine interpreter * * comments: Portable abstract machine interpreter *
* Last rev: $Date: 2006-11-21 16:21:30 $,$Author: vsc $ * * Last rev: $Date: 2006-11-27 17:42:02 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.212 2006/11/21 16:21:30 vsc
* fix I/O mess
* fix spy/reconsult mess
*
* Revision 1.211 2006/11/15 00:13:36 vsc * Revision 1.211 2006/11/15 00:13:36 vsc
* fixes for indexing code. * fixes for indexing code.
* *
@ -960,16 +964,14 @@ Yap_absmi(int inp)
LogUpdClause *lcl = PREG->u.lld.d; LogUpdClause *lcl = PREG->u.lld.d;
UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]); UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]);
if (!VALID_TIMESTAMP(timestamp, PREG->u.lld.d)) { if (!VALID_TIMESTAMP(timestamp, lcl)) {
/* jump to next alternative */ /* jump to next alternative */
PREG = FAILCODE; PREG = FAILCODE;
} else { } else {
PredEntry *pe = PREG->u.lld.d->ClPred; LOCK(ap->StatisticsForPred.lock);
ap->StatisticsForPred.NOfRetries++;
LOCK(pe->StatisticsForPred.lock); UNLOCK(ap->StatisticsForPred.lock);
pe->StatisticsForPred.NOfRetries++; PREG = lcl->ClCode;
UNLOCK(pe->StatisticsForPred.lock);
PREG = PREG->u.lld.d->ClCode;
} }
/* HEY, leave indexing block alone!! */ /* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */ /* check if we are the ones using this code */
@ -977,7 +979,8 @@ Yap_absmi(int inp)
LOCK(cl->ClLock); LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl); DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */ /* clear the entry from the trail */
TR = B->cp_tr-1; B->cp_tr--;
TR = B->cp_tr;
/* actually get rid of the code */ /* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) { if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
UNLOCK(cl->ClLock); UNLOCK(cl->ClLock);
@ -994,10 +997,15 @@ Yap_absmi(int inp)
} }
UNLOCK(lcl->ClLock); UNLOCK(lcl->ClLock);
} }
if (cl->ClFlags & ErasedMask) if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl); Yap_ErLogUpdIndex(cl);
else setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl); Yap_CleanUpIndex(cl);
setregs();
}
save_pc(); save_pc();
} else { } else {
UNLOCK(cl->ClLock); UNLOCK(cl->ClLock);
@ -1016,10 +1024,15 @@ Yap_absmi(int inp)
TRAIL_CLREF(lcl); TRAIL_CLREF(lcl);
} }
} }
if (cl->ClFlags & ErasedMask) if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl); Yap_ErLogUpdIndex(cl);
else setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl); Yap_CleanUpIndex(cl);
setregs();
}
save_pc(); save_pc();
} }
} }
@ -1262,7 +1275,7 @@ Yap_absmi(int inp)
LogUpdClause *lcl = PREG->u.lld.d; LogUpdClause *lcl = PREG->u.lld.d;
UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]); UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]);
if (!VALID_TIMESTAMP(timestamp, PREG->u.lld.d)) { if (!VALID_TIMESTAMP(timestamp, lcl)) {
/* jump to next alternative */ /* jump to next alternative */
PREG = FAILCODE; PREG = FAILCODE;
} else { } else {
@ -1280,10 +1293,10 @@ Yap_absmi(int inp)
setregs(); setregs();
JMPNext(); JMPNext();
} }
LOCK(PREG->u.lld.d->ClPred->StatisticsForPred.lock); LOCK(ap->StatisticsForPred.lock);
PREG->u.lld.d->ClPred->StatisticsForPred.NOfRetries++; ap->StatisticsForPred.NOfRetries++;
UNLOCK(PREG->u.lld.d->ClPred->StatisticsForPred.lock); UNLOCK(ap->ClPred->StatisticsForPred.lock);
PREG = PREG->u.lld.d->ClCode; PREG = lcl->ClCode;
} }
/* HEY, leave indexing block alone!! */ /* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */ /* check if we are the ones using this code */
@ -1291,7 +1304,7 @@ Yap_absmi(int inp)
LOCK(cl->ClLock); LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl); DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */ /* clear the entry from the trail */
TR = B->cp_tr-1; TR = --B->cp_tr;
/* actually get rid of the code */ /* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) { if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
UNLOCK(cl->ClLock); UNLOCK(cl->ClLock);
@ -1308,10 +1321,15 @@ Yap_absmi(int inp)
} }
UNLOCK(lcl->ClLock); UNLOCK(lcl->ClLock);
} }
if (cl->ClFlags & ErasedMask) if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl); Yap_ErLogUpdIndex(cl);
else setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl); Yap_CleanUpIndex(cl);
setregs();
}
save_pc(); save_pc();
} else { } else {
UNLOCK(cl->ClLock); UNLOCK(cl->ClLock);
@ -1320,7 +1338,7 @@ Yap_absmi(int inp)
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) && if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) { B->cp_tr != B->cp_b->cp_tr) {
cl->ClFlags &= ~InUseMask; cl->ClFlags &= ~InUseMask;
TR = B->cp_tr-1; TR = --B->cp_tr;
/* next, recover space for the indexing code if it was erased */ /* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) { if (cl->ClFlags & (ErasedMask|DirtyMask)) {
if (PREG != FAILCODE) { if (PREG != FAILCODE) {
@ -1330,10 +1348,15 @@ Yap_absmi(int inp)
TRAIL_CLREF(lcl); TRAIL_CLREF(lcl);
} }
} }
if (cl->ClFlags & ErasedMask) if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl); Yap_ErLogUpdIndex(cl);
else setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl); Yap_CleanUpIndex(cl);
setregs();
}
save_pc(); save_pc();
} }
} }
@ -8094,12 +8117,12 @@ Yap_absmi(int inp)
LogUpdClause *lcl = PREG->u.lld.d; LogUpdClause *lcl = PREG->u.lld.d;
UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]); UInt timestamp = IntegerOfTerm(((CELL *)(B_YREG+1))[ap->ArityOfPE]);
/*fprintf(stderr,"- %p/%p %d %d %d--%u\n",PREG,ap,timestamp,ap->TimeStampOfPred,PREG->u.lld.d->ClTimeStart,PREG->u.lld.d->ClTimeEnd);*/ /* fprintf(stderr,"- %p/%p %d %d %p\n",PREG,ap,timestamp,ap->TimeStampOfPred,PREG->u.lld.d->ClCode);*/
if (!VALID_TIMESTAMP(timestamp, PREG->u.lld.d)) { if (!VALID_TIMESTAMP(timestamp, lcl)) {
/* jump to next alternative */ /* jump to next alternative */
PREG = FAILCODE; PREG = FAILCODE;
} else { } else {
PREG = PREG->u.lld.d->ClCode; PREG = lcl->ClCode;
} }
/* HEY, leave indexing block alone!! */ /* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */ /* check if we are the ones using this code */
@ -8107,7 +8130,8 @@ Yap_absmi(int inp)
LOCK(cl->ClLock); LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl); DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */ /* clear the entry from the trail */
TR = B->cp_tr-1; B->cp_tr--;
TR = B->cp_tr;
/* actually get rid of the code */ /* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) { if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
UNLOCK(cl->ClLock); UNLOCK(cl->ClLock);
@ -8121,13 +8145,19 @@ Yap_absmi(int inp)
/* always add an extra reference */ /* always add an extra reference */
INC_CLREF_COUNT(lcl); INC_CLREF_COUNT(lcl);
TRAIL_CLREF(lcl); TRAIL_CLREF(lcl);
B->cp_tr = TR;
} }
UNLOCK(lcl->ClLock); UNLOCK(lcl->ClLock);
} }
if (cl->ClFlags & ErasedMask) if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl); Yap_ErLogUpdIndex(cl);
else setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl); Yap_CleanUpIndex(cl);
setregs();
}
save_pc(); save_pc();
} else { } else {
UNLOCK(cl->ClLock); UNLOCK(cl->ClLock);
@ -8136,7 +8166,8 @@ Yap_absmi(int inp)
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) && if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) { B->cp_tr != B->cp_b->cp_tr) {
cl->ClFlags &= ~InUseMask; cl->ClFlags &= ~InUseMask;
TR = B->cp_tr-1; B->cp_tr--;
TR = B->cp_tr;
/* next, recover space for the indexing code if it was erased */ /* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) { if (cl->ClFlags & (ErasedMask|DirtyMask)) {
if (PREG != FAILCODE) { if (PREG != FAILCODE) {
@ -8144,13 +8175,18 @@ Yap_absmi(int inp)
if (lcl->ClRefCount == 1 && !(lcl->ClFlags & InUseMask)) { if (lcl->ClRefCount == 1 && !(lcl->ClFlags & InUseMask)) {
lcl->ClFlags |= InUseMask; lcl->ClFlags |= InUseMask;
TRAIL_CLREF(lcl); TRAIL_CLREF(lcl);
B->cp_tr = TR;
} }
} }
if (cl->ClFlags & ErasedMask) if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl); Yap_ErLogUpdIndex(cl);
else setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl); Yap_CleanUpIndex(cl);
save_pc(); setregs();
}
} }
} }
#endif #endif

118
C/adtdefs.c
View File

@ -33,6 +33,7 @@ Prop STD_PROTO(PredPropByAtom,(Atom, Term));
#include "Heap.h" #include "Heap.h"
#include "yapio.h" #include "yapio.h"
#include <stdio.h> #include <stdio.h>
#include <wchar.h>
#if HAVE_STRING_H #if HAVE_STRING_H
#include <string.h> #include <string.h>
#endif #endif
@ -139,6 +140,21 @@ SearchAtom(unsigned char *p, Atom a) {
return(NIL); return(NIL);
} }
static inline Atom
SearchWideAtom(wchar_t *p, Atom a) {
AtomEntry *ae;
/* search atom in chain */
while (a != NIL) {
ae = RepAtom(a);
if (wcscmp((wchar_t *)ae->StrOfAE, p) == 0) {
return a;
}
a = ae->NextOfAE;
}
return(NIL);
}
static Atom static Atom
LookupAtom(char *atom) LookupAtom(char *atom)
{ /* lookup atom in atom table */ { /* lookup atom in atom table */
@ -194,12 +210,80 @@ LookupAtom(char *atom)
return na; return na;
} }
static Atom
LookupWideAtom(wchar_t *atom)
{ /* lookup atom in atom table */
CELL hash;
wchar_t *p;
Atom a, na;
AtomEntry *ae;
UInt sz;
WideAtomEntry *wae;
/* compute hash */
p = atom;
hash = WideHashFunction(p) % WideAtomHashTableSize;
/* we'll start by holding a read lock in order to avoid contention */
READ_LOCK(WideHashChain[hash].AERWLock);
a = WideHashChain[hash].Entry;
/* search atom in chain */
na = SearchWideAtom(atom, a);
if (na != NIL) {
READ_UNLOCK(WideHashChain[hash].AERWLock);
return(na);
}
READ_UNLOCK(WideHashChain[hash].AERWLock);
/* we need a write lock */
WRITE_LOCK(WideHashChain[hash].AERWLock);
/* concurrent version of Yap, need to take care */
#if defined(YAPOR) || defined(THREADS)
if (a != WideHashChain[hash].Entry) {
a = WideHashChain[hash].Entry;
na = SearchWideAtom((unsigned char *)atom, a);
if (na != NIL) {
WRITE_UNLOCK(WideHashChain[hash].AERWLock);
return na;
}
}
#endif
/* add new atom to start of chain */
sz = wcslen(atom);
ae = (AtomEntry *) Yap_AllocAtomSpace(sizeof(AtomEntry) + sizeof(wchar_t)*(sz + 1)+sizeof(WideAtomEntry));
if (ae == NULL) {
WRITE_UNLOCK(WideHashChain[hash].AERWLock);
return NIL;
}
wae = (WideAtomEntry *)(ae->StrOfAE+sizeof(wchar_t)*(sz + 1));
na = AbsAtom(ae);
ae->PropsOfAE = AbsWideAtomProp(wae);
wae->NextOfPE = NIL;
wae->KindOfPE = WideAtomProperty;
wae->SizeOfAtom = sz;
if (ae->StrOfAE != (char *)atom)
wcscpy((wchar_t *)(ae->StrOfAE), atom);
NOfAtoms++;
ae->NextOfAE = a;
WideHashChain[hash].Entry = na;
INIT_RWLOCK(ae->ARWLock);
WRITE_UNLOCK(WideHashChain[hash].AERWLock);
if (NOfWideAtoms > 2*WideAtomHashTableSize) {
Yap_signal(YAP_CDOVF_SIGNAL);
}
return na;
}
Atom Atom
Yap_LookupAtom(char *atom) Yap_LookupAtom(char *atom)
{ /* lookup atom in atom table */ { /* lookup atom in atom table */
return LookupAtom(atom); return LookupAtom(atom);
} }
Atom
Yap_LookupWideAtom(wchar_t *atom)
{ /* lookup atom in atom table */
return LookupWideAtom(atom);
}
Atom Atom
Yap_FullLookupAtom(char *atom) Yap_FullLookupAtom(char *atom)
{ /* lookup atom in atom table */ { /* lookup atom in atom table */
@ -517,6 +601,7 @@ Yap_GetExpPropHavingLock(AtomEntry *ae, unsigned int arity)
p = RepExpProp(p0 = ae->PropsOfAE); p = RepExpProp(p0 = ae->PropsOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity)) while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE); p = RepExpProp(p0 = p->NextOfPE);
return (p0); return (p0);
} }
@ -868,6 +953,19 @@ Yap_StringToList(char *s)
return (t); return (t);
} }
Term
Yap_WStringToList(wchar_t *s)
{
Term t;
wchar_t *cp = s + wcslen(s);
t = MkAtomTerm(AtomNil);
while (cp > s) {
t = MkPairTerm(MkIntegerTerm(*--cp), t);
}
return t;
}
Term Term
Yap_StringToDiffList(char *s, Term t) Yap_StringToDiffList(char *s, Term t)
{ {
@ -895,6 +993,22 @@ Yap_StringToListOfAtoms(char *s)
return (t); return (t);
} }
Term
Yap_WStringToListOfAtoms(wchar_t *s)
{
register Term t;
wchar_t so[2];
wchar_t *cp = s + wcslen(s);
so[1] = '\0';
t = MkAtomTerm(AtomNil);
while (cp > s) {
so[0] = *--cp;
t = MkPairTerm(MkAtomTerm(LookupWideAtom(so)), t);
}
return t;
}
Term Term
Yap_ArrayToList(register Term *tp, int nof) Yap_ArrayToList(register Term *tp, int nof)
{ {
@ -927,8 +1041,8 @@ Yap_GetName(char *s, UInt max, Term t)
if (!IsNumTerm(Head)) if (!IsNumTerm(Head))
return (FALSE); return (FALSE);
i = IntOfTerm(Head); i = IntOfTerm(Head);
if (i < 0 || i > 255) if (i < 0 || i > MAX_ISO_LATIN1)
return (FALSE); return FALSE;
*s++ = i; *s++ = i;
t = TailOfTerm(t); t = TailOfTerm(t);
if (--max == 0) { if (--max == 0) {

72
C/agc.c
View File

@ -143,6 +143,7 @@ AtomAdjust(Atom a)
#define PtoHeapCellAdjust(P) (P) #define PtoHeapCellAdjust(P) (P)
#define PtoOpAdjust(P) (P) #define PtoOpAdjust(P) (P)
#define PtoLUClauseAdjust(P) (P) #define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define PtoPredAdjust(P) (P) #define PtoPredAdjust(P) (P)
#define PropAdjust(P) (P) #define PropAdjust(P) (P)
#define TrailAddrAdjust(P) (P) #define TrailAddrAdjust(P) (P)
@ -162,22 +163,14 @@ rehash(CELL *oldcode, int NOfE, int KindOfEntries)
#include "rheap.h" #include "rheap.h"
/*
* This is the really tough part, to restore the whole of the heap
*/
static void static void
mark_atoms(void) mark_hash_entry(AtomHashEntry *HashPtr)
{ {
AtomHashEntry *HashPtr = HashChain;
register int i;
Atom atm; Atom atm;
AtomEntry *at;
restore_codes();
for (i = 0; i < AtomHashTableSize; ++i) {
atm = HashPtr->Entry; atm = HashPtr->Entry;
if (atm) { if (atm) {
at = RepAtom(atm); AtomEntry *at = RepAtom(atm);
do { do {
#ifdef DEBUG_RESTORE1 /* useful during debug */ #ifdef DEBUG_RESTORE1 /* useful during debug */
fprintf(errout, "Restoring %s\n", at->StrOfAE); fprintf(errout, "Restoring %s\n", at->StrOfAE);
@ -187,6 +180,27 @@ mark_atoms(void)
at = RepAtom(CleanAtomMarkedBit(atm)); at = RepAtom(CleanAtomMarkedBit(atm));
} while (!EndOfPAEntr(at)); } while (!EndOfPAEntr(at));
} }
}
/*
* This is the really tough part, to restore the whole of the heap
*/
static void
mark_atoms(void)
{
AtomHashEntry *HashPtr = HashChain;
register int i;
AtomEntry *at;
Atom atm;
restore_codes();
for (i = 0; i < AtomHashTableSize; ++i) {
mark_hash_entry(HashPtr);
HashPtr++;
}
HashPtr = WideHashChain;
for (i = 0; i < WideAtomHashTableSize; ++i) {
mark_hash_entry(HashPtr);
HashPtr++; HashPtr++;
} }
@ -304,23 +318,13 @@ mark_stacks(void)
mark_global(); mark_global();
} }
/*
* This is the really tough part, to restore the whole of the heap
*/
static void static void
clean_atoms(void) clean_atom(AtomHashEntry *HashPtr)
{ {
AtomHashEntry *HashPtr = HashChain; Atom atm = HashPtr->Entry;
register int i; Atom *patm = &(HashPtr->Entry);
Atom atm;
Atom *patm;
AtomEntry *at;
for (i = 0; i < AtomHashTableSize; ++i) {
atm = HashPtr->Entry;
patm = &(HashPtr->Entry);
while (atm != NIL) { while (atm != NIL) {
at = RepAtom(CleanAtomMarkedBit(atm)); AtomEntry *at = RepAtom(CleanAtomMarkedBit(atm));
if (AtomResetMark(at) || (AGCHook != NULL && !AGCHook(atm))) { if (AtomResetMark(at) || (AGCHook != NULL && !AGCHook(atm))) {
patm = &(at->NextOfAE); patm = &(at->NextOfAE);
atm = at->NextOfAE; atm = at->NextOfAE;
@ -335,6 +339,26 @@ clean_atoms(void)
Yap_FreeCodeSpace((char *)at); Yap_FreeCodeSpace((char *)at);
} }
} }
}
/*
* This is the really tough part, to restore the whole of the heap
*/
static void
clean_atoms(void)
{
AtomHashEntry *HashPtr = HashChain;
register int i;
Atom atm;
Atom *patm;
AtomEntry *at;
for (i = 0; i < AtomHashTableSize; ++i) {
clean_atom(HashPtr);
HashPtr++;
}
for (i = 0; i < WideAtomHashTableSize; ++i) {
clean_atom(HashPtr);
HashPtr++; HashPtr++;
} }
patm = &(INVISIBLECHAIN.Entry); patm = &(INVISIBLECHAIN.Entry);

22
C/c_interface.c
View File

@ -10,8 +10,13 @@
* File: c_interface.c * * File: c_interface.c *
* comments: c_interface primitives definition * * comments: c_interface primitives definition *
* * * *
* Last rev: $Date: 2006-05-16 18:37:30 $,$Author: vsc $ * * Last rev: $Date: 2006-11-27 17:42:02 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.85 2006/05/16 18:37:30 vsc
* WIN32 fixes
* compiler bug fixes
* extend interface
*
* Revision 1.84 2006/03/09 15:52:04 tiagosoares * Revision 1.84 2006/03/09 15:52:04 tiagosoares
* CUT_C and MYDDAS support for 64 bits architectures * CUT_C and MYDDAS support for 64 bits architectures
* *
@ -293,7 +298,7 @@ X_API void STD_PROTO(YAP_PruneGoal,(void));
X_API void STD_PROTO(YAP_InitConsult,(int, char *)); X_API void STD_PROTO(YAP_InitConsult,(int, char *));
X_API void STD_PROTO(YAP_EndConsult,(void)); X_API void STD_PROTO(YAP_EndConsult,(void));
X_API Term STD_PROTO(YAP_Read, (int (*)(void))); X_API Term STD_PROTO(YAP_Read, (int (*)(void)));
X_API void STD_PROTO(YAP_Write, (Term, void (*)(int), int)); X_API void STD_PROTO(YAP_Write, (Term, wchar_t (*)(wchar_t), int));
X_API Term STD_PROTO(YAP_WriteBuffer, (Term, char *, unsigned int, int)); X_API Term STD_PROTO(YAP_WriteBuffer, (Term, char *, unsigned int, int));
X_API char *STD_PROTO(YAP_CompileClause, (Term)); X_API char *STD_PROTO(YAP_CompileClause, (Term));
X_API void STD_PROTO(YAP_PutValue, (Atom,Term)); X_API void STD_PROTO(YAP_PutValue, (Atom,Term));
@ -344,9 +349,9 @@ static int do_yap_getc(int streamno) {
return(do_getf()); return(do_getf());
} }
static void (*do_putcf)(int); static wchar_t (*do_putcf)(wchar_t);
static int do_yap_putc(int streamno,int ch) { static wchar_t do_yap_putc(int streamno,wchar_t ch) {
do_putcf(ch); do_putcf(ch);
return(ch); return(ch);
} }
@ -1002,9 +1007,10 @@ YAP_Error(int myerrno, Term t, char *buf,...)
Yap_Error(myerrno,t,tmpbuf); Yap_Error(myerrno,t,tmpbuf);
} }
static void myputc (int ch) static wchar_t myputc (wchar_t ch)
{ {
putc(ch,stderr); putc(ch,stderr);
return ch;
} }
X_API Term X_API Term
@ -1130,12 +1136,12 @@ YAP_Read(int (*mygetc)(void))
BACKUP_MACHINE_REGS(); BACKUP_MACHINE_REGS();
do_getf = mygetc; do_getf = mygetc;
sno = Yap_GetFreeStreamD(); sno = Yap_GetFreeStreamDForReading();
if (sno < 0) { if (sno < 0) {
Yap_Error(SYSTEM_ERROR,TermNil, "new stream not available for YAP_Read"); Yap_Error(SYSTEM_ERROR,TermNil, "new stream not available for YAP_Read");
return TermNil; return TermNil;
} }
Stream[sno].stream_getc_for_read = Stream[sno].stream_getc = do_yap_getc; Stream[sno].stream_getc = do_yap_getc;
tokstart = Yap_tokptr = Yap_toktide = Yap_tokenizer(sno); tokstart = Yap_tokptr = Yap_toktide = Yap_tokenizer(sno);
Stream[sno].status = Free_Stream_f; Stream[sno].status = Free_Stream_f;
if (Yap_ErrorMessage) if (Yap_ErrorMessage)
@ -1152,7 +1158,7 @@ YAP_Read(int (*mygetc)(void))
} }
X_API void X_API void
YAP_Write(Term t, void (*myputc)(int), int flags) YAP_Write(Term t, wchar_t (*myputc)(wchar_t), int flags)
{ {
BACKUP_MACHINE_REGS(); BACKUP_MACHINE_REGS();

6
C/cdmgr.c
View File

@ -11,8 +11,11 @@
* File: cdmgr.c * * File: cdmgr.c *
* comments: Code manager * * comments: Code manager *
* * * *
* Last rev: $Date: 2006-11-15 00:13:36 $,$Author: vsc $ * * Last rev: $Date: 2006-11-27 17:42:02 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.199 2006/11/15 00:13:36 vsc
* fixes for indexing code.
*
* Revision 1.198 2006/11/14 11:42:25 vsc * Revision 1.198 2006/11/14 11:42:25 vsc
* fix bug in growstack * fix bug in growstack
* *
@ -574,6 +577,7 @@ static_in_use(PredEntry *p, int check_everything)
#define PtoPredAdjust(X) (X) #define PtoPredAdjust(X) (X)
#define PtoOpAdjust(X) (X) #define PtoOpAdjust(X) (X)
#define PtoLUClauseAdjust(P) (P) #define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define XAdjust(X) (X) #define XAdjust(X) (X)
#define YAdjust(X) (X) #define YAdjust(X) (X)
#define AtomTermAdjust(X) (X) #define AtomTermAdjust(X) (X)

47
C/cmppreds.c
View File

@ -25,6 +25,7 @@ static char SccsId[] = "%W% %G%";
#if HAVE_STRING_H #if HAVE_STRING_H
#include <string.h> #include <string.h>
#endif #endif
#include <wchar.h>
STATIC_PROTO(Int compare, (Term, Term)); STATIC_PROTO(Int compare, (Term, Term));
STATIC_PROTO(Int p_compare, (void)); STATIC_PROTO(Int p_compare, (void));
@ -43,6 +44,36 @@ STATIC_PROTO(Int a_gen_ge, (Term,Term));
#define rfloat(X) ( X > 0.0 ? 1 : ( X == 0.0 ? 0 : -1)) #define rfloat(X) ( X > 0.0 ? 1 : ( X == 0.0 ? 0 : -1))
static int
cmp_atoms(Atom a1, Atom a2)
{
if (IsWideAtom(a1)) {
if (IsWideAtom(a2)) {
return wcscmp((wchar_t *)RepAtom(a1)->StrOfAE,(wchar_t *)RepAtom(a2)->StrOfAE);
} else {
/* The standard does not seem to have nothing on this */
unsigned char *s1 = (unsigned char *)RepAtom(a1)->StrOfAE;
wchar_t *s2 = (wchar_t *)RepAtom(a2)->StrOfAE;
while (*s1 == *s2) {
if (!*s1) return 0;
}
return *s1-*s2;
}
} else if (IsWideAtom(a2)) {
/* The standard does not seem to have nothing on this */
wchar_t *s1 = (wchar_t *)RepAtom(a1)->StrOfAE;
unsigned char *s2 = (unsigned char *)RepAtom(a2)->StrOfAE;
while (*s1 == *s2) {
if (!*s1) return 0;
}
return *s1-*s2;
} else {
return strcmp(RepAtom(a1)->StrOfAE,RepAtom(a2)->StrOfAE);
}
}
static int compare_complex(register CELL *pt0, register CELL *pt0_end, register static int compare_complex(register CELL *pt0, register CELL *pt0_end, register
CELL *pt1) CELL *pt1)
{ {
@ -73,10 +104,7 @@ static int compare_complex(register CELL *pt0, register CELL *pt0_end, register
if (d0 == d1) continue; if (d0 == d1) continue;
else if (IsAtomTerm(d0)) { else if (IsAtomTerm(d0)) {
if (IsAtomTerm(d1)) if (IsAtomTerm(d1))
out = strcmp( out = cmp_atoms(AtomOfTerm(d0), AtomOfTerm(d1));
RepAtom(AtomOfTerm(d0))->StrOfAE,
RepAtom(AtomOfTerm(d1))->StrOfAE
);
else if (IsPrimitiveTerm(d1)) else if (IsPrimitiveTerm(d1))
out = 1; out = 1;
else out = -1; else out = -1;
@ -207,8 +235,7 @@ static int compare_complex(register CELL *pt0, register CELL *pt0_end, register
/* compare functors */ /* compare functors */
if (f != (Functor)*ap3) { if (f != (Functor)*ap3) {
if (!(out = ArityOfFunctor(f)-ArityOfFunctor(f2))) if (!(out = ArityOfFunctor(f)-ArityOfFunctor(f2)))
out = strcmp(RepAtom(NameOfFunctor(f))->StrOfAE, out = cmp_atoms(NameOfFunctor(f), NameOfFunctor(f2));
RepAtom(NameOfFunctor(f2))->StrOfAE);
goto done; goto done;
} }
#ifdef RATIONAL_TREES #ifdef RATIONAL_TREES
@ -285,10 +312,7 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
if (IsAtomOrIntTerm(t1)) { if (IsAtomOrIntTerm(t1)) {
if (IsAtomTerm(t1)) { if (IsAtomTerm(t1)) {
if (IsAtomTerm(t2)) if (IsAtomTerm(t2))
return strcmp( return cmp_atoms(AtomOfTerm(t1),AtomOfTerm(t2));
RepAtom(AtomOfTerm(t1))->StrOfAE,
RepAtom(AtomOfTerm(t2))->StrOfAE
);
if (IsPrimitiveTerm(t2)) if (IsPrimitiveTerm(t2))
return 1; return 1;
return -1; return -1;
@ -404,8 +428,7 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
r = ArityOfFunctor(fun1) - ArityOfFunctor(fun2); r = ArityOfFunctor(fun1) - ArityOfFunctor(fun2);
if (r) if (r)
return r; return r;
r = strcmp(RepAtom(NameOfFunctor(fun1))->StrOfAE, r = cmp_atoms(NameOfFunctor(fun1), NameOfFunctor(fun2));
RepAtom(NameOfFunctor(fun2))->StrOfAE);
if (r) if (r)
return r; return r;
else else

16
C/dbase.c
View File

@ -4845,6 +4845,22 @@ cont_current_key(void)
READ_UNLOCK(HashChain[i].AERWLock); READ_UNLOCK(HashChain[i].AERWLock);
i++; i++;
} }
i = 0;
while (i < WideAtomHashTableSize) {
/* protect current hash table line, notice that the current
LOCK/UNLOCK algorithm assumes new entries are added to
the *front* of the list, otherwise I should have locked
earlier.
*/
READ_LOCK(HashChain[i].AERWLock);
a = HashChain[i].Entry;
if (a != NIL) {
break;
}
/* move to next entry */
READ_UNLOCK(HashChain[i].AERWLock);
i++;
}
if (i == AtomHashTableSize) { if (i == AtomHashTableSize) {
/* we have left the atom hash table */ /* we have left the atom hash table */
/* we don't have a lock over the hash table any longer */ /* we don't have a lock over the hash table any longer */

13
C/heapgc.c
View File

@ -1743,6 +1743,7 @@ mark_slots(CELL *ptr)
static void static void
mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose) mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
{ {
OPCODE trust_lu = Yap_opcode(_trust_logical);
yamop *lu_cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,ld), yamop *lu_cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,ld),
*lu_cl = NEXTOP(PredLogUpdClause->CodeOfPred,ld), *lu_cl = NEXTOP(PredLogUpdClause->CodeOfPred,ld),
@ -2017,6 +2018,17 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
case _retry_logical: case _retry_logical:
case _count_retry_logical: case _count_retry_logical:
case _profiled_retry_logical: case _profiled_retry_logical:
{
/* find out who owns this sequence of try-retry-trust */
/* I don't like this code, it's a bad idea to do a linear scan,
on the other hand it's the only way we can be sure we can reclaim
space
*/
yamop *end = rtp->u.lld.n;
while (end->opc != trust_lu)
end = end->u.lld.n;
mark_ref_in_use((DBRef)end->u.lld.t.block);
}
/* mark timestamp */ /* mark timestamp */
nargs = rtp->u.lld.t.s+1; nargs = rtp->u.lld.t.s+1;
break; break;
@ -2024,6 +2036,7 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
case _count_trust_logical: case _count_trust_logical:
case _profiled_trust_logical: case _profiled_trust_logical:
/* mark timestamp */ /* mark timestamp */
mark_ref_in_use((DBRef)rtp->u.lld.t.block);
nargs = rtp->u.lld.d->ClPred->ArityOfPE+1; nargs = rtp->u.lld.d->ClPred->ArityOfPE+1;
break; break;
#ifdef DEBUG #ifdef DEBUG

31
C/index.c
View File

@ -11,8 +11,12 @@
* File: index.c * * File: index.c *
* comments: Indexing a Prolog predicate * * comments: Indexing a Prolog predicate *
* * * *
* Last rev: $Date: 2006-11-21 16:21:31 $,$Author: vsc $ * * Last rev: $Date: 2006-11-27 17:42:02 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.178 2006/11/21 16:21:31 vsc
* fix I/O mess
* fix spy/reconsult mess
*
* Revision 1.177 2006/11/15 00:13:36 vsc * Revision 1.177 2006/11/15 00:13:36 vsc
* fixes for indexing code. * fixes for indexing code.
* *
@ -776,7 +780,7 @@ delete_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
while (i < regs_count) { while (i < regs_count) {
if (regs[i] == copy) { if (regs[i] == copy) {
/* we found it */ /* we found it */
regs[i] = regs[MAX_REG_COPIES-1]; regs[i] = regs[regs_count-1];
return regs_count-1; return regs_count-1;
} }
i++; i++;
@ -789,13 +793,12 @@ delete_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
inline static int inline static int
regcopy_in(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy) regcopy_in(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
{ {
int i = 0; int i;
do { for (i=0; i<regs_count; i++) {
if (regs[i] == copy) { if (regs[i] == copy) {
return TRUE; return TRUE;
} }
i++; }
} while (i < regs_count);
/* this copy could not be found */ /* this copy could not be found */
return FALSE; return FALSE;
} }
@ -1401,10 +1404,12 @@ add_info(ClauseDef *clause, UInt regno)
case _commit_b_x: case _commit_b_x:
clause->Tag = (CELL)NULL; clause->Tag = (CELL)NULL;
return; return;
case _save_b_x:
case _write_x_val: case _write_x_val:
case _write_x_loc: case _write_x_loc:
case _write_x_var: case _write_x_var:
cl = NEXTOP(cl,e);
break;
case _save_b_x:
case _put_list: case _put_list:
if (regcopy_in(myregs, nofregs, cl->u.x.x)) { if (regcopy_in(myregs, nofregs, cl->u.x.x)) {
clause->Tag = (CELL)NULL; clause->Tag = (CELL)NULL;
@ -1772,6 +1777,10 @@ add_info(ClauseDef *clause, UInt regno)
} else { } else {
nofregs = delete_regcopy(myregs, nofregs, cl->u.yx.x); nofregs = delete_regcopy(myregs, nofregs, cl->u.yx.x);
} }
if (nofregs == 0 && !ycopy) {
clause->Tag = (CELL)NULL;
return;
}
cl = NEXTOP(cl,yx); cl = NEXTOP(cl,yx);
break; break;
case _get_y_val: case _get_y_val:
@ -5454,7 +5463,7 @@ expand_index(struct intermediates *cint) {
} }
newpc = (yamop *)(fe->Label); newpc = (yamop *)(fe->Label);
labp = (yamop **)(&(fe->Label)); labp = (yamop **)&(fe->Label);
if (newpc == e_code) { if (newpc == e_code) {
/* we found it */ /* we found it */
parentcl = code_to_indexcl(ipc->u.sssl.l,is_lu); parentcl = code_to_indexcl(ipc->u.sssl.l,is_lu);
@ -7930,7 +7939,8 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
newpc = ipc->u.lld.d; newpc = ipc->u.lld.d;
} }
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
TR = B->cp_tr-1; B->cp_tr--;
TR--;
LOCK(cl->ClLock); LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl); DEC_CLREF_COUNT(cl);
/* actually get rid of the code */ /* actually get rid of the code */
@ -7951,7 +7961,8 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) && if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) { B->cp_tr != B->cp_b->cp_tr) {
TR = B->cp_tr-1; B->cp_tr--;
TR--;
cl->ClFlags &= ~InUseMask; cl->ClFlags &= ~InUseMask;
/* next, recover space for the indexing code if it was erased */ /* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) { if (cl->ClFlags & (ErasedMask|DirtyMask)) {

10
C/init.c
View File

@ -1352,6 +1352,7 @@ Yap_InitWorkspace(int Heap, int Stack, int Trail, int max_table_size,
Yap_InitTime (); Yap_InitTime ();
AtomHashTableSize = MaxHash; AtomHashTableSize = MaxHash;
WideAtomHashTableSize = MaxWideHash;
HashChain = (AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxHash); HashChain = (AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxHash);
if (HashChain == NULL) { if (HashChain == NULL) {
Yap_Error(FATAL_ERROR,MkIntTerm(0),"allocating initial atom table"); Yap_Error(FATAL_ERROR,MkIntTerm(0),"allocating initial atom table");
@ -1360,7 +1361,16 @@ Yap_InitWorkspace(int Heap, int Stack, int Trail, int max_table_size,
INIT_RWLOCK(HashChain[i].AERWLock); INIT_RWLOCK(HashChain[i].AERWLock);
HashChain[i].Entry = NIL; HashChain[i].Entry = NIL;
} }
WideHashChain = (AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxWideHash);
if (WideHashChain == NULL) {
Yap_Error(FATAL_ERROR,MkIntTerm(0),"allocating initial atom table");
}
for (i = 0; i < MaxWideHash; ++i) {
INIT_RWLOCK(WideHashChain[i].AERWLock);
WideHashChain[i].Entry = NIL;
}
NOfAtoms = 0; NOfAtoms = 0;
NOfWideAtoms = 0;
#if THREADS #if THREADS
SF_STORE->AtFoundVar = Yap_LookupAtom("."); SF_STORE->AtFoundVar = Yap_LookupAtom(".");
Yap_ReleaseAtom(AtomFoundVar); Yap_ReleaseAtom(AtomFoundVar);

589
C/iopreds.c
View File

File diff suppressed because it is too large Load Diff

17
C/parser.c
View File

@ -525,6 +525,21 @@ ParseTerm(int prio, JMPBUFF *FailBuff)
} }
break; break;
case WString_tok: /* build list on the heap */
{
Volatile wchar_t *p = (wchar_t *) Yap_tokptr->TokInfo;
if (*p == 0)
t = MkAtomTerm(AtomNil);
else if (yap_flags[YAP_DOUBLE_QUOTES_FLAG] == STRING_AS_CHARS)
t = Yap_WStringToListOfAtoms(p);
else if (yap_flags[YAP_DOUBLE_QUOTES_FLAG] == STRING_AS_ATOM)
t = MkAtomTerm(Yap_LookupWideAtom(p));
else
t = Yap_WStringToList(p);
NextToken;
}
break;
case Var_tok: case Var_tok:
varinfo = (VarEntry *) (Yap_tokptr->TokInfo); varinfo = (VarEntry *) (Yap_tokptr->TokInfo);
if ((t = varinfo->VarAdr) == TermNil) { if ((t = varinfo->VarAdr) == TermNil) {
@ -653,7 +668,7 @@ ParseTerm(int prio, JMPBUFF *FailBuff)
continue; continue;
} }
} }
if (Yap_tokptr->Tok <= Ord(String_tok)) if (Yap_tokptr->Tok <= Ord(WString_tok))
FAIL; FAIL;
break; break;
} }

31
C/save.c
View File

@ -1301,6 +1301,25 @@ restore_heap(void)
do { do {
#ifdef DEBUG_RESTORE2 /* useful during debug */ #ifdef DEBUG_RESTORE2 /* useful during debug */
fprintf(errout, "Restoring %s\n", at->StrOfAE); fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif
at->PropsOfAE = PropAdjust(at->PropsOfAE);
RestoreEntries(RepProp(at->PropsOfAE));
atm = at->NextOfAE = AtomAdjust(at->NextOfAE);
at = RepAtom(atm);
} while (!EndOfPAEntr(at));
}
HashPtr++;
}
HashPtr = WideHashChain;
for (i = 0; i < WideAtomHashTableSize; ++i) {
Atom atm = HashPtr->Entry;
if (atm) {
AtomEntry *at;
HashPtr->Entry = atm = AtomAdjust(atm);
at = RepAtom(atm);
do {
#ifdef DEBUG_RESTORE2 /* useful during debug */
fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif #endif
at->PropsOfAE = PropAdjust(at->PropsOfAE); at->PropsOfAE = PropAdjust(at->PropsOfAE);
RestoreEntries(RepProp(at->PropsOfAE)); RestoreEntries(RepProp(at->PropsOfAE));
@ -1343,6 +1362,18 @@ ShowAtoms()
} }
HashPtr++; HashPtr++;
} }
HashPtr = WideHashChain;
for (i = 0; i < WideAtomHashTableSize; ++i) {
if (HashPtr->Entry != NIL) {
AtomEntry *at;
at = RepAtom(HashPtr->Entry);
do {
fprintf(Yap_stderr,"Passei ao %s em %x\n", at->StrOfAE, at);
ShowEntries(RepProp(at->PropsOfAE));
} while (!EndOfPAEntr(at = RepAtom(at->NextOfAE)));
}
HashPtr++;
}
} }
#endif /* DEBUG_RESTORE3 */ #endif /* DEBUG_RESTORE3 */

133
C/scanner.c
View File

@ -57,7 +57,7 @@
STATIC_PROTO(int my_getch, (int (*) (int))); STATIC_PROTO(int my_getch, (int (*) (int)));
STATIC_PROTO(Term float_send, (char *)); STATIC_PROTO(Term float_send, (char *));
STATIC_PROTO(Term get_num, (int *, int *, int, int (*) (int), int (*) (int),char *,UInt)); STATIC_PROTO(Term get_num, (wchar_t *, wchar_t *, int, wchar_t (*) (int), wchar_t (*) (int),char *,UInt));
/* token table with some help from Richard O'Keefe's PD scanner */ /* token table with some help from Richard O'Keefe's PD scanner */
static char chtype0[NUMBER_OF_CHARS+1] = static char chtype0[NUMBER_OF_CHARS+1] =
@ -231,8 +231,8 @@ read_int_overflow(const char *s, Int base, Int val)
#endif #endif
} }
static unsigned int static wchar_t
read_quoted_char(int *scan_nextp, int inp_stream, int (*QuotedNxtch)(int)) read_quoted_char(int *scan_nextp, int inp_stream, wchar_t (*QuotedNxtch)(int))
{ {
int ch; int ch;
@ -273,6 +273,46 @@ read_quoted_char(int *scan_nextp, int inp_stream, int (*QuotedNxtch)(int))
return '\r'; return '\r';
case 't': case 't':
return '\t'; return '\t';
case 'u':
{
int i;
wchar_t wc='\0';
for (i=0; i< 4; i++) {
ch = QuotedNxtch(inp_stream);
if (ch>='0' && ch <= '9') {
wc += (ch-'0')<<((3-i)*4);
} else if (ch>='a' && ch <= 'f') {
wc += ((ch-'a')+10)<<((3-i)*4);
} else if (ch>='A' && ch <= 'F') {
wc += ((ch-'A')+10)<<((3-i)*4);
} else {
Yap_ErrorMessage = "invalid escape sequence";
return 0;
}
}
return wc;
}
case 'U':
{
int i;
wchar_t wc='\0';
for (i=0; i< 8; i++) {
ch = QuotedNxtch(inp_stream);
if (ch>='0' && ch <= '9') {
wc += (ch-'0')<<((7-i)*4);
} else if (ch>='a' && ch <= 'f') {
wc += ((ch-'a')+10)<<((7-i)*4);
} else if (ch>='A' && ch <= 'F') {
wc += ((ch-'A')+10)<<((7-i)*4);
} else {
Yap_ErrorMessage = "invalid escape sequence";
return 0;
}
}
return wc;
}
case 'v': case 'v':
return '\v'; return '\v';
case '\\': case '\\':
@ -415,7 +455,7 @@ read_quoted_char(int *scan_nextp, int inp_stream, int (*QuotedNxtch)(int))
/* reads a number, either integer or float */ /* reads a number, either integer or float */
static Term static Term
get_num(int *chp, int *chbuffp, int inp_stream, int (*Nxtch) (int), int (*QuotedNxtch) (int), char *s, UInt max_size) get_num(wchar_t *chp, wchar_t *chbuffp, int inp_stream, wchar_t (*Nxtch) (int), wchar_t (*QuotedNxtch) (int), char *s, UInt max_size)
{ {
char *sp = s; char *sp = s;
int ch = *chp; int ch = *chp;
@ -450,7 +490,7 @@ get_num(int *chp, int *chbuffp, int inp_stream, int (*Nxtch) (int), int (*Quoted
*sp++ = ch; *sp++ = ch;
ch = Nxtch(inp_stream); ch = Nxtch(inp_stream);
if (base == 0) { if (base == 0) {
Int ascii = ch; wchar_t ascii = ch;
int scan_extra = TRUE; int scan_extra = TRUE;
if (ch == '\\' && if (ch == '\\' &&
@ -460,7 +500,7 @@ get_num(int *chp, int *chbuffp, int inp_stream, int (*Nxtch) (int), int (*Quoted
/* a quick way to represent ASCII */ /* a quick way to represent ASCII */
if (scan_extra) if (scan_extra)
*chp = Nxtch(inp_stream); *chp = Nxtch(inp_stream);
return MkIntTerm(ascii); return MkIntegerTerm(ascii);
} else if (base >= 10 && base <= 36) { } else if (base >= 10 && base <= 36) {
int upper_case = 'A' - 11 + base; int upper_case = 'A' - 11 + base;
int lower_case = 'a' - 11 + base; int lower_case = 'a' - 11 + base;
@ -629,11 +669,11 @@ get_num(int *chp, int *chbuffp, int inp_stream, int (*Nxtch) (int), int (*Quoted
/* given a function Nxtch scan until we either find the number /* given a function Nxtch scan until we either find the number
or end of file */ or end of file */
Term Term
Yap_scan_num(int (*Nxtch) (int)) Yap_scan_num(wchar_t (*Nxtch) (int))
{ {
Term out; Term out;
int sign = 1; int sign = 1;
int ch, cherr; wchar_t ch, cherr;
char *ptr; char *ptr;
Yap_ErrorMessage = NULL; Yap_ErrorMessage = NULL;
@ -655,7 +695,7 @@ Yap_scan_num(int (*Nxtch) (int))
Yap_clean_tokenizer(NULL, NULL, NULL); Yap_clean_tokenizer(NULL, NULL, NULL);
return TermNil; return TermNil;
} }
cherr = 0; cherr = '\0';
if (ASP-H < 1024) if (ASP-H < 1024)
return TermNil; return TermNil;
out = get_num(&ch, &cherr, -1, Nxtch, Nxtch, ptr, 4096); out = get_num(&ch, &cherr, -1, Nxtch, Nxtch, ptr, 4096);
@ -672,15 +712,33 @@ Yap_scan_num(int (*Nxtch) (int))
return(out); return(out);
} }
static wchar_t *
ch_to_wide(char *base, char *charp)
{
int n = charp-base, i;
wchar_t *nb = (wchar_t *)base;
if ((nb+n) + 1024 > (wchar_t *)AuxSp) {
Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
Yap_ErrorMessage = "Heap Overflow While Scanning: please increase code space (-h)";
return NULL;
}
for (i=n; i > 0; i--) {
nb[i-1] = base[i-1];
}
return nb+n;
}
TokEntry * TokEntry *
Yap_tokenizer(int inp_stream) Yap_tokenizer(int inp_stream)
{ {
TokEntry *t, *l, *p; TokEntry *t, *l, *p;
enum TokenKinds kind; enum TokenKinds kind;
int solo_flag = TRUE; int solo_flag = TRUE;
int ch; wchar_t ch, *wcharp;
int (*Nxtch) (int) = Stream[inp_stream].stream_getc_for_read; wchar_t (*Nxtch) (int) = Stream[inp_stream].stream_wgetc_for_read;
int (*QuotedNxtch) (int) = Stream[inp_stream].stream_getc; wchar_t (*QuotedNxtch) (int) = Stream[inp_stream].stream_wgetc;
Yap_ErrorMessage = NULL; Yap_ErrorMessage = NULL;
Yap_Error_Size = 0; Yap_Error_Size = 0;
@ -694,7 +752,8 @@ Yap_tokenizer(int inp_stream)
LOCK(Stream[inp_stream].streamlock); LOCK(Stream[inp_stream].streamlock);
ch = Nxtch(inp_stream); ch = Nxtch(inp_stream);
do { do {
int och, quote, isvar; wchar_t och;
int quote, isvar;
char *charp, *mp; char *charp, *mp;
unsigned int len; unsigned int len;
char *TokImage = NULL; char *TokImage = NULL;
@ -785,7 +844,8 @@ Yap_tokenizer(int inp_stream)
case NU: case NU:
{ {
int cherr, cha = ch; wchar_t cherr;
wchar_t cha = ch;
char *ptr; char *ptr;
cherr = 0; cherr = 0;
@ -915,12 +975,18 @@ Yap_tokenizer(int inp_stream)
quote = ch; quote = ch;
len = 0; len = 0;
ch = QuotedNxtch(inp_stream); ch = QuotedNxtch(inp_stream);
while (1) { wcharp = NULL;
while (TRUE) {
if (charp + 1024 > (char *)AuxSp) { if (charp + 1024 > (char *)AuxSp) {
Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR; Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
Yap_ErrorMessage = "Heap Overflow While Scanning: please increase code space (-h)"; Yap_ErrorMessage = "Heap Overflow While Scanning: please increase code space (-h)";
break; break;
} }
if (ch >= 0xff){
/* does not fit in ISO-LATIN */
wcharp = ch_to_wide(TokImage, charp);
}
if (ch == 10 && yap_flags[CHARACTER_ESCAPE_FLAG] == ISO_CHARACTER_ESCAPES) { if (ch == 10 && yap_flags[CHARACTER_ESCAPE_FLAG] == ISO_CHARACTER_ESCAPES) {
/* in ISO a new line terminates a string */ /* in ISO a new line terminates a string */
Yap_ErrorMessage = "layout character \n inside quotes"; Yap_ErrorMessage = "layout character \n inside quotes";
@ -930,11 +996,25 @@ Yap_tokenizer(int inp_stream)
ch = QuotedNxtch(inp_stream); ch = QuotedNxtch(inp_stream);
if (ch != quote) if (ch != quote)
break; break;
if (wcharp)
*wcharp++ = ch;
else
*charp++ = ch; *charp++ = ch;
ch = QuotedNxtch(inp_stream); ch = QuotedNxtch(inp_stream);
} else if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) { } else if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
int scan_next = TRUE; int scan_next = TRUE;
*charp++ = read_quoted_char(&scan_next, inp_stream, QuotedNxtch); if (wcharp)
*wcharp++ = read_quoted_char(&scan_next, inp_stream, QuotedNxtch);
else {
wchar_t next = read_quoted_char(&scan_next, inp_stream, QuotedNxtch);
if (next >= 0xff){
/* does not fit in ISO-LATIN */
wcharp = ch_to_wide(TokImage, charp);
*wcharp++ = next;
} else {
*charp++ = next;
}
}
if (scan_next) { if (scan_next) {
ch = QuotedNxtch(inp_stream); ch = QuotedNxtch(inp_stream);
} }
@ -943,6 +1023,9 @@ Yap_tokenizer(int inp_stream)
t->Tok = Ord(kind = eot_tok); t->Tok = Ord(kind = eot_tok);
break; break;
} else { } else {
if (wcharp)
*wcharp++ = ch;
else
*charp++ = ch; *charp++ = ch;
ch = QuotedNxtch(inp_stream); ch = QuotedNxtch(inp_stream);
} }
@ -958,9 +1041,16 @@ Yap_tokenizer(int inp_stream)
return l; return l;
} }
} }
if (wcharp)
*wcharp++ = '\0';
else
*charp = '\0'; *charp = '\0';
if (quote == '"') { if (quote == '"') {
if (wcharp) {
mp = AllocScannerMemory(sizeof(wchar_t)*(len+1));
} else {
mp = AllocScannerMemory(len + 1); mp = AllocScannerMemory(len + 1);
}
if (mp == NULL) { if (mp == NULL) {
UNLOCK(Stream[inp_stream].streamlock); UNLOCK(Stream[inp_stream].streamlock);
Yap_ErrorMessage = "not enough heap space to read in string or quoted atom"; Yap_ErrorMessage = "not enough heap space to read in string or quoted atom";
@ -968,12 +1058,23 @@ Yap_tokenizer(int inp_stream)
t->Tok = Ord(kind = eot_tok); t->Tok = Ord(kind = eot_tok);
return l; return l;
} }
if (wcharp)
wcscpy((wchar_t *)mp,(wchar_t *)TokImage);
else
strcpy(mp, TokImage); strcpy(mp, TokImage);
t->TokInfo = Unsigned(mp); t->TokInfo = Unsigned(mp);
Yap_ReleasePreAllocCodeSpace((CODEADDR)TokImage); Yap_ReleasePreAllocCodeSpace((CODEADDR)TokImage);
if (wcharp) {
t->Tok = Ord(kind = WString_tok);
} else {
t->Tok = Ord(kind = String_tok); t->Tok = Ord(kind = String_tok);
}
} else {
if (wcharp) {
t->TokInfo = Unsigned(Yap_LookupWideAtom((wchar_t *)TokImage));
} else { } else {
t->TokInfo = Unsigned(Yap_LookupAtom(TokImage)); t->TokInfo = Unsigned(Yap_LookupAtom(TokImage));
}
Yap_ReleasePreAllocCodeSpace((CODEADDR)TokImage); Yap_ReleasePreAllocCodeSpace((CODEADDR)TokImage);
t->Tok = Ord(kind = Name_tok); t->Tok = Ord(kind = Name_tok);
if (ch == '(') if (ch == '(')

638
C/stdpreds.c
View File

@ -11,8 +11,11 @@
* File: stdpreds.c * * File: stdpreds.c *
* comments: General-purpose C implemented system predicates * * comments: General-purpose C implemented system predicates *
* * * *
* Last rev: $Date: 2006-11-16 14:26:00 $,$Author: vsc $ * * Last rev: $Date: 2006-11-27 17:42:03 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.113 2006/11/16 14:26:00 vsc
* fix handling of infinity in name/2 and friends.
*
* Revision 1.112 2006/11/08 01:56:47 vsc * Revision 1.112 2006/11/08 01:56:47 vsc
* fix argument order in db statistics. * fix argument order in db statistics.
* *
@ -217,6 +220,7 @@ static char SccsId[] = "%W% %G%";
#if HAVE_MALLOC_H #if HAVE_MALLOC_H
#include <malloc.h> #include <malloc.h>
#endif #endif
#include <wchar.h>
STD_PROTO(static Int p_setval, (void)); STD_PROTO(static Int p_setval, (void));
STD_PROTO(static Int p_value, (void)); STD_PROTO(static Int p_value, (void));
@ -519,6 +523,31 @@ FindAtom(codeToFind, arity)
READ_UNLOCK(ae->ARWLock); READ_UNLOCK(ae->ARWLock);
} }
} }
for (i = 0; i < WideAtomHashTableSize; ++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; *arityp = 0;
return (0); return (0);
} }
@ -605,13 +634,13 @@ strtod(s, pe)
static char *cur_char_ptr; static char *cur_char_ptr;
static int static wchar_t
get_char_from_string(int s) get_char_from_string(int s)
{ {
if (cur_char_ptr[0] == '\0') if (cur_char_ptr[0] == '\0')
return(-1); return(-1);
cur_char_ptr++; cur_char_ptr++;
return((int)(cur_char_ptr[-1])); return((wchar_t)(cur_char_ptr[-1]));
} }
@ -747,16 +776,44 @@ p_char_code(void)
} }
} }
static wchar_t *
ch_to_wide(char *base, char *charp)
{
int n = charp-base, i;
wchar_t *nb = (wchar_t *)base;
if ((nb+n) + 1024 > (wchar_t *)AuxSp) {
Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
Yap_ErrorMessage = "Heap Overflow While Scanning: please increase code space (-h)";
return NULL;
}
for (i=n; i > 0; i--) {
nb[i-1] = base[i-1];
}
return nb+n;
}
static Int static Int
p_name(void) p_name(void)
{ /* name(?Atomic,?String) */ { /* name(?Atomic,?String) */
char *String, *s; /* alloc temp space on trail */ char *String, *s; /* alloc temp space on trail */
Term t = Deref(ARG2), NewT, AtomNameT = Deref(ARG1); Term t = Deref(ARG2), NewT, AtomNameT = Deref(ARG1);
wchar_t *ws = NULL;
restart_aux: restart_aux:
if (!IsVarTerm(AtomNameT)) { if (!IsVarTerm(AtomNameT)) {
if (!IsVarTerm(t) && !IsPairTerm(t) && t != TermNil) {
Yap_Error(TYPE_ERROR_LIST,ARG2,
"name/2");
return FALSE;
}
if (IsAtomTerm(AtomNameT)) { if (IsAtomTerm(AtomNameT)) {
String = RepAtom(AtomOfTerm(AtomNameT))->StrOfAE; Atom at = AtomOfTerm(AtomNameT);
if (IsWideAtom(at)) {
NewT = Yap_WStringToList((wchar_t *)(RepAtom(at)->StrOfAE));
return Yap_unify(NewT, ARG2);
} else
String = RepAtom(at)->StrOfAE;
} else if (IsIntTerm(AtomNameT)) { } else if (IsIntTerm(AtomNameT)) {
String = Yap_PreAllocCodeSpace(); String = Yap_PreAllocCodeSpace();
if (String + 1024 > (char *)AuxSp) if (String + 1024 > (char *)AuxSp)
@ -794,11 +851,6 @@ p_name(void)
return FALSE; return FALSE;
} }
NewT = Yap_StringToList(String); NewT = Yap_StringToList(String);
if (!IsVarTerm(t) && !IsPairTerm(t) && t != TermNil) {
Yap_Error(TYPE_ERROR_LIST,ARG2,
"name/2");
return FALSE;
}
return Yap_unify(NewT, ARG2); return Yap_unify(NewT, ARG2);
} }
s = String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE; s = String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE;
@ -817,22 +869,49 @@ p_name(void)
Yap_Error(INSTANTIATION_ERROR,Head,"name/2"); Yap_Error(INSTANTIATION_ERROR,Head,"name/2");
return FALSE; return FALSE;
} }
if (!IsIntTerm(Head)) { if (!IsIntegerTerm(Head)) {
Yap_Error(TYPE_ERROR_INTEGER,Head,"name/2"); Yap_Error(TYPE_ERROR_INTEGER,Head,"name/2");
return FALSE; return FALSE;
} }
i = IntOfTerm(Head); i = IntegerOfTerm(Head);
if (i < 0 || i > 255) { if (i < 0 || i >= 255) {
if (i<0) if (i<0) {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,Head,"name/2"); Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,Head,"name/2");
return FALSE; return FALSE;
} else {
ws = ch_to_wide(String, s);
} }
}
if (ws) {
if (ws > (wchar_t *)AuxSp-1024) {
goto expand_auxsp;
}
*ws++ = i;
} else {
if (s > (char *)AuxSp-1024) { if (s > (char *)AuxSp-1024) {
goto expand_auxsp; goto expand_auxsp;
} }
*s++ = i; *s++ = i;
}
t = TailOfTerm(t); t = TailOfTerm(t);
} }
if (ws) {
Atom at;
*ws = '\0';
while ((at = Yap_LookupWideAtom((wchar_t *)String)) == NIL) {
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, ARG2, "generating atom from string in name/2");
return FALSE;
}
/* safest to restart, we don't know what happened to String */
t = Deref(ARG2);
AtomNameT = Deref(ARG1);
goto restart_aux;
}
NewT = MkAtomTerm(at);
return Yap_unify_constant(ARG1, NewT);
}
*s = '\0'; *s = '\0';
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"name/2"); Yap_Error(INSTANTIATION_ERROR,t,"name/2");
@ -882,20 +961,32 @@ p_atom_chars(void)
restart_aux: restart_aux:
if (!IsVarTerm(t1)) { if (!IsVarTerm(t1)) {
Term NewT; Term NewT;
Atom at;
if (!IsAtomTerm(t1)) { if (!IsAtomTerm(t1)) {
Yap_Error(TYPE_ERROR_ATOM, t1, "atom_chars/2"); Yap_Error(TYPE_ERROR_ATOM, t1, "atom_chars/2");
return(FALSE); return(FALSE);
} }
at = AtomOfTerm(t1);
if (IsWideAtom(at)) {
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) { if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
NewT = Yap_StringToList(RepAtom(AtomOfTerm(t1))->StrOfAE); NewT = Yap_WStringToList((wchar_t *)RepAtom(at)->StrOfAE);
} else {
NewT = Yap_WStringToListOfAtoms((wchar_t *)RepAtom(AtomOfTerm(t1))->StrOfAE);
}
} else {
if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) {
NewT = Yap_StringToList(RepAtom(at)->StrOfAE);
} else { } else {
NewT = Yap_StringToListOfAtoms(RepAtom(AtomOfTerm(t1))->StrOfAE); NewT = Yap_StringToListOfAtoms(RepAtom(AtomOfTerm(t1))->StrOfAE);
} }
}
return Yap_unify(NewT, ARG2); return Yap_unify(NewT, ARG2);
} else { } else {
/* ARG1 unbound */ /* ARG1 unbound */
Term t = Deref(ARG2); Term t = Deref(ARG2);
char *s; char *s;
wchar_t *ws = NULL;
Atom at; Atom at;
String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE; String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE;
@ -921,19 +1012,29 @@ p_atom_chars(void)
if (IsVarTerm(Head)) { if (IsVarTerm(Head)) {
Yap_Error(INSTANTIATION_ERROR,Head,"atom_chars/2"); Yap_Error(INSTANTIATION_ERROR,Head,"atom_chars/2");
return(FALSE); return(FALSE);
} else if (!IsIntTerm(Head)) { } else if (!IsIntegerTerm(Head)) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2"); Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2");
return(FALSE); return(FALSE);
} }
i = IntOfTerm(Head); i = IntegerOfTerm(Head);
if (i < 0 || i > 255) { if (i < 0) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2"); Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2");
return(FALSE); return(FALSE);
} }
if (i > MAX_ISO_LATIN1 && !ws) {
ws = ch_to_wide(String, s);
}
if (ws) {
if (ws > (wchar_t *)AuxSp-1024) {
goto expand_auxsp;
}
*ws++ = i;
} else {
if (s+1024 > (char *)AuxSp) { if (s+1024 > (char *)AuxSp) {
goto expand_auxsp; goto expand_auxsp;
} }
*s++ = i; *s++ = i;
}
t = TailOfTerm(t); t = TailOfTerm(t);
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"atom_chars/2"); Yap_Error(INSTANTIATION_ERROR,t,"atom_chars/2");
@ -957,15 +1058,38 @@ p_atom_chars(void)
Yap_Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2"); Yap_Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2");
return(FALSE); return(FALSE);
} }
is = RepAtom(AtomOfTerm(Head))->StrOfAE; at = AtomOfTerm(Head);
if (IsWideAtom(at)) {
wchar_t *wis = (wchar_t *)RepAtom(at)->StrOfAE;
if (wis[1] != '\0') {
Yap_Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2");
return(FALSE);
}
if (!ws) {
ws = ch_to_wide(String, s);
}
if (ws+1024 == (wchar_t *)AuxSp) {
goto expand_auxsp;
}
*ws++ = wis[0];
} else {
is = RepAtom(at)->StrOfAE;
if (is[1] != '\0') { if (is[1] != '\0') {
Yap_Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2"); Yap_Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2");
return(FALSE); return(FALSE);
} }
if (ws) {
if (ws+1024 == (wchar_t *)AuxSp) {
goto expand_auxsp;
}
*ws++ = is[0];
} else {
if (s+1024 == (char *)AuxSp) { if (s+1024 == (char *)AuxSp) {
goto expand_auxsp; goto expand_auxsp;
} }
*s++ = is[0]; *s++ = is[0];
}
}
t = TailOfTerm(t); t = TailOfTerm(t);
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"atom_chars/2"); Yap_Error(INSTANTIATION_ERROR,t,"atom_chars/2");
@ -976,6 +1100,15 @@ p_atom_chars(void)
} }
} }
} }
if (ws) {
*ws++ = '\0';
while ((at = Yap_LookupWideAtom((wchar_t *)String)) == NIL) {
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
}
} else {
*s++ = '\0'; *s++ = '\0';
while ((at = Yap_LookupAtom(String)) == NIL) { while ((at = Yap_LookupAtom(String)) == NIL) {
if (!Yap_growheap(FALSE, 0, NULL)) { if (!Yap_growheap(FALSE, 0, NULL)) {
@ -983,6 +1116,7 @@ p_atom_chars(void)
return FALSE; return FALSE;
} }
} }
}
return Yap_unify_constant(ARG1, MkAtomTerm(at)); return Yap_unify_constant(ARG1, MkAtomTerm(at));
} }
/* error handling */ /* error handling */
@ -1000,20 +1134,25 @@ p_atom_chars(void)
static Int static Int
p_atom_concat(void) p_atom_concat(void)
{ {
Term t1 = Deref(ARG1); Term t1;
char *cptr = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE, *cpt0; int wide_mode = FALSE;
char *top = (char *)AuxSp;
char *atom_str;
UInt sz; UInt sz;
restart: restart:
cpt0 = cptr; t1 = Deref(ARG1);
/* we need to have a list */ /* we need to have a list */
if (IsVarTerm(t1)) { if (IsVarTerm(t1)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2"); Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
return(FALSE); return FALSE;
} }
if (wide_mode) {
wchar_t *cptr = (wchar_t *)(((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE), *cpt0;
wchar_t *top = (wchar_t *)AuxSp;
char *atom_str;
Atom ahead;
cpt0 = cptr;
while (IsPairTerm(t1)) { while (IsPairTerm(t1)) {
Term thead = HeadOfTerm(t1); Term thead = HeadOfTerm(t1);
if (IsVarTerm(thead)) { if (IsVarTerm(thead)) {
@ -1026,6 +1165,74 @@ p_atom_concat(void)
Yap_Error(TYPE_ERROR_ATOM, ARG1, "atom_concat/2"); Yap_Error(TYPE_ERROR_ATOM, ARG1, "atom_concat/2");
return(FALSE); return(FALSE);
} }
ahead = AtomOfTerm(thead);
atom_str = RepAtom(ahead)->StrOfAE;
if (IsWideAtom(ahead)) {
/* check for overflows */
sz = wcslen((wchar_t *)atom_str);
} else {
sz = strlen(atom_str);
}
if (cptr+sz >= top-1024) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
if (!Yap_growheap(FALSE, sz+1024, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
goto restart;
}
if (IsWideAtom(ahead)) {
memcpy((void *)cptr, (void *)atom_str, sz*sizeof(wchar_t));
cptr += sz;
} else {
int i;
for (i=0; i < sz; i++) {
*cptr++ = *atom_str++;
}
}
t1 = TailOfTerm(t1);
if (IsVarTerm(t1)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
return FALSE;
}
}
if (t1 == TermNil) {
Atom at;
cptr[0] = '\0';
while ((at = Yap_LookupWideAtom(cpt0)) == NIL) {
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
}
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
return Yap_unify(ARG2, MkAtomTerm(at));
}
} else {
char *cptr = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE, *cpt0;
char *top = (char *)AuxSp;
char *atom_str;
cpt0 = cptr;
while (IsPairTerm(t1)) {
Term thead = HeadOfTerm(t1);
if (IsVarTerm(thead)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
return(FALSE);
}
if (!IsAtomTerm(thead)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(TYPE_ERROR_ATOM, ARG1, "atom_concat/2");
return(FALSE);
}
if (IsWideAtom(AtomOfTerm(thead)) && !wide_mode) {
wide_mode = TRUE;
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
goto restart;
}
atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE; atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE;
/* check for overflows */ /* check for overflows */
sz = strlen(atom_str); sz = strlen(atom_str);
@ -1033,7 +1240,7 @@ p_atom_concat(void)
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
if (!Yap_growheap(FALSE, sz+1024, NULL)) { if (!Yap_growheap(FALSE, sz+1024, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE); return FALSE;
} }
goto restart; goto restart;
} }
@ -1043,7 +1250,7 @@ p_atom_concat(void)
if (IsVarTerm(t1)) { if (IsVarTerm(t1)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2"); Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
return(FALSE); return FALSE;
} }
} }
if (t1 == TermNil) { if (t1 == TermNil) {
@ -1059,6 +1266,7 @@ p_atom_concat(void)
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
return Yap_unify(ARG2, MkAtomTerm(at)); return Yap_unify(ARG2, MkAtomTerm(at));
} }
}
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2"); Yap_Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2");
return FALSE; return FALSE;
@ -1067,28 +1275,148 @@ p_atom_concat(void)
static Int static Int
p_atomic_concat(void) p_atomic_concat(void)
{ {
Term t1 = Deref(ARG1); Term t1;
char *cptr = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE, *cpt0; int wide_mode = FALSE;
char *top = (char *)AuxSp; char *base;
char *atom_str;
UInt sz;
restart: restart:
if (cptr+1024 > (char *)AuxSp) { base = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE;
cptr = Yap_ExpandPreAllocCodeSpace(0,NULL); while (base+1024 > (char *)AuxSp) {
if (cptr + 1024 > (char *)AuxSp) { base = Yap_ExpandPreAllocCodeSpace(0,NULL);
if (base + 1024 > (char *)AuxSp) {
/* crash in flames */ /* crash in flames */
Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "allocating temp space in atomic_concat/2"); Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "allocating temp space in atomic_concat/2");
return FALSE; return FALSE;
} }
} }
cpt0 = cptr; t1 = Deref(ARG1);
/* we need to have a list */ /* we need to have a list */
if (IsVarTerm(t1)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
return FALSE;
}
if (wide_mode) {
wchar_t *wcptr = (wchar_t *)base, *wcpt0;
wchar_t *wtop = (wchar_t *)AuxSp;
wcpt0 = wcptr;
while (IsPairTerm(t1)) {
Term thead = HeadOfTerm(t1);
if (IsVarTerm(thead)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
return FALSE;
}
if (!IsAtomicTerm(thead)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(TYPE_ERROR_ATOMIC, ARG1, "atom_concat/2");
return FALSE;
}
if (IsAtomTerm(thead)) {
Atom at = AtomOfTerm(thead);
if (IsWideAtom(at)) {
wchar_t *watom_str = (wchar_t *)RepAtom(AtomOfTerm(thead))->StrOfAE;
UInt sz = wcslen(watom_str);
if (wcptr+sz >= wtop-1024) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
if (!Yap_growheap(FALSE, sz+1024, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
goto restart;
}
memcpy((void *)wcptr, (void *)watom_str, sz*sizeof(wchar_t));
wcptr += sz;
} else {
char *atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE;
/* check for overflows */
UInt sz = strlen(atom_str);
if (wcptr+sz >= wtop-1024) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
if (!Yap_growheap(FALSE, sz+1024, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
goto restart;
}
while ((*wcptr++ = *atom_str++));
wcptr--;
}
} else if (IsIntegerTerm(thead)) {
UInt sz, i;
char *cptr = (char *)wcptr;
#if HAVE_SNPRINTF
sz = snprintf(cptr, (wtop-wcptr)-1024,"%ld", (long int)IntegerOfTerm(thead));
#else
sz = sprintf(cptr,"%ld", (long int)IntegerOfTerm(thead));
#endif
for (i=sz; i>0; i--) {
wcptr[i-1] = cptr[i-1];
}
wcptr += sz;
} else if (IsFloatTerm(thead)) {
char *cptr = (char *)wcptr;
UInt i, sz;
#if HAVE_SNPRINTF
sz = snprintf(cptr,(wtop-wcptr)-1024,"%g", FloatOfTerm(thead));
#else
sz = sprintf(cptr,"%g", FloatOfTerm(thead));
#endif
for (i=sz; i>0; i--) {
wcptr[i-1] = cptr[i-1];
}
wcptr += sz;
#if USE_GMP
} else if (IsBigIntTerm(thead)) {
MP_INT *n = Yap_BigIntOfTerm(thead);
int sz, i;
char *tmp = (char *)wcptr;
if ((sz = mpz_sizeinbase (n, 10)) > (wtop-wcptr)-1024) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
if (!Yap_growheap(FALSE, sz+1024, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
goto restart;
}
mpz_get_str(tmp, 10, n);
for (i=sz; i>0; i--) {
wcptr[i-1] = tmp[i-1];
}
wcptr += sz;
#endif
}
t1 = TailOfTerm(t1);
if (IsVarTerm(t1)) { if (IsVarTerm(t1)) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2"); Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
return(FALSE); return(FALSE);
} }
}
if (t1 == TermNil) {
Atom at;
wcptr[0] = '\0';
while ((at = Yap_LookupWideAtom(wcpt0)) == NIL) {
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
}
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
return Yap_unify(ARG2, MkAtomTerm(at));
}
} else {
char *top = (char *)AuxSp;
char *cpt0 = base;
char *cptr = base;
while (IsPairTerm(t1)) { while (IsPairTerm(t1)) {
Term thead = HeadOfTerm(t1); Term thead = HeadOfTerm(t1);
if (IsVarTerm(thead)) { if (IsVarTerm(thead)) {
@ -1102,6 +1430,14 @@ p_atomic_concat(void)
return(FALSE); return(FALSE);
} }
if (IsAtomTerm(thead)) { if (IsAtomTerm(thead)) {
char *atom_str;
UInt sz;
if (IsWideAtom(AtomOfTerm(thead))) {
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
wide_mode = TRUE;
goto restart;
}
atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE; atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE;
/* check for overflows */ /* check for overflows */
sz = strlen(atom_str); sz = strlen(atom_str);
@ -1166,6 +1502,7 @@ p_atomic_concat(void)
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
return Yap_unify(ARG2, MkAtomTerm(at)); return Yap_unify(ARG2, MkAtomTerm(at));
} }
}
Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_ReleasePreAllocCodeSpace((ADDR)cpt0);
Yap_Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2"); Yap_Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2");
return(FALSE); return(FALSE);
@ -1180,16 +1517,24 @@ p_atom_codes(void)
restart_pred: restart_pred:
if (!IsVarTerm(t1)) { if (!IsVarTerm(t1)) {
Term NewT; Term NewT;
Atom at;
if (!IsAtomTerm(t1)) { if (!IsAtomTerm(t1)) {
Yap_Error(TYPE_ERROR_ATOM, t1, "atom_codes/2"); Yap_Error(TYPE_ERROR_ATOM, t1, "atom_codes/2");
return(FALSE); return(FALSE);
} }
NewT = Yap_StringToList(RepAtom(AtomOfTerm(t1))->StrOfAE); at = AtomOfTerm(t1);
if (IsWideAtom(at)) {
NewT = Yap_WStringToList((wchar_t *)RepAtom(at)->StrOfAE);
} else {
NewT = Yap_StringToList(RepAtom(at)->StrOfAE);
}
return (Yap_unify(NewT, ARG2)); return (Yap_unify(NewT, ARG2));
} else { } else {
/* ARG1 unbound */ /* ARG1 unbound */
Term t = Deref(ARG2); Term t = Deref(ARG2);
char *s; char *s;
wchar_t *ws = NULL;
String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE; String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE;
if (String + 1024 > (char *)AuxSp) { if (String + 1024 > (char *)AuxSp) {
@ -1219,14 +1564,24 @@ p_atom_codes(void)
return(FALSE); return(FALSE);
} }
i = IntOfTerm(Head); i = IntOfTerm(Head);
if (i < 0 || i > 255) { if (i < 0) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_codes/2"); Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_codes/2");
return(FALSE); return(FALSE);
} }
if (i > MAX_ISO_LATIN1 && !ws) {
ws = ch_to_wide(String, s);
}
if (ws) {
if (ws+1024 > (wchar_t *)AuxSp) {
goto expand_auxsp;
}
*ws++ = i;
} else {
if (s+1024 > (char *)AuxSp) { if (s+1024 > (char *)AuxSp) {
goto expand_auxsp; goto expand_auxsp;
} }
*s++ = i; *s++ = i;
}
t = TailOfTerm(t); t = TailOfTerm(t);
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"atom_codes/2"); Yap_Error(INSTANTIATION_ERROR,t,"atom_codes/2");
@ -1236,8 +1591,13 @@ p_atom_codes(void)
return(FALSE); return(FALSE);
} }
} }
if (ws) {
*ws++ = '\0';
return Yap_unify_constant(ARG1, MkAtomTerm(Yap_LookupWideAtom((wchar_t *)String)));
} else {
*s++ = '\0'; *s++ = '\0';
return (Yap_unify_constant(ARG1, MkAtomTerm(Yap_LookupAtom(String)))); return Yap_unify_constant(ARG1, MkAtomTerm(Yap_LookupAtom(String)));
}
} }
/* error handling */ /* error handling */
expand_auxsp: expand_auxsp:
@ -1259,7 +1619,7 @@ p_atom_length(void)
{ {
Term t1 = Deref(ARG1); Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2); Term t2 = Deref(ARG2);
Int len; Atom at;
if (IsVarTerm(t1)) { if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "atom_length/2"); Yap_Error(INSTANTIATION_ERROR, t1, "atom_length/2");
@ -1269,35 +1629,60 @@ p_atom_length(void)
Yap_Error(TYPE_ERROR_ATOM, t1, "atom_length/2"); Yap_Error(TYPE_ERROR_ATOM, t1, "atom_length/2");
return(FALSE); return(FALSE);
} }
at = AtomOfTerm(t1);
if (!IsVarTerm(t2)) { if (!IsVarTerm(t2)) {
if (!IsIntTerm(t2)) { size_t len;
if (!IsIntegerTerm(t2)) {
Yap_Error(TYPE_ERROR_INTEGER, t2, "atom_length/2"); Yap_Error(TYPE_ERROR_INTEGER, t2, "atom_length/2");
return(FALSE); return(FALSE);
} }
if ((len = IntOfTerm(t2)) < 0) { if ((len = IntegerOfTerm(t2)) < 0) {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "atom_length/2"); Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "atom_length/2");
return(FALSE); return(FALSE);
} }
return((Int)strlen(RepAtom(AtomOfTerm(t1))->StrOfAE) == len); if (IsWideAtom(at)) {
return wcslen((wchar_t *)RepAtom(at)->StrOfAE) == len;
} else { } else {
Term tj = MkIntegerTerm(strlen(RepAtom(AtomOfTerm(t1))->StrOfAE)); return(strlen(RepAtom(at)->StrOfAE) == len);
}
} else {
Term tj;
size_t len;
if (IsWideAtom(at)) {
len = wcslen((wchar_t *)RepAtom(at)->StrOfAE);
} else {
len = strlen(RepAtom(at)->StrOfAE);
}
tj = MkIntegerTerm(len);
return Yap_unify_constant(t2,tj); return Yap_unify_constant(t2,tj);
} }
} }
static int
is_wide(wchar_t *s)
{
wchar_t ch;
while ((ch = *s++)) {
if (ch > MAX_ISO_LATIN1)
return TRUE;
}
return FALSE;
}
/* split an atom into two sub-atoms */ /* split an atom into two sub-atoms */
static Int static Int
p_atom_split(void) p_atom_split(void)
{ {
Term t1 = Deref(ARG1); Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2); Term t2 = Deref(ARG2);
Int len; size_t len;
char *s, *s1;
int i; int i;
Term to1, to2; Term to1, to2;
Atom at;
s1 = (char *)H;
if (IsVarTerm(t1)) { if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "$atom_split/4"); Yap_Error(INSTANTIATION_ERROR, t1, "$atom_split/4");
return(FALSE); return(FALSE);
@ -1318,16 +1703,64 @@ p_atom_split(void)
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "$atom_split/4"); Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "$atom_split/4");
return(FALSE); return(FALSE);
} }
s = RepAtom(AtomOfTerm(t1))->StrOfAE; at = AtomOfTerm(t1);
if (len > (Int)strlen(s)) return(FALSE); if (IsWideAtom(at)) {
for (i = 0; i< len; i++) { wchar_t *ws, *ws1 = (wchar_t *)H;
if (s1 > (char *)LCL0-1024) char *s1 = (char *)H;
size_t wlen;
ws = (wchar_t *)RepAtom(at)->StrOfAE;
wlen = wcslen(ws);
if (len > wlen) return FALSE;
if (s1+len > (char *)LCL0-1024)
Yap_Error(OUT_OF_STACK_ERROR,t1,"$atom_split/4"); Yap_Error(OUT_OF_STACK_ERROR,t1,"$atom_split/4");
for (i = 0; i< len; i++) {
if (ws[i] > MAX_ISO_LATIN1) {
break;
}
s1[i] = ws[i];
}
if (ws1[i] > MAX_ISO_LATIN1) {
/* first sequence is wide */
if (ws1+len > (wchar_t *)ASP-1024)
Yap_Error(OUT_OF_STACK_ERROR,t1,"$atom_split/4");
ws = (wchar_t *)RepAtom(at)->StrOfAE;
for (i = 0; i< len; i++) {
ws1[i] = ws[i];
}
ws1[len] = '\0';
to1 = MkAtomTerm(Yap_LookupWideAtom(ws1));
/* we don't know if the rest of the string is wide or not */
if (is_wide(ws+len)) {
to2 = MkAtomTerm(Yap_LookupWideAtom(ws+len));
} else {
char *s2 = (char *)H;
if (s2+(wlen-len) > (char *)ASP-1024)
Yap_Error(OUT_OF_STACK_ERROR,t1,"$atom_split/4");
ws += len;
while ((*s2++ = *ws++));
to2 = MkAtomTerm(Yap_LookupAtom((char *)H));
}
} else {
s1[len] = '\0';
to1 = MkAtomTerm(Yap_LookupAtom(s1));
/* second atom must be wide, if first wasn't */
to2 = MkAtomTerm(Yap_LookupWideAtom(ws+len));
}
} else {
char *s, *s1 = (char *)H;
s = RepAtom(at)->StrOfAE;
if (len > (Int)strlen(s)) return(FALSE);
if (s1+len > (char *)ASP-1024)
Yap_Error(OUT_OF_STACK_ERROR,t1,"$atom_split/4");
for (i = 0; i< len; i++) {
s1[i] = s[i]; s1[i] = s[i];
} }
s1[len] = '\0'; s1[len] = '\0';
to1 = MkAtomTerm(Yap_LookupAtom(s1)); to1 = MkAtomTerm(Yap_LookupAtom(s1));
to2 = MkAtomTerm(Yap_LookupAtom(s+len)); to2 = MkAtomTerm(Yap_LookupAtom(s+len));
}
return(Yap_unify_constant(ARG3,to1) && Yap_unify_constant(ARG4,to2)); return(Yap_unify_constant(ARG3,to1) && Yap_unify_constant(ARG4,to2));
} }
@ -1923,6 +2356,87 @@ init_current_atom(void)
return (cont_current_atom()); return (cont_current_atom());
} }
static Int
cont_current_wide_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 < WideAtomHashTableSize) {
READ_LOCK(WideHashChain[i].AERWLock);
catom = WideHashChain[i].Entry;
READ_UNLOCK(WideHashChain[i].AERWLock);
if (catom != NIL) {
break;
}
i++;
}
if (i == WideAtomHashTableSize) {
cut_fail();
}
}
ap = RepAtom(catom);
if (Yap_unify_constant(ARG1, MkAtomTerm(catom))) {
READ_LOCK(ap->ARWLock);
if (ap->NextOfAE == NIL) {
READ_UNLOCK(ap->ARWLock);
i++;
while (i < WideAtomHashTableSize) {
READ_LOCK(WideHashChain[i].AERWLock);
catom = WideHashChain[i].Entry;
READ_UNLOCK(WideHashChain[i].AERWLock);
if (catom != NIL) {
break;
}
i++;
}
if (i == WideAtomHashTableSize) {
cut_fail();
} else {
EXTRA_CBACK_ARG(1,1) = MkAtomTerm(catom);
}
} else {
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_wide_atom(void)
{ /* current_atom(?Atom) */
Term t1 = Deref(ARG1);
if (!IsVarTerm(t1)) {
if (IsAtomTerm(t1))
cut_succeed();
else
cut_fail();
}
READ_LOCK(WideHashChain[0].AERWLock);
if (WideHashChain[0].Entry != NIL) {
EXTRA_CBACK_ARG(1,1) = MkAtomTerm(WideHashChain[0].Entry);
} else {
EXTRA_CBACK_ARG(1,1) = MkIntTerm(0);
}
READ_UNLOCK(WideHashChain[0].AERWLock);
EXTRA_CBACK_ARG(1,2) = MkIntTerm(0);
return (cont_current_wide_atom());
}
static Int static Int
cont_current_predicate(void) cont_current_predicate(void)
{ {
@ -2562,6 +3076,27 @@ p_statistics_atom_info(void)
catom = ncatom; catom = ncatom;
} }
} }
for (i =0; i < WideAtomHashTableSize; i++) {
Atom catom;
READ_LOCK(WideHashChain[i].AERWLock);
catom = WideHashChain[i].Entry;
if (catom != NIL) {
READ_LOCK(RepAtom(catom)->ARWLock);
}
READ_UNLOCK(WideHashChain[i].AERWLock);
while (catom != NIL) {
Atom ncatom;
count++;
spaceused += sizeof(AtomEntry)+wcslen((wchar_t *)( RepAtom(catom)->StrOfAE));
ncatom = RepAtom(catom)->NextOfAE;
if (ncatom != NIL) {
READ_LOCK(RepAtom(ncatom)->ARWLock);
}
READ_UNLOCK(RepAtom(ncatom)->ARWLock);
catom = ncatom;
}
}
return Yap_unify(ARG1, MkIntegerTerm(count)) && return Yap_unify(ARG1, MkIntegerTerm(count)) &&
Yap_unify(ARG2, MkIntegerTerm(spaceused)); Yap_unify(ARG2, MkIntegerTerm(spaceused));
} }
@ -3023,6 +3558,9 @@ Yap_InitBackCPreds(void)
{ {
Yap_InitCPredBack("$current_atom", 1, 2, init_current_atom, cont_current_atom, Yap_InitCPredBack("$current_atom", 1, 2, init_current_atom, cont_current_atom,
SafePredFlag|SyncPredFlag|HiddenPredFlag); SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPredBack("$current_wide_atom", 1, 2, init_current_wide_atom,
cont_current_wide_atom,
SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPredBack("$current_predicate", 3, 1, init_current_predicate, cont_current_predicate, Yap_InitCPredBack("$current_predicate", 3, 1, init_current_predicate, cont_current_predicate,
SafePredFlag|SyncPredFlag|HiddenPredFlag); SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPredBack("$current_predicate_for_atom", 3, 1, init_current_predicate_for_atom, cont_current_predicate_for_atom, Yap_InitCPredBack("$current_predicate_for_atom", 3, 1, init_current_predicate_for_atom, cont_current_predicate_for_atom,

2
C/userpreds.c
View File

@ -594,7 +594,7 @@ p_grab_tokens()
Term *p = ASP - 20, *p0, t; Term *p = ASP - 20, *p0, t;
Atom IdAtom, VarAtom; Atom IdAtom, VarAtom;
Functor IdFunctor, VarFunctor; Functor IdFunctor, VarFunctor;
char ch, IdChars[255], *chp; char ch, IdChars[256], *chp;
IdAtom = Yap_LookupAtom("id"); IdAtom = Yap_LookupAtom("id");
IdFunctor = Yap_MkFunctor(IdAtom, 1); IdFunctor = Yap_MkFunctor(IdAtom, 1);

254
C/write.c
View File

@ -42,10 +42,10 @@ typedef enum {
static wtype lastw; static wtype lastw;
typedef int (*wrf) (int, int); typedef wchar_t (*wrf) (int, wchar_t);
typedef struct write_globs { typedef struct write_globs {
wrf writech; wrf writewch;
int Quote_illegal, Ignore_ops, Handle_vars, Use_portray; int Quote_illegal, Ignore_ops, Handle_vars, Use_portray;
int keep_terms; int keep_terms;
UInt MaxDepth, MaxList, MaxArgs; UInt MaxDepth, MaxList, MaxArgs;
@ -65,16 +65,16 @@ STATIC_PROTO(void writeTerm, (Term, int, int, int, struct write_globs *));
#define wrputc(X,WF) ((*WF)(Yap_c_output_stream,X)) /* writes a character */ #define wrputc(X,WF) ((*WF)(Yap_c_output_stream,X)) /* writes a character */
static void static void
wrputn(Int n, wrf writech) /* writes an integer */ wrputn(Int n, wrf writewch) /* writes an integer */
{ {
char s[256], *s1=s; /* that should be enough for most integers */ char s[256], *s1=s; /* that should be enough for most integers */
if (n < 0) { if (n < 0) {
if (lastw == symbol) if (lastw == symbol)
wrputc(' ', writech); wrputc(' ', writewch);
} else { } else {
if (lastw == alphanum) if (lastw == alphanum)
wrputc(' ', writech); wrputc(' ', writewch);
} }
#if HAVE_SNPRINTF #if HAVE_SNPRINTF
#if SHORT_INTS #if SHORT_INTS
@ -90,29 +90,36 @@ wrputn(Int n, wrf writech) /* writes an integer */
#endif #endif
#endif #endif
while (*s1) while (*s1)
wrputc(*s1++, writech); wrputc(*s1++, writewch);
lastw = alphanum; lastw = alphanum;
} }
static void static void
wrputs(char *s, wrf writech) /* writes a string */ wrputs(char *s, wrf writewch) /* writes a string */
{ {
while (*s) while (*s)
wrputc(*s++, writech); wrputc(*s++, writewch);
} }
static void static void
wrputf(Float f, wrf writech) /* writes a float */ wrputws(wchar_t *s, wrf writewch) /* writes a string */
{
while (*s)
wrputc(*s++, writewch);
}
static void
wrputf(Float f, wrf writewch) /* writes a float */
{ {
char s[255], *pt = s, ch; char s[256], *pt = s, ch;
if (f < 0) { if (f < 0) {
if (lastw == symbol) if (lastw == symbol)
wrputc(' ', writech); wrputc(' ', writewch);
} else { } else {
if (lastw == alphanum) if (lastw == alphanum)
wrputc(' ', writech); wrputc(' ', writewch);
} }
lastw = alphanum; lastw = alphanum;
// sprintf(s, "%.15g", f); // sprintf(s, "%.15g", f);
@ -120,12 +127,12 @@ wrputf(Float f, wrf writech) /* writes a float */
while (*pt == ' ') while (*pt == ' ')
pt++; pt++;
if (*pt == 'i' || *pt == 'n') /* inf or nan */ { if (*pt == 'i' || *pt == 'n') /* inf or nan */ {
wrputc('(', writech); wrputc('(', writewch);
wrputc('+', writech); wrputc('+', writewch);
wrputs(pt, writech); wrputs(pt, writewch);
wrputc(')', writech); wrputc(')', writewch);
} else { } else {
wrputs(pt, writech); wrputs(pt, writewch);
} }
if (*pt == '-') pt++; if (*pt == '-') pt++;
while ((ch = *pt) != '\0') { while ((ch = *pt) != '\0') {
@ -133,16 +140,16 @@ wrputf(Float f, wrf writech) /* writes a float */
return; return;
pt++; pt++;
} }
wrputs(".0", writech); wrputs(".0", writewch);
} }
static void static void
wrputref(CODEADDR ref, int Quote_illegal, wrf writech) /* writes a data base reference */ wrputref(CODEADDR ref, int Quote_illegal, wrf writewch) /* writes a data base reference */
{ {
char s[256]; char s[256];
putAtom(AtomDBRef, Quote_illegal, writech); putAtom(AtomDBRef, Quote_illegal, writewch);
#if SHORT_INTS #if SHORT_INTS
sprintf(s, "(0x%p,0)", ref); sprintf(s, "(0x%p,0)", ref);
#elif __linux__ #elif __linux__
@ -150,7 +157,7 @@ wrputref(CODEADDR ref, int Quote_illegal, wrf writech) /* writes a data base r
#else #else
sprintf(s, "(0x%p,0)", ref); sprintf(s, "(0x%p,0)", ref);
#endif #endif
wrputs(s, writech); wrputs(s, writewch);
lastw = alphanum; lastw = alphanum;
} }
@ -211,7 +218,7 @@ AtomIsSymbols(char *s) /* Is this atom just formed by symbols ? */
} }
static void static void
putAtom(Atom atom, int Quote_illegal, wrf writech) /* writes an atom */ putAtom(Atom atom, int Quote_illegal, wrf writewch) /* writes an atom */
{ {
char *s = RepAtom(atom)->StrOfAE; char *s = RepAtom(atom)->StrOfAE;
@ -222,26 +229,45 @@ putAtom(Atom atom, int Quote_illegal, wrf writech) /* writes an atom */
if (Yap_GetValue(Yap_LookupAtom("crypt_atoms")) != TermNil && Yap_GetAProp(atom, OpProperty) == NIL) { if (Yap_GetValue(Yap_LookupAtom("crypt_atoms")) != TermNil && Yap_GetAProp(atom, OpProperty) == NIL) {
char s[16]; char s[16];
sprintf(s,"x%x", (CELL)s); sprintf(s,"x%x", (CELL)s);
wrputs(s, writech); wrputs(s, writewch);
return; return;
} }
#endif #endif
if (IsWideAtom(atom)) {
wchar_t *ws = (wchar_t *)s;
if (Quote_illegal) {
wrputc('\'', writewch);
while (*ws) {
wchar_t ch = *ws++;
wrputc(ch, writewch);
if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES)
wrputc('\\', writewch); /* be careful about backslashes */
else if (ch == '\'')
wrputc('\'', writewch); /* be careful about quotes */
}
wrputc('\'', writewch);
} else {
wrputws(ws, writewch);
}
return;
}
if (lastw == atom_or_symbol && atom_or_symbol != separator /* solo */) if (lastw == atom_or_symbol && atom_or_symbol != separator /* solo */)
wrputc(' ', writech); wrputc(' ', writewch);
lastw = atom_or_symbol; lastw = atom_or_symbol;
if (!legalAtom(s) && Quote_illegal) { if (!legalAtom(s) && Quote_illegal) {
wrputc('\'', writech); wrputc('\'', writewch);
while (*s) { while (*s) {
int ch = *s++; int ch = *s++;
wrputc(ch, writech); wrputc(ch, writewch);
if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES)
wrputc('\\', writech); /* be careful about backslashes */ wrputc('\\', writewch); /* be careful about backslashes */
else if (ch == '\'') else if (ch == '\'')
wrputc('\'', writech); /* be careful about quotes */ wrputc('\'', writewch); /* be careful about quotes */
} }
wrputc('\'', writech); wrputc('\'', writewch);
} else { } else {
wrputs(s, writech); wrputs(s, writewch);
} }
} }
@ -258,7 +284,7 @@ IsStringTerm(Term string) /* checks whether this is a string */
if (IsVarTerm(hd)) return(FALSE); if (IsVarTerm(hd)) return(FALSE);
if (!IsIntTerm(hd)) return(FALSE); if (!IsIntTerm(hd)) return(FALSE);
ch = IntOfTerm(HeadOfTerm(string)); ch = IntOfTerm(HeadOfTerm(string));
if ((ch < ' ' || ch > 255) && ch != '\n' && ch != '\t') if ((ch < ' ' || ch > MAX_ISO_LATIN1) && ch != '\n' && ch != '\t')
return(FALSE); return(FALSE);
string = TailOfTerm(string); string = TailOfTerm(string);
if (IsVarTerm(string)) return(FALSE); if (IsVarTerm(string)) return(FALSE);
@ -267,30 +293,30 @@ IsStringTerm(Term string) /* checks whether this is a string */
} }
static void static void
putString(Term string, wrf writech) /* writes a string */ putString(Term string, wrf writewch) /* writes a string */
{ {
wrputc('"', writech); wrputc('"', writewch);
while (string != TermNil) { while (string != TermNil) {
int ch = IntOfTerm(HeadOfTerm(string)); int ch = IntOfTerm(HeadOfTerm(string));
wrputc(ch, writech); wrputc(ch, writewch);
if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES)
wrputc('\\', writech); /* be careful about backslashes */ wrputc('\\', writewch); /* be careful about backslashes */
else if (ch == '"') else if (ch == '"')
wrputc('"', writech); /* be careful about quotes */ wrputc('"', writewch); /* be careful about quotes */
string = TailOfTerm(string); string = TailOfTerm(string);
} }
wrputc('"', writech); wrputc('"', writewch);
lastw = alphanum; lastw = alphanum;
} }
static void static void
putUnquotedString(Term string, wrf writech) /* writes a string */ putUnquotedString(Term string, wrf writewch) /* writes a string */
{ {
while (string != TermNil) { while (string != TermNil) {
int ch = IntOfTerm(HeadOfTerm(string)); int ch = IntOfTerm(HeadOfTerm(string));
wrputc(ch, writech); wrputc(ch, writewch);
string = TailOfTerm(string); string = TailOfTerm(string);
} }
lastw = alphanum; lastw = alphanum;
@ -301,9 +327,9 @@ static void
write_var(CELL *t, struct write_globs *wglb) write_var(CELL *t, struct write_globs *wglb)
{ {
if (lastw == alphanum) { if (lastw == alphanum) {
wrputc(' ', wglb->writech); wrputc(' ', wglb->writewch);
} }
wrputc('_', wglb->writech); wrputc('_', wglb->writewch);
/* make sure we don't get no creepy spaces where they shouldn't be */ /* make sure we don't get no creepy spaces where they shouldn't be */
lastw = separator; lastw = separator;
if (CellPtr(t) < H0) { if (CellPtr(t) < H0) {
@ -318,31 +344,31 @@ write_var(CELL *t, struct write_globs *wglb)
long sl = 0; long sl = 0;
Term l = attv->Atts; Term l = attv->Atts;
wrputs("$AT(",wglb->writech); wrputs("$AT(",wglb->writewch);
write_var(t, wglb); write_var(t, wglb);
wrputc(',', wglb->writech); wrputc(',', wglb->writewch);
if (wglb->keep_terms) { if (wglb->keep_terms) {
/* garbage collection may be called */ /* garbage collection may be called */
sl = Yap_InitSlot((CELL)attv); sl = Yap_InitSlot((CELL)attv);
} }
writeTerm((Term)&(attv->Value), 999, 1, FALSE, wglb); writeTerm((Term)&(attv->Value), 999, 1, FALSE, wglb);
wrputc(',', wglb->writech); wrputc(',', wglb->writewch);
writeTerm(l, 999, 1, FALSE, wglb); writeTerm(l, 999, 1, FALSE, wglb);
if (wglb->keep_terms) { if (wglb->keep_terms) {
attv = (attvar_record *)Yap_GetFromSlot(sl); attv = (attvar_record *)Yap_GetFromSlot(sl);
Yap_RecoverSlots(1); Yap_RecoverSlots(1);
} }
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
} }
Yap_Portray_delays = TRUE; Yap_Portray_delays = TRUE;
return; return;
} }
#endif #endif
wrputc('D', wglb->writech); wrputc('D', wglb->writewch);
wrputn((Int) ((attvar_record *)H0-(attvar_record *)t),wglb->writech); wrputn((Int) ((attvar_record *)H0-(attvar_record *)t),wglb->writewch);
#endif #endif
} else { } else {
wrputn(((Int) (t- H0)),wglb->writech); wrputn(((Int) (t- H0)),wglb->writewch);
} }
} }
@ -353,7 +379,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
{ {
if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) { if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) {
putAtom(Yap_LookupAtom("..."), wglb->Quote_illegal, wglb->writech); putAtom(Yap_LookupAtom("..."), wglb->Quote_illegal, wglb->writewch);
return; return;
} }
if (EX != 0) if (EX != 0)
@ -362,9 +388,9 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
write_var((CELL *)t, wglb); write_var((CELL *)t, wglb);
} else if (IsIntTerm(t)) { } else if (IsIntTerm(t)) {
wrputn((Int) IntOfTerm(t),wglb->writech); wrputn((Int) IntOfTerm(t),wglb->writewch);
} else if (IsAtomTerm(t)) { } else if (IsAtomTerm(t)) {
putAtom(AtomOfTerm(t), wglb->Quote_illegal, wglb->writech); putAtom(AtomOfTerm(t), wglb->Quote_illegal, wglb->writewch);
} else if (IsPairTerm(t)) { } else if (IsPairTerm(t)) {
int eldepth = 1; int eldepth = 1;
Term ti; Term ti;
@ -386,17 +412,17 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
return; return;
} }
if (yap_flags[WRITE_QUOTED_STRING_FLAG] && IsStringTerm(t)) { if (yap_flags[WRITE_QUOTED_STRING_FLAG] && IsStringTerm(t)) {
putString(t, wglb->writech); putString(t, wglb->writewch);
} else { } else {
wrputc('[', wglb->writech); wrputc('[', wglb->writewch);
lastw = separator; lastw = separator;
while (1) { while (1) {
int new_depth = depth + 1; int new_depth = depth + 1;
long sl= 0; long sl= 0;
if (wglb->MaxList && eldepth > wglb->MaxList) { if (wglb->MaxList && eldepth > wglb->MaxList) {
putAtom(Yap_LookupAtom("..."), wglb->Quote_illegal, wglb->writech); putAtom(Yap_LookupAtom("..."), wglb->Quote_illegal, wglb->writewch);
wrputc(']', wglb->writech); wrputc(']', wglb->writewch);
lastw = separator; lastw = separator;
return; return;
} else { } else {
@ -417,15 +443,15 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
if (!IsPairTerm(ti)) if (!IsPairTerm(ti))
break; break;
t = ti; t = ti;
wrputc(',', wglb->writech); wrputc(',', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (ti != MkAtomTerm(AtomNil)) { if (ti != MkAtomTerm(AtomNil)) {
wrputc('|', wglb->writech); wrputc('|', wglb->writewch);
lastw = separator; lastw = separator;
writeTerm(TailOfTermCell(t), 999, depth + 1, FALSE, wglb); writeTerm(TailOfTermCell(t), 999, depth + 1, FALSE, wglb);
} }
wrputc(']', wglb->writech); wrputc(']', wglb->writewch);
lastw = separator; lastw = separator;
} }
} else { /* compound term */ } else { /* compound term */
@ -438,13 +464,13 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
if (IsExtensionFunctor(functor)) { if (IsExtensionFunctor(functor)) {
switch((CELL)functor) { switch((CELL)functor) {
case (CELL)FunctorDouble: case (CELL)FunctorDouble:
wrputf(FloatOfTerm(t),wglb->writech); wrputf(FloatOfTerm(t),wglb->writewch);
return; return;
case (CELL)FunctorDBRef: case (CELL)FunctorDBRef:
wrputref(RefOfTerm(t), wglb->Quote_illegal, wglb->writech); wrputref(RefOfTerm(t), wglb->Quote_illegal, wglb->writewch);
return; return;
case (CELL)FunctorLongInt: case (CELL)FunctorLongInt:
wrputn(LongIntOfTerm(t),wglb->writech); wrputn(LongIntOfTerm(t),wglb->writewch);
return; return;
#ifdef USE_GMP #ifdef USE_GMP
case (CELL)FunctorBigInt: case (CELL)FunctorBigInt:
@ -461,13 +487,13 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
return; return;
if (mpz_sgn(big) < 0) { if (mpz_sgn(big) < 0) {
if (lastw == symbol) if (lastw == symbol)
wrputc(' ', wglb->writech); wrputc(' ', wglb->writewch);
} else { } else {
if (lastw == alphanum) if (lastw == alphanum)
wrputc(' ', wglb->writech); wrputc(' ', wglb->writewch);
} }
mpz_get_str(s, 10, big); mpz_get_str(s, 10, big);
wrputs(s,wglb->writech); wrputs(s,wglb->writewch);
} }
return; return;
#endif #endif
@ -480,14 +506,14 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
if (Arity == SFArity) { if (Arity == SFArity) {
int argno = 1; int argno = 1;
CELL *p = ArgsOfSFTerm(t); CELL *p = ArgsOfSFTerm(t);
putAtom(atom, wglb->Quote_illegal, wglb->writech); putAtom(atom, wglb->Quote_illegal, wglb->writewch);
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
while (*p) { while (*p) {
long sl = 0; long sl = 0;
while (argno < *p) { while (argno < *p) {
wrputc('_', wglb->writech), wrputc(',', wglb->writech); wrputc('_', wglb->writewch), wrputc(',', wglb->writewch);
++argno; ++argno;
} }
*p++; *p++;
@ -504,10 +530,10 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
Yap_RecoverSlots(1); Yap_RecoverSlots(1);
} }
if (*p) if (*p)
wrputc(',', wglb->writech); wrputc(',', wglb->writewch);
argno++; argno++;
} }
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
return; return;
} }
@ -547,22 +573,22 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
if (op > p) { if (op > p) {
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */ /* avoid stuff such as \+ (a,b) being written as \+(a,b) */
if (lastw != separator && !rinfixarg) if (lastw != separator && !rinfixarg)
wrputc(' ', wglb->writech); wrputc(' ', wglb->writewch);
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
} }
putAtom(atom, wglb->Quote_illegal, wglb->writech); putAtom(atom, wglb->Quote_illegal, wglb->writewch);
if (bracket_right) { if (bracket_right) {
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
} }
writeTerm(ArgOfTermCell(1,t), rp, depth + 1, FALSE, wglb); writeTerm(ArgOfTermCell(1,t), rp, depth + 1, FALSE, wglb);
if (bracket_right) { if (bracket_right) {
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (op > p) { if (op > p) {
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
} else if (!wglb->Ignore_ops && } else if (!wglb->Ignore_ops &&
@ -575,12 +601,12 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
if (op > p) { if (op > p) {
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */ /* avoid stuff such as \+ (a,b) being written as \+(a,b) */
if (lastw != separator && !rinfixarg) if (lastw != separator && !rinfixarg)
wrputc(' ', wglb->writech); wrputc(' ', wglb->writewch);
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (bracket_left) { if (bracket_left) {
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (wglb->keep_terms) { if (wglb->keep_terms) {
@ -594,12 +620,12 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
Yap_RecoverSlots(1); Yap_RecoverSlots(1);
} }
if (bracket_left) { if (bracket_left) {
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
putAtom(atom, wglb->Quote_illegal, wglb->writech); putAtom(atom, wglb->Quote_illegal, wglb->writewch);
if (op > p) { if (op > p) {
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
} else if (!wglb->Ignore_ops && } else if (!wglb->Ignore_ops &&
@ -618,12 +644,12 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
if (op > p) { if (op > p) {
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */ /* avoid stuff such as \+ (a,b) being written as \+(a,b) */
if (lastw != separator && !rinfixarg) if (lastw != separator && !rinfixarg)
wrputc(' ', wglb->writech); wrputc(' ', wglb->writewch);
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (bracket_left) { if (bracket_left) {
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (wglb->keep_terms) { if (wglb->keep_terms) {
@ -637,57 +663,57 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
Yap_RecoverSlots(1); Yap_RecoverSlots(1);
} }
if (bracket_left) { if (bracket_left) {
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
/* avoid quoting commas */ /* avoid quoting commas */
if (strcmp(RepAtom(atom)->StrOfAE,",")) if (strcmp(RepAtom(atom)->StrOfAE,","))
putAtom(atom, wglb->Quote_illegal, wglb->writech); putAtom(atom, wglb->Quote_illegal, wglb->writewch);
else { else {
wrputc(',', wglb->writech); wrputc(',', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (bracket_right) { if (bracket_right) {
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
lastw = separator; lastw = separator;
} }
writeTerm(ArgOfTermCell(2, t), rp, depth + 1, TRUE, wglb); writeTerm(ArgOfTermCell(2, t), rp, depth + 1, TRUE, wglb);
if (bracket_right) { if (bracket_right) {
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
if (op > p) { if (op > p) {
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
} else if (wglb->Handle_vars && functor == FunctorVar) { } else if (wglb->Handle_vars && functor == FunctorVar) {
Term ti = ArgOfTerm(1, t); Term ti = ArgOfTerm(1, t);
if (lastw == alphanum) { if (lastw == alphanum) {
wrputc(' ', wglb->writech); wrputc(' ', wglb->writewch);
} }
if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsStringTerm(ti))) { if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsStringTerm(ti))) {
if (IsIntTerm(ti)) { if (IsIntTerm(ti)) {
Int k = IntOfTerm(ti); Int k = IntOfTerm(ti);
if (k == -1) { if (k == -1) {
wrputc('_', wglb->writech); wrputc('_', wglb->writewch);
lastw = alphanum; lastw = alphanum;
return; return;
} else { } else {
wrputc((k % 26) + 'A', wglb->writech); wrputc((k % 26) + 'A', wglb->writewch);
if (k >= 26) { if (k >= 26) {
/* make sure we don't get confused about our context */ /* make sure we don't get confused about our context */
lastw = separator; lastw = separator;
wrputn( k / 26 ,wglb->writech); wrputn( k / 26 ,wglb->writewch);
} else } else
lastw = alphanum; lastw = alphanum;
} }
} else { } else {
putUnquotedString(ti, wglb->writech); putUnquotedString(ti, wglb->writewch);
} }
} else { } else {
long sl = 0; long sl = 0;
wrputs("'$VAR'(",wglb->writech); wrputs("'$VAR'(",wglb->writewch);
lastw = separator; lastw = separator;
if (wglb->keep_terms) { if (wglb->keep_terms) {
/* garbage collection may be called */ /* garbage collection may be called */
@ -699,25 +725,25 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
t = Yap_GetFromSlot(sl); t = Yap_GetFromSlot(sl);
Yap_RecoverSlots(1); Yap_RecoverSlots(1);
} }
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
} else if (functor == FunctorBraces) { } else if (functor == FunctorBraces) {
wrputc('{', wglb->writech); wrputc('{', wglb->writewch);
lastw = separator; lastw = separator;
writeTerm(ArgOfTermCell(1, t), 1200, depth + 1, FALSE, wglb); writeTerm(ArgOfTermCell(1, t), 1200, depth + 1, FALSE, wglb);
wrputc('}', wglb->writech); wrputc('}', wglb->writewch);
lastw = separator; lastw = separator;
} else if (atom == AtomArray) { } else if (atom == AtomArray) {
long sl = 0; long sl = 0;
wrputc('{', wglb->writech); wrputc('{', wglb->writewch);
lastw = separator; lastw = separator;
for (op = 1; op <= Arity; ++op) { for (op = 1; op <= Arity; ++op) {
if (op == wglb->MaxArgs) { if (op == wglb->MaxArgs) {
wrputc('.', wglb->writech); wrputc('.', wglb->writewch);
wrputc('.', wglb->writech); wrputc('.', wglb->writewch);
wrputc('.', wglb->writech); wrputc('.', wglb->writewch);
break; break;
} }
if (wglb->keep_terms) { if (wglb->keep_terms) {
@ -731,23 +757,23 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
Yap_RecoverSlots(1); Yap_RecoverSlots(1);
} }
if (op != Arity) { if (op != Arity) {
wrputc(',', wglb->writech); wrputc(',', wglb->writewch);
lastw = separator; lastw = separator;
} }
} }
wrputc('}', wglb->writech); wrputc('}', wglb->writewch);
lastw = separator; lastw = separator;
} else { } else {
putAtom(atom, wglb->Quote_illegal, wglb->writech); putAtom(atom, wglb->Quote_illegal, wglb->writewch);
lastw = separator; lastw = separator;
wrputc('(', wglb->writech); wrputc('(', wglb->writewch);
for (op = 1; op <= Arity; ++op) { for (op = 1; op <= Arity; ++op) {
long sl = 0; long sl = 0;
if (op == wglb->MaxArgs) { if (op == wglb->MaxArgs) {
wrputc('.', wglb->writech); wrputc('.', wglb->writewch);
wrputc('.', wglb->writech); wrputc('.', wglb->writewch);
wrputc('.', wglb->writech); wrputc('.', wglb->writewch);
break; break;
} }
if (wglb->keep_terms) { if (wglb->keep_terms) {
@ -761,25 +787,25 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
Yap_RecoverSlots(1); Yap_RecoverSlots(1);
} }
if (op != Arity) { if (op != Arity) {
wrputc(',', wglb->writech); wrputc(',', wglb->writewch);
lastw = separator; lastw = separator;
} }
} }
wrputc(')', wglb->writech); wrputc(')', wglb->writewch);
lastw = separator; lastw = separator;
} }
} }
} }
void void
Yap_plwrite(Term t, int (*mywrite) (int, int), int flags) Yap_plwrite(Term t, wchar_t (*mywrite) (int, wchar_t), int flags)
/* term to be written */ /* term to be written */
/* consumer */ /* consumer */
/* write options */ /* write options */
{ {
struct write_globs wglb; struct write_globs wglb;
wglb.writech = mywrite; wglb.writewch = mywrite;
lastw = separator; lastw = separator;
wglb.Quote_illegal = flags & Quote_illegal_f; wglb.Quote_illegal = flags & Quote_illegal_f;
wglb.Handle_vars = flags & Handle_vars_f; wglb.Handle_vars = flags & Handle_vars_f;

8
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h * * File: Heap.h *
* mods: * * mods: *
* comments: Heap Init Structure * * comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.108 2006-11-06 18:35:05 vsc Exp $ * * version: $Id: Heap.h,v 1.109 2006-11-27 17:42:03 vsc Exp $ *
*************************************************************************/ *************************************************************************/
/* information that can be stored in Code Space */ /* information that can be stored in Code Space */
@ -546,6 +546,9 @@ typedef struct various_codes {
#endif #endif
UInt n_of_atoms; UInt n_of_atoms;
UInt atom_hash_table_size; UInt atom_hash_table_size;
UInt wide_atom_hash_table_size;
UInt n_of_wide_atoms;
AtomHashEntry *wide_hash_chain;
AtomHashEntry *hash_chain; AtomHashEntry *hash_chain;
} all_heap_codes; } all_heap_codes;
@ -635,6 +638,9 @@ struct various_codes *Yap_heap_regs;
#define NOfAtoms Yap_heap_regs->n_of_atoms #define NOfAtoms Yap_heap_regs->n_of_atoms
#define AtomHashTableSize Yap_heap_regs->atom_hash_table_size #define AtomHashTableSize Yap_heap_regs->atom_hash_table_size
#define HashChain Yap_heap_regs->hash_chain #define HashChain Yap_heap_regs->hash_chain
#define NOfWideAtoms Yap_heap_regs->n_of_wide_atoms
#define WideAtomHashTableSize Yap_heap_regs->wide_atom_hash_table_size
#define WideHashChain Yap_heap_regs->wide_hash_chain
#define INT_KEYS_SIZE Yap_heap_regs->int_keys_size #define INT_KEYS_SIZE Yap_heap_regs->int_keys_size
#define INT_KEYS_TIMESTAMP Yap_heap_regs->int_keys_timestamp #define INT_KEYS_TIMESTAMP Yap_heap_regs->int_keys_timestamp
#define INT_KEYS Yap_heap_regs->IntKeys #define INT_KEYS Yap_heap_regs->IntKeys

3
H/Yap.h
View File

@ -10,7 +10,7 @@
* File: Yap.h.m4 * * File: Yap.h.m4 *
* mods: * * mods: *
* comments: main header file for YAP * * comments: main header file for YAP *
* version: $Id: Yap.h,v 1.16 2006-05-22 16:03:34 tiagosoares Exp $ * * version: $Id: Yap.h,v 1.17 2006-11-27 17:42:03 vsc Exp $ *
*************************************************************************/ *************************************************************************/
#include "config.h" #include "config.h"
@ -1102,6 +1102,7 @@ TailOfTermCell (Term t)
/*************** variables concerned with atoms table *******************/ /*************** variables concerned with atoms table *******************/
#define MaxHash 1001 #define MaxHash 1001
#define MaxWideHash (MaxHash/10+1)
#define FAIL_RESTORE 0 #define FAIL_RESTORE 0
#define DO_EVERYTHING 1 #define DO_EVERYTHING 1

74
H/Yatom.h
View File

@ -189,6 +189,7 @@ IsFunctorProperty (int flags)
ff df sparse functor ff df sparse functor
ff ex arithmetic property ff ex arithmetic property
ff f7 array ff f7 array
ff f8 wide atom
ff fa module property ff fa module property
ff fb blackboard property ff fb blackboard property
ff fc value property ff fc value property
@ -267,6 +268,79 @@ IsGlobalProperty (int flags)
} }
/* Wide Atom property */
typedef struct
{
Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */
UInt SizeOfAtom; /* index in module table */
} WideAtomEntry;
#if USE_OFFSETS_IN_PROPS
inline EXTERN WideAtomEntry *RepWideAtomProp (Prop p);
inline EXTERN WideAtomEntry *
RepWideAtomProp (Prop p)
{
return (WideAtomEntry *) (AtomBase + Unsigned (p));
}
inline EXTERN Prop AbsWideAtomProp (WideAtomEntry * p);
inline EXTERN Prop
AbsWideAtomProp (WideAtomEntry * p)
{
return (Prop) (Addr (p) - AtomBase);
}
#else
inline EXTERN WideAtomEntry *RepWideAtomProp (Prop p);
inline EXTERN WideAtomEntry *
RepWideAtomProp (Prop p)
{
return (WideAtomEntry *) (p);
}
inline EXTERN Prop AbsWideAtomProp (WideAtomEntry * p);
inline EXTERN Prop
AbsWideAtomProp (WideAtomEntry * p)
{
return (Prop) (p);
}
#endif
#define WideAtomProperty ((PropFlags)0xfff8)
inline EXTERN PropFlags IsWideAtomProperty (int);
inline EXTERN PropFlags
IsWideAtomProperty (int flags)
{
return (PropFlags) ((flags == WideAtomProperty));
}
inline EXTERN int IsWideAtom (Atom);
inline EXTERN int
IsWideAtom (Atom at)
{
return RepAtom(at)->PropsOfAE &&
IsWideAtomProperty(RepWideAtomProp(RepAtom(at)->PropsOfAE)->KindOfPE);
}
/* Module property */ /* Module property */
typedef struct typedef struct
{ {

12
H/iopreds.h
View File

@ -29,6 +29,8 @@ static char SccsId[] = "%W% %G%";
#endif #endif
#include <wchar.h>
#if HAVE_LIBREADLINE #if HAVE_LIBREADLINE
#if _MSC_VER || defined(__MINGW32__) #if _MSC_VER || defined(__MINGW32__)
@ -76,7 +78,7 @@ typedef struct stream_desc
} u; } u;
Int charcount, linecount, linepos; Int charcount, linecount, linepos;
Int status; Int status;
Int och; wchar_t och;
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
lockvar streamlock; /* protect stream access */ lockvar streamlock; /* protect stream access */
#endif #endif
@ -85,7 +87,12 @@ typedef struct stream_desc
GetsFunc stream_gets; /* function the stream uses for reading a sequence of characters */ GetsFunc stream_gets; /* function the stream uses for reading a sequence of characters */
/* function the stream uses for parser. It may be different if the ISO /* function the stream uses for parser. It may be different if the ISO
character conversion is on */ character conversion is on */
int (* stream_getc_for_read)(int); wchar_t (* stream_wgetc_for_read)(int);
wchar_t (* stream_wgetc)(int);
wchar_t (* stream_wputc)(int,wchar_t);
encoding_t encoding;
int use_bom;
mbstate_t mbstate;
} }
StreamDesc; StreamDesc;
@ -115,6 +122,7 @@ StreamDesc;
#define InMemory_Stream_f 0x020000 #define InMemory_Stream_f 0x020000
#define Pipe_Stream_f 0x040000 #define Pipe_Stream_f 0x040000
#define Popen_Stream_f 0x080000 #define Popen_Stream_f 0x080000
#define User_Stream_f 0x100000
#define StdInStream 0 #define StdInStream 0
#define StdOutStream 1 #define StdOutStream 1

15
H/rclause.h
View File

@ -12,8 +12,11 @@
* File: rclause.h * * File: rclause.h *
* comments: walk through a clause * * comments: walk through a clause *
* * * *
* Last rev: $Date: 2006-10-10 14:08:17 $,$Author: vsc $ * * Last rev: $Date: 2006-11-27 17:42:03 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.17 2006/10/10 14:08:17 vsc
* small fixes on threaded implementation.
*
* Revision 1.16 2006/09/20 20:03:51 vsc * Revision 1.16 2006/09/20 20:03:51 vsc
* improve indexing on floats * improve indexing on floats
* fix sending large lists to DB * fix sending large lists to DB
@ -170,15 +173,19 @@ restore_opcodes(yamop *pc)
break; break;
case _try_logical: case _try_logical:
case _retry_logical: case _retry_logical:
case _trust_logical:
case _count_retry_logical: case _count_retry_logical:
case _count_trust_logical:
case _profiled_retry_logical: case _profiled_retry_logical:
case _profiled_trust_logical:
pc->u.lld.n = PtoOpAdjust(pc->u.lld.n); pc->u.lld.n = PtoOpAdjust(pc->u.lld.n);
pc->u.lld.d = PtoLUClauseAdjust(pc->u.lld.d); pc->u.lld.d = PtoLUClauseAdjust(pc->u.lld.d);
pc = pc->u.lld.n; pc = pc->u.lld.n;
break; break;
case _trust_logical:
case _count_trust_logical:
case _profiled_trust_logical:
pc->u.lld.n = PtoOpAdjust(pc->u.lld.n);
pc->u.lld.d = PtoLUClauseAdjust(pc->u.lld.d);
pc->u.lld.t.block = PtoLUIndexAdjust(pc->u.lld.t.block);
return;
case _enter_lu_pred: case _enter_lu_pred:
pc->u.Ill.I = (LogUpdIndex *)PtoOpAdjust((yamop *)(pc->u.Ill.I)); pc->u.Ill.I = (LogUpdIndex *)PtoOpAdjust((yamop *)(pc->u.Ill.I));
pc->u.Ill.l1 = PtoOpAdjust(pc->u.Ill.l1); pc->u.Ill.l1 = PtoOpAdjust(pc->u.Ill.l1);

7
H/rheap.h
View File

@ -11,8 +11,11 @@
* File: rheap.h * * File: rheap.h *
* comments: walk through heap code * * comments: walk through heap code *
* * * *
* Last rev: $Date: 2006-08-25 19:50:35 $,$Author: vsc $ * * Last rev: $Date: 2006-11-27 17:42:03 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.70 2006/08/25 19:50:35 vsc
* global data structures
*
* Revision 1.69 2006/08/22 16:12:46 vsc * Revision 1.69 2006/08/22 16:12:46 vsc
* global variables * global variables
* *
@ -777,6 +780,8 @@ restore_codes(void)
PtoPredAdjust(Yap_heap_regs->logdb_erased_marker->ClPred); PtoPredAdjust(Yap_heap_regs->logdb_erased_marker->ClPred);
Yap_heap_regs->hash_chain = Yap_heap_regs->hash_chain =
(AtomHashEntry *)PtoHeapCellAdjust((CELL *)(Yap_heap_regs->hash_chain)); (AtomHashEntry *)PtoHeapCellAdjust((CELL *)(Yap_heap_regs->hash_chain));
Yap_heap_regs->wide_hash_chain =
(AtomHashEntry *)PtoHeapCellAdjust((CELL *)(Yap_heap_regs->wide_hash_chain));
} }

8
H/sshift.h
View File

@ -471,6 +471,14 @@ PtoLUClauseAdjust (struct logic_upd_clause * ptr)
return (struct logic_upd_clause *) (CharP (ptr) + HDiff); return (struct logic_upd_clause *) (CharP (ptr) + HDiff);
} }
inline EXTERN struct logic_upd_index *PtoLUIndexAdjust (struct logic_upd_index *);
inline EXTERN struct logic_upd_index *
PtoLUIndexAdjust (struct logic_upd_index * ptr)
{
return (struct logic_upd_index *) (CharP (ptr) + HDiff);
}
inline EXTERN CELL *PtoHeapCellAdjust (CELL *); inline EXTERN CELL *PtoHeapCellAdjust (CELL *);

38
H/yapio.h
View File

@ -169,6 +169,7 @@ enum TokenKinds {
Number_tok, Number_tok,
Var_tok, Var_tok,
String_tok, String_tok,
WString_tok,
Ponctuation_tok, Ponctuation_tok,
Error_tok, Error_tok,
eot_tok eot_tok
@ -243,6 +244,20 @@ typedef struct AliasDescS {
int alias_stream; int alias_stream;
} * AliasDesc; } * AliasDesc;
/************ SWI compatible support for different encodings ************/
typedef enum {
ENC_OCTET = 0,
ENC_ISO_LATIN1 = 1,
ENC_ISO_ASCII = 2,
ENC_ISO_ANSI = 4,
ENC_ISO_UTF8 = 8,
ENC_UNICODE_BE = 16,
ENC_UNICODE_LE = 32
} encoding_t;
#define MAX_ISO_LATIN1 255
/****************** character definition table **************************/ /****************** character definition table **************************/
#define NUMBER_OF_CHARS 256 #define NUMBER_OF_CHARS 256
extern char *Yap_chtype; extern char *Yap_chtype;
@ -257,7 +272,7 @@ Term STD_PROTO(Yap_VarNames,(VarEntry *,Term));
/* routines in scanner.c */ /* routines in scanner.c */
TokEntry STD_PROTO(*Yap_tokenizer,(int)); TokEntry STD_PROTO(*Yap_tokenizer,(int));
void STD_PROTO(Yap_clean_tokenizer,(TokEntry *, VarEntry *, VarEntry *)); void STD_PROTO(Yap_clean_tokenizer,(TokEntry *, VarEntry *, VarEntry *));
Term STD_PROTO(Yap_scan_num,(int (*)(int))); Term STD_PROTO(Yap_scan_num,(wchar_t (*)(int)));
char STD_PROTO(*Yap_AllocScannerMemory,(unsigned int)); char STD_PROTO(*Yap_AllocScannerMemory,(unsigned int));
/* routines in iopreds.c */ /* routines in iopreds.c */
@ -267,6 +282,7 @@ int STD_PROTO(Yap_GetStreamFd,(int));
void STD_PROTO(Yap_CloseStreams,(int)); void STD_PROTO(Yap_CloseStreams,(int));
void STD_PROTO(Yap_CloseStream,(int)); void STD_PROTO(Yap_CloseStream,(int));
int STD_PROTO(Yap_PlGetchar,(void)); int STD_PROTO(Yap_PlGetchar,(void));
wchar_t STD_PROTO(Yap_PlGetWchar,(void));
int STD_PROTO(Yap_PlFGetchar,(void)); int STD_PROTO(Yap_PlFGetchar,(void));
int STD_PROTO(Yap_GetCharForSIGINT,(void)); int STD_PROTO(Yap_GetCharForSIGINT,(void));
int STD_PROTO(Yap_StreamToFileNo,(Term)); int STD_PROTO(Yap_StreamToFileNo,(Term));
@ -274,6 +290,11 @@ Term STD_PROTO(Yap_OpenStream,(FILE *,char *,Term,int));
Term STD_PROTO(Yap_StringToTerm,(char *,Term *)); Term STD_PROTO(Yap_StringToTerm,(char *,Term *));
Term STD_PROTO(Yap_TermToString,(Term,char *,unsigned int,int)); Term STD_PROTO(Yap_TermToString,(Term,char *,unsigned int,int));
int STD_PROTO(Yap_GetFreeStreamD,(void)); int STD_PROTO(Yap_GetFreeStreamD,(void));
int STD_PROTO(Yap_GetFreeStreamDForReading,(void));
Term STD_PROTO(Yap_WStringToList,(wchar_t *));
Term STD_PROTO(Yap_WStringToListOfAtoms,(wchar_t *));
Atom STD_PROTO(Yap_LookupWideAtom,(wchar_t *));
extern int extern int
Yap_c_input_stream, Yap_c_input_stream,
@ -297,7 +318,7 @@ extern int
#define To_heap_f 16 #define To_heap_f 16
/* write.c */ /* write.c */
void STD_PROTO(Yap_plwrite,(Term,int (*)(int, int),int)); void STD_PROTO(Yap_plwrite,(Term,wchar_t (*)(int, wchar_t),int));
/* grow.c */ /* grow.c */
int STD_PROTO(Yap_growstack_in_parser, (tr_fr_ptr *, TokEntry **, VarEntry **)); int STD_PROTO(Yap_growstack_in_parser, (tr_fr_ptr *, TokEntry **, VarEntry **));
@ -318,6 +339,7 @@ extern int Yap_Portray_delays;
#endif #endif
EXTERN inline UInt STD_PROTO(HashFunction, (unsigned char *)); EXTERN inline UInt STD_PROTO(HashFunction, (unsigned char *));
EXTERN inline UInt STD_PROTO(WideHashFunction, (wchar_t *));
EXTERN inline UInt EXTERN inline UInt
HashFunction(unsigned char *CHP) HashFunction(unsigned char *CHP)
@ -338,6 +360,18 @@ HashFunction(unsigned char *CHP)
*/ */
} }
EXTERN inline UInt
WideHashFunction(wchar_t *CHP)
{
UInt hash = 5381;
UInt c;
while ((c = *CHP++) != '\0') {
hash = hash * 33 ^ c;
}
return hash;
}
#define FAIL_ON_PARSER_ERROR 0 #define FAIL_ON_PARSER_ERROR 0
#define QUIET_ON_PARSER_ERROR 1 #define QUIET_ON_PARSER_ERROR 1
#define CONTINUE_ON_PARSER_ERROR 2 #define CONTINUE_ON_PARSER_ERROR 2

4
changes-5.1.html
View File

@ -16,6 +16,10 @@
<h2>Yap-5.1.2:</h2> <h2>Yap-5.1.2:</h2>
<ul> <ul>
<li> NEW: partial support for UNICODE.</li>
<li> FIXED: &yuml; has ISO-LATIN1 code 255, so it would be confused with EOF
(obs from Miguel Filgueiras).</li>
<li> FIXED: mess with \+ meta-call and modules (obs from Nicos Angelopoulos).</li>
<li> FIXED: reconsult with spy was broken (obs from Miguel Filgueiras).</li> <li> FIXED: reconsult with spy was broken (obs from Miguel Filgueiras).</li>
<li> FIXED: mess with EOF and open (obs from Nicos Angelopoulos).</li> <li> FIXED: mess with EOF and open (obs from Nicos Angelopoulos).</li>
<li> FIXED: make use_module/3 handle case where module is given.</li> <li> FIXED: make use_module/3 handle case where module is given.</li>

22
distribute
View File

@ -37,10 +37,30 @@ cd examples
splat splat
cd ../../../include cd ../../../include
splat splat
cd ../CLPBN
splat
cd clpbn
splat
cd examples
splat
cd School
splat
cd ../mn
splat
cd ../HMMer
splat
cd ../../../learning
splat
cd aleph_model
splat
cd ../nbayes
splat
cd ../utils
splat
#/bin/cp config.h config.h.mine #/bin/cp config.h config.h.mine
#/bin/cp ../../../bins/cyg/*.h . #/bin/cp ../../../bins/cyg/*.h .
#/bin/mv config.h.mine config.h #/bin/mv config.h.mine config.h
cd ../console cd ../../../console
splat splat
cd ../docs cd ../docs
splat splat

10
pl/boot.yap
View File

@ -745,10 +745,10 @@ not(G) :- \+ '$execute'(G).
; ;
'$call'(B,CP,G0,M) '$call'(B,CP,G0,M)
). ).
'$call'(\+ X, _CP, _G0, _M) :- !, '$call'(\+ X, _CP, _G0, M) :- !,
\+ '$execute'(X). \+ '$execute'(M:X).
'$call'(not(X), _CP, _G0, _M) :- !, '$call'(not(X), _CP, _G0, _M) :- !,
\+ '$execute'(X). \+ '$execute'(M:X).
'$call'(!, CP, _,_) :- !, '$call'(!, CP, _,_) :- !,
'$$cut_by'(CP). '$$cut_by'(CP).
'$call'([A|B], _, _, M) :- !, '$call'([A|B], _, _, M) :- !,
@ -858,7 +858,7 @@ break :-
set_value('$lf_verbose', OldSilent). set_value('$lf_verbose', OldSilent).
bootstrap(F) :- bootstrap(F) :-
'$open'(F,'$csult',Stream,0), '$open'(F,'$csult',Stream,0,0),
'$current_stream'(File,_,Stream), '$current_stream'(File,_,Stream),
'$start_consult'(consult, File, LC), '$start_consult'(consult, File, LC),
file_directory_name(File, Dir), file_directory_name(File, Dir),
@ -931,7 +931,7 @@ bootstrap(F) :-
'$exists'(F,Mode) :- '$exists'(F,Mode) :-
get_value(fileerrors,V), get_value(fileerrors,V),
set_value(fileerrors,0), set_value(fileerrors,0),
( '$open'(F,Mode,S,0) -> '$close'(S), set_value(fileerrors,V) ; set_value(fileerrors,V), fail). ( '$open'(F,Mode,S,0,1) -> '$close'(S), set_value(fileerrors,V) ; set_value(fileerrors,V), fail).
% This sequence must be followed: % This sequence must be followed:

64
pl/consult.yap
View File

@ -41,7 +41,12 @@ load_files(Files,Opts) :-
'$process_lf_opts'(V,_,_,_,_,_,_,_,_,_,_,_,Call) :- '$process_lf_opts'(V,_,_,_,_,_,_,_,_,_,_,_,Call) :-
var(V), !, var(V), !,
'$do_error'(instantiation_error,Call). '$do_error'(instantiation_error,Call).
'$process_lf_opts'([],_,_,_,_,_,_,_,_,_,_,_,_). '$process_lf_opts'([],_,_,_,_,_,_,_,Encoding,_,_,_,_) :-
(var(Encoding) ->
'$default_encoding'(Encoding)
;
true
).
'$process_lf_opts'([Opt|Opts],Silent,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,SkipUnixComments,Reconsult,Files,Call) :- '$process_lf_opts'([Opt|Opts],Silent,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,SkipUnixComments,Reconsult,Files,Call) :-
'$process_lf_opt'(Opt,Silent,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,SkipUnixComments,Reconsult,Files,Call), !, '$process_lf_opt'(Opt,Silent,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,SkipUnixComments,Reconsult,Files,Call), !,
'$process_lf_opts'(Opts,Silent,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,SkipUnixComments,Reconsult,Files,Call). '$process_lf_opts'(Opts,Silent,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,SkipUnixComments,Reconsult,Files,Call).
@ -61,8 +66,15 @@ load_files(Files,Opts) :-
( atom(Files) -> true ; '$do_error'(type_error(atom,Files),Call) ), ( atom(Files) -> true ; '$do_error'(type_error(atom,Files),Call) ),
/* call make */ /* call make */
'$do_error'(domain_error(unimplemented_option,derived_from),Call). '$do_error'(domain_error(unimplemented_option,derived_from),Call).
'$process_lf_opt'(encoding(Encoding),_,_,_,_,_,_,_,_,_,_,_,Call) :- '$process_lf_opt'(encoding(Encoding),_,_,_,_,_,_,_,_,EncCode,_,_,Call) :-
'$do_error'(domain_error(unimplemented_option,encoding),Call). ( var(Encoding) ->
'$do_error'(instantiation_error,Call)
;
'$valid_encoding'(Enc, EncCode) ->
true
;
'$do_error'(domain_error(io_mode,encoding(Encoding)),Call)
).
'$process_lf_opt'(expand(true),_,_,true,_,_,_,_,_,_,_,_,Call) :- '$process_lf_opt'(expand(true),_,_,true,_,_,_,_,_,_,_,_,Call) :-
'$do_error'(domain_error(unimplemented_option,expand),Call). '$do_error'(domain_error(unimplemented_option,expand),Call).
'$process_lf_opt'(expand(false),_,_,false,_,_,_,_,_,_,_,_,_). '$process_lf_opt'(expand(false),_,_,false,_,_,_,_,_,_,_,_,_).
@ -111,9 +123,9 @@ load_files(Files,Opts) :-
'$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,SkipUnixComments,Reconsult,UseModule). '$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,SkipUnixComments,Reconsult,UseModule).
'$lf'(user_input, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,SkipUnixComments,Reconsult,UseModule) :- !, '$lf'(user_input, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,SkipUnixComments,Reconsult,UseModule) :- !,
'$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,Reconsult,UseModule). '$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,Reconsult,UseModule).
'$lf'(X, Mod, Call, InfLevel,_,Changed,CompilationMode,Imports,_,_,SkipUnixComments,Reconsult,UseModule) :- '$lf'(X, Mod, Call, InfLevel,_,Changed,CompilationMode,Imports,_,Enc,SkipUnixComments,Reconsult,UseModule) :-
'$find_in_path'(X, Y, Call), '$find_in_path'(X, Y, Call),
'$open'(Y, '$csult', Stream, 0), !, '$open'(Y, '$csult', Stream, 0, Enc), !,
'$set_changed_lfmode'(Changed), '$set_changed_lfmode'(Changed),
'$start_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, Changed,SkipUnixComments,Reconsult,UseModule), '$start_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, Changed,SkipUnixComments,Reconsult,UseModule),
'$close'(Stream). '$close'(Stream).
@ -305,7 +317,8 @@ use_module(M,F,Is) :-
'$values'('$included_file',OY,Y), '$values'('$included_file',OY,Y),
'$current_module'(Mod), '$current_module'(Mod),
H0 is heapused, '$cputime'(T0,_), H0 is heapused, '$cputime'(T0,_),
( '$open'(Y,'$csult',Stream,0), !, '$default_encoding'(Encoding),
( '$open'(Y,'$csult',Stream,0,Encoding), !,
'$print_message'(Verbosity, loading(including, Y)), '$print_message'(Verbosity, loading(including, Y)),
'$loop'(Stream,Status), '$close'(Stream) '$loop'(Stream,Status), '$close'(Stream)
; ;
@ -367,7 +380,8 @@ prolog_load_context(term_position, Position) :-
'$use_preds'(Imports,P, NM, M). '$use_preds'(Imports,P, NM, M).
'$ensure_file_loaded'(F, M, _) :- '$ensure_file_loaded'(F, M, _) :-
recorded('$lf_loaded','$lf_loaded'(F1,M,Age),R), recorded('$lf_loaded','$lf_loaded'(F1,M,Age),R),
'$same_file'(F1,F). '$same_file'(F1,F), !.
% if the file exports a module, then we can % if the file exports a module, then we can
% be imported from any module. % be imported from any module.
@ -481,3 +495,39 @@ remove_from_path(New) :- '$check_path'(New,Path),
getenv('YAPSHAREDIR', Dir). getenv('YAPSHAREDIR', Dir).
'$system_library_directories'(Dir) :- '$system_library_directories'(Dir) :-
get_value(system_library_directory,Dir). get_value(system_library_directory,Dir).
%
% encoding stuff: what I believe SWI does.
%
% 8-bit binaries
'$valid_encoding'(octet, 0).
% 7-bit ASCII as America originally intended
'$valid_encoding'(ascii, 2).
% Ye europeaners made it 8 bits
'$valid_encoding'(iso_latin_1, 1).
% UTF-8: default 8 bits but 80 extends to 16bits
'$valid_encoding'(utf8, 8).
% UNICODE: 16 bits throughout, the way Gates does it!
'$valid_encoding'(unicode_be, 16).
'$valid_encoding'(unicode_le, 32).
% whatever the system tell us to do.
'$valid_encoding'(text, 4).
'$default_encoding'(DefCode) :- nonvar(DefCode), !,
'$set_encoding'('$stream'(0),DefCode),
'$set_encoding'('$stream'(1),DefCode),
'$set_encoding'('$stream'(2),DefCode),
set_value('$default_encoding',DefCode).
'$default_encoding'(DefCode) :-
get_value('$default_encoding',DefCode0),
( DefCode0 == [] ->
'$get_default_encoding'(DefCode)
;
DefCode = DefCode0
).

14
pl/directives.yap
View File

@ -49,6 +49,7 @@
'$directive'(use_module(_,_,_)). '$directive'(use_module(_,_,_)).
'$directive'(thread_local(_)). '$directive'(thread_local(_)).
'$directive'(uncutable(_)). '$directive'(uncutable(_)).
'$directive'(encoding(_)).
'$exec_directives'((G1,G2), Mode, M) :- !, '$exec_directives'((G1,G2), Mode, M) :- !,
'$exec_directives'(G1, Mode, M), '$exec_directives'(G1, Mode, M),
@ -64,6 +65,8 @@
'$discontiguous'(D,M). '$discontiguous'(D,M).
'$exec_directive'(initialization(D), _, M) :- '$exec_directive'(initialization(D), _, M) :-
'$initialization'(M:D). '$initialization'(M:D).
'$exec_directive'(encoding(Enc), _, M) :-
'$current_encoding'(Enc).
'$exec_directive'(parallel, _, _) :- '$exec_directive'(parallel, _, _) :-
'$parallel'. '$parallel'.
'$exec_directive'(sequential, _, _) :- '$exec_directive'(sequential, _, _) :-
@ -131,6 +134,16 @@ yap_flag(argv,L) :- '$argv'(L).
yap_flag(hide,Atom) :- !, hide(Atom). yap_flag(hide,Atom) :- !, hide(Atom).
yap_flag(unhide,Atom) :- !, unhide(Atom). yap_flag(unhide,Atom) :- !, unhide(Atom).
% hide/unhide atoms
yap_flag(encoding,DefaultEncoding) :- var(DefaultEncoding), !,
'$default_encoding'(DefCode),
'$valid_encoding'(DefaultEncoding, DefCode).
yap_flag(encoding,Encoding) :-
'$valid_encoding'(Encoding, EncCode), !,
'$default_encoding'(EncCode).
yap_flag(encoding,Encoding) :-
'$do_error'(domain_error(io_mode,encoding(Encoding)),yap_flag(encoding,Encoding)).
% control garbage collection % control garbage collection
yap_flag(gc,V) :- yap_flag(gc,V) :-
var(V), !, var(V), !,
@ -647,6 +660,7 @@ yap_flag(float_format,X) :-
V = discontiguous_warnings ; V = discontiguous_warnings ;
V = dollar_as_lower_case ; V = dollar_as_lower_case ;
V = double_quotes ; V = double_quotes ;
V = encoding ;
% V = fast ; % V = fast ;
V = fileerrors ; V = fileerrors ;
V = float_format ; V = float_format ;

1
pl/init.yap
View File

@ -34,7 +34,6 @@ otherwise.
[] :- true. [] :- true.
:- set_value('$doindex',true). :- set_value('$doindex',true).
% force having indexing code for throw. % force having indexing code for throw.

2
pl/sockets.yap
View File

@ -36,7 +36,7 @@ socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams) :-
'$do_error'(instantiation_error,G). '$do_error'(instantiation_error,G).
'$check_list_for_sockets'([],_) :- !. '$check_list_for_sockets'([],_) :- !.
'$check_list_for_sockets'([_|T],G) :- !, '$check_list_for_sockets'([_|T],G) :- !,
  '$check_list_for_sockets'(T,G). '$check_list_for_sockets'(T,G).
'$check_list_for_sockets'(T,G) :- '$check_list_for_sockets'(T,G) :-
'$do_error'(type_error(list,T),G). '$do_error'(type_error(list,T),G).

2
pl/utils.yap
View File

@ -323,6 +323,8 @@ current_atom(A) :- % check
atom(A), !. atom(A), !.
current_atom(A) :- % generate current_atom(A) :- % generate
'$current_atom'(A). '$current_atom'(A).
current_atom(A) :- % generate
'$current_wide_atom'(A).
current_predicate(A,T) :- var(T), !, % only for the predicate current_predicate(A,T) :- var(T), !, % only for the predicate
'$current_module'(M), '$current_module'(M),

61
pl/yio.yap
View File

@ -24,7 +24,8 @@ open(Source,M,T) :- var(M), !,
open(Source,M,T) :- nonvar(T), !, open(Source,M,T) :- nonvar(T), !,
'$do_error'(type_error(variable,T),open(Source,M,T)). '$do_error'(type_error(variable,T),open(Source,M,T)).
open(File,Mode,Stream) :- open(File,Mode,Stream) :-
'$open'(File,Mode,Stream,16). '$default_encoding'(Encoding),
'$open'(File,Mode,Stream,16,Encoding).
/* meaning of flags for '$write' is /* meaning of flags for '$write' is
1 quote illegal atoms 1 quote illegal atoms
@ -58,42 +59,46 @@ close(S,Opts) :-
open(F,T,S,Opts) :- open(F,T,S,Opts) :-
'$check_io_opts'(Opts,open(F,T,S,Opts)), '$check_io_opts'(Opts,open(F,T,S,Opts)),
'$process_open_opts'(Opts, 0, N, Aliases), '$process_open_opts'(Opts, 0, N, Aliases, E),
'$open2'(F,T,S,N), '$open2'(F,T,S,N,E),
'$process_open_aliases'(Aliases,S). '$process_open_aliases'(Aliases,S).
'$open2'(Source,M,T,N) :- var(Source), !, '$open2'(Source,M,T,N,_) :- var(Source), !,
'$do_error'(instantiation_error,open(Source,M,T,N)). '$do_error'(instantiation_error,open(Source,M,T,N)).
'$open2'(Source,M,T,N) :- var(M), !, '$open2'(Source,M,T,N,_) :- var(M), !,
'$do_error'(instantiation_error,open(Source,M,T,N)). '$do_error'(instantiation_error,open(Source,M,T,N)).
'$open2'(Source,M,T,N) :- nonvar(T), !, '$open2'(Source,M,T,N,_) :- nonvar(T), !,
'$do_error'(type_error(variable,T),open(Source,M,T,N)). '$do_error'(type_error(variable,T),open(Source,M,T,N)).
'$open2'(File,Mode,Stream,N) :- '$open2'(File,Mode,Stream,N,Encoding) :-
'$open'(File,Mode,Stream,N). '$open'(File,Mode,Stream,N,Encoding).
'$process_open_aliases'([],_). '$process_open_aliases'([],_).
'$process_open_aliases'([Alias|Aliases],S) :- '$process_open_aliases'([Alias|Aliases],S) :-
'$add_alias_to_stream'(Alias, S), '$add_alias_to_stream'(Alias, S),
'$process_open_aliases'(Aliases,S). '$process_open_aliases'(Aliases,S).
'$process_open_opts'([], N, N, []). '$process_open_opts'([], N, N, [], DefaultEncoding) :-
'$process_open_opts'([type(T)|L], N0, N, Aliases) :- '$default_encoding'(DefaultEncoding).
'$process_open_opts'([type(T)|L], N0, N, Aliases, Encoding) :-
'$value_open_opt'(T,type,I1,I2), '$value_open_opt'(T,type,I1,I2),
N1 is I1\/N0, N1 is I1\/N0,
N2 is I2/\N1, N2 is I2/\N1,
'$process_open_opts'(L,N2,N, Aliases). '$process_open_opts'(L,N2,N, Aliases, Encoding).
'$process_open_opts'([reposition(T)|L], N0, N, Aliases) :- '$process_open_opts'([reposition(T)|L], N0, N, Aliases, Encoding) :-
'$value_open_opt'(T,reposition,I1,I2), '$value_open_opt'(T,reposition,I1,I2),
N1 is I1\/N0, N1 is I1\/N0,
N2 is I2/\N1, N2 is I2/\N1,
'$process_open_opts'(L,N2,N, Aliases). '$process_open_opts'(L,N2,N, Aliases, Encoding).
'$process_open_opts'([eof_action(T)|L], N0, N, Aliases) :- '$process_open_opts'([encoding(Enc)|L], N0, N, Aliases, T, EncCode) :-
'$valid_encoding'(Enc, EndCode),
'$process_open_opts'(L,N2,N, Aliases, _).
'$process_open_opts'([eof_action(T)|L], N0, N, Aliases, Encoding) :-
'$value_open_opt'(T,eof_action,I1,I2), '$value_open_opt'(T,eof_action,I1,I2),
N1 is I1\/N0, N1 is I1\/N0,
N2 is I2/\N1, N2 is I2/\N1,
'$process_open_opts'(L,N2,N, Aliases). '$process_open_opts'(L,N2,N, Aliases, Encoding).
'$process_open_opts'([alias(Alias)|L], N0, N, [Alias|Aliases]) :- '$process_open_opts'([alias(Alias)|L], N0, N, [Alias|Aliases], Encoding) :-
'$process_open_opts'(L,N0,N, Aliases). '$process_open_opts'(L,N0,N, Aliases, Encoding).
'$value_open_opt'(text,_,1,X) :- X is 128-2. % default '$value_open_opt'(text,_,1,X) :- X is 128-2. % default
@ -141,6 +146,8 @@ open(F,T,S,Opts) :-
'$check_open_alias_arg'(T, G). '$check_open_alias_arg'(T, G).
'$check_opt_open'(eof_action(T), G) :- !, '$check_opt_open'(eof_action(T), G) :- !,
'$check_open_eof_action_arg'(T, G). '$check_open_eof_action_arg'(T, G).
'$check_opt_open'(encoding(T), G) :- !,
'$check_open_encoding'(T, G).
'$check_opt_open'(A, G) :- '$check_opt_open'(A, G) :-
'$do_error'(domain_error(stream_option,A),G). '$do_error'(domain_error(stream_option,A),G).
@ -223,6 +230,12 @@ open(F,T,S,Opts) :-
'$check_open_eof_action_arg'(X,G) :- '$check_open_eof_action_arg'(X,G) :-
'$do_error'(domain_error(io_mode,eof_action(X)),G). '$do_error'(domain_error(io_mode,eof_action(X)),G).
'$check_open_encoding'(X, G) :- var(X), !,
'$do_error'(instantiation_error,G).
'$check_open_encoding'(Encoding,_) :- '$valid_encoding'(Encoding,_), !.
'$check_open_eof_action_arg'(Encoding,G) :-
'$do_error'(domain_error(io_mode,encoding(Encoding)),G).
'$check_read_syntax_errors_arg'(X, G) :- var(X), !, '$check_read_syntax_errors_arg'(X, G) :- var(X), !,
'$do_error'(instantiation_error,G). '$do_error'(instantiation_error,G).
'$check_read_syntax_errors_arg'(dec10,_) :- !. '$check_read_syntax_errors_arg'(dec10,_) :- !.
@ -584,26 +597,26 @@ peek_char(S,V) :-
( I = -1 -> V = end_of_file ; atom_codes(V,[I])). ( I = -1 -> V = end_of_file ; atom_codes(V,[I])).
get_code(S,V) :- get_code(S,V) :-
\+ var(V), (\+ integer(V) ; V < -1 ; V > 256), !, \+ var(V), (\+ integer(V)), !,
'$do_error'(type_error(in_character_code,V),get_code(S,V)). '$do_error'(type_error(in_character_code,V),get_code(S,V)).
get_code(S,V) :- get_code(S,V) :-
'$get0'(S,V). '$get0'(S,V).
get_code(V) :- get_code(V) :-
\+ var(V), (\+ integer(V) ; V < -1 ; V > 256), !, \+ var(V), (\+ integer(V)), !,
'$do_error'(type_error(in_character_code,V),get_code(V)). '$do_error'(type_error(in_character_code,V),get_code(V)).
get_code(V) :- get_code(V) :-
current_input(S), current_input(S),
'$get0'(S,V). '$get0'(S,V).
peek_code(S,V) :- peek_code(S,V) :-
\+ var(V), (\+ integer(V) ; V < -1 ; V > 256), !, \+ var(V), (\+ integer(V)), !,
'$do_error'(type_error(in_character_code,V),get_code(S,V)). '$do_error'(type_error(in_character_code,V),get_code(S,V)).
peek_code(S,V) :- peek_code(S,V) :-
'$peek'(S,V). '$peek'(S,V).
peek_code(V) :- peek_code(V) :-
\+ var(V), (\+ integer(V) ; V < -1 ; V > 256), !, \+ var(V), (\+ integer(V)), !,
'$do_error'(type_error(in_character_code,V),get_code(V)). '$do_error'(type_error(in_character_code,V),get_code(V)).
peek_code(V) :- peek_code(V) :-
current_input(S), current_input(S),
@ -649,7 +662,7 @@ put_char(S,V) :-
put_code(V) :- var(V), !, put_code(V) :- var(V), !,
'$do_error'(instantiation_error,put_code(V)). '$do_error'(instantiation_error,put_code(V)).
put_code(V) :- put_code(V) :-
(\+ integer(V) ; V < 0 ; V > 256), !, (\+ integer(V)), !,
'$do_error'(type_error(character_code,V),put_code(V)). '$do_error'(type_error(character_code,V),put_code(V)).
put_code(V) :- put_code(V) :-
current_output(S), current_output(S),
@ -659,7 +672,7 @@ put_code(V) :-
put_code(S,V) :- var(V), !, put_code(S,V) :- var(V), !,
'$do_error'(instantiation_error,put_code(S,V)). '$do_error'(instantiation_error,put_code(S,V)).
put_code(S,V) :- put_code(S,V) :-
(\+ integer(V) ; V < 0 ; V > 256), !, (\+ integer(V)), !,
'$do_error'(type_error(character_code,V),put_code(S,V)). '$do_error'(type_error(character_code,V),put_code(S,V)).
put_code(S,V) :- put_code(S,V) :-
'$put'(S,V). '$put'(S,V).
@ -904,7 +917,7 @@ absolute_file_name(RelFile, AbsFile) :-
'$exists'(F,Mode,AbsFile) :- '$exists'(F,Mode,AbsFile) :-
get_value(fileerrors,V), get_value(fileerrors,V),
set_value(fileerrors,0), set_value(fileerrors,0),
( '$open'(F,Mode,S,0), !, ( '$open'(F,Mode,S,0,0), !,
'$file_name'(S, AbsFile), '$file_name'(S, AbsFile),
'$close'(S), set_value(fileerrors,V); '$close'(S), set_value(fileerrors,V);
set_value(fileerrors,V), fail). set_value(fileerrors,V), fail).