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 *
* 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 $
* 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
* fixes for indexing code.
*
@ -960,16 +964,14 @@ Yap_absmi(int inp)
LogUpdClause *lcl = PREG->u.lld.d;
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 */
PREG = FAILCODE;
} else {
PredEntry *pe = PREG->u.lld.d->ClPred;
LOCK(pe->StatisticsForPred.lock);
pe->StatisticsForPred.NOfRetries++;
UNLOCK(pe->StatisticsForPred.lock);
PREG = PREG->u.lld.d->ClCode;
LOCK(ap->StatisticsForPred.lock);
ap->StatisticsForPred.NOfRetries++;
UNLOCK(ap->StatisticsForPred.lock);
PREG = lcl->ClCode;
}
/* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */
@ -977,7 +979,8 @@ Yap_absmi(int inp)
LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */
TR = B->cp_tr-1;
B->cp_tr--;
TR = B->cp_tr;
/* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
UNLOCK(cl->ClLock);
@ -994,10 +997,15 @@ Yap_absmi(int inp)
}
UNLOCK(lcl->ClLock);
}
if (cl->ClFlags & ErasedMask)
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
else
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
} else {
UNLOCK(cl->ClLock);
@ -1016,10 +1024,15 @@ Yap_absmi(int inp)
TRAIL_CLREF(lcl);
}
}
if (cl->ClFlags & ErasedMask)
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
else
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
}
}
@ -1262,7 +1275,7 @@ Yap_absmi(int inp)
LogUpdClause *lcl = PREG->u.lld.d;
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 */
PREG = FAILCODE;
} else {
@ -1280,10 +1293,10 @@ Yap_absmi(int inp)
setregs();
JMPNext();
}
LOCK(PREG->u.lld.d->ClPred->StatisticsForPred.lock);
PREG->u.lld.d->ClPred->StatisticsForPred.NOfRetries++;
UNLOCK(PREG->u.lld.d->ClPred->StatisticsForPred.lock);
PREG = PREG->u.lld.d->ClCode;
LOCK(ap->StatisticsForPred.lock);
ap->StatisticsForPred.NOfRetries++;
UNLOCK(ap->ClPred->StatisticsForPred.lock);
PREG = lcl->ClCode;
}
/* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */
@ -1291,7 +1304,7 @@ Yap_absmi(int inp)
LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */
TR = B->cp_tr-1;
TR = --B->cp_tr;
/* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
UNLOCK(cl->ClLock);
@ -1308,10 +1321,15 @@ Yap_absmi(int inp)
}
UNLOCK(lcl->ClLock);
}
if (cl->ClFlags & ErasedMask)
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
else
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
} else {
UNLOCK(cl->ClLock);
@ -1320,7 +1338,7 @@ Yap_absmi(int inp)
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) {
cl->ClFlags &= ~InUseMask;
TR = B->cp_tr-1;
TR = --B->cp_tr;
/* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) {
if (PREG != FAILCODE) {
@ -1330,10 +1348,15 @@ Yap_absmi(int inp)
TRAIL_CLREF(lcl);
}
}
if (cl->ClFlags & ErasedMask)
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
else
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
}
}
@ -8094,12 +8117,12 @@ Yap_absmi(int inp)
LogUpdClause *lcl = PREG->u.lld.d;
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);*/
if (!VALID_TIMESTAMP(timestamp, PREG->u.lld.d)) {
/* fprintf(stderr,"- %p/%p %d %d %p\n",PREG,ap,timestamp,ap->TimeStampOfPred,PREG->u.lld.d->ClCode);*/
if (!VALID_TIMESTAMP(timestamp, lcl)) {
/* jump to next alternative */
PREG = FAILCODE;
} else {
PREG = PREG->u.lld.d->ClCode;
PREG = lcl->ClCode;
}
/* HEY, leave indexing block alone!! */
/* check if we are the ones using this code */
@ -8107,7 +8130,8 @@ Yap_absmi(int inp)
LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl);
/* clear the entry from the trail */
TR = B->cp_tr-1;
B->cp_tr--;
TR = B->cp_tr;
/* actually get rid of the code */
if (cl->ClRefCount == 0 && (cl->ClFlags & (ErasedMask|DirtyMask))) {
UNLOCK(cl->ClLock);
@ -8121,13 +8145,19 @@ Yap_absmi(int inp)
/* always add an extra reference */
INC_CLREF_COUNT(lcl);
TRAIL_CLREF(lcl);
B->cp_tr = TR;
}
UNLOCK(lcl->ClLock);
}
if (cl->ClFlags & ErasedMask)
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
else
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
setregs();
}
save_pc();
} else {
UNLOCK(cl->ClLock);
@ -8136,7 +8166,8 @@ Yap_absmi(int inp)
if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) &&
B->cp_tr != B->cp_b->cp_tr) {
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 */
if (cl->ClFlags & (ErasedMask|DirtyMask)) {
if (PREG != FAILCODE) {
@ -8144,13 +8175,18 @@ Yap_absmi(int inp)
if (lcl->ClRefCount == 1 && !(lcl->ClFlags & InUseMask)) {
lcl->ClFlags |= InUseMask;
TRAIL_CLREF(lcl);
B->cp_tr = TR;
}
}
if (cl->ClFlags & ErasedMask)
if (cl->ClFlags & ErasedMask) {
saveregs();
Yap_ErLogUpdIndex(cl);
else
setregs();
} else {
saveregs();
Yap_CleanUpIndex(cl);
save_pc();
setregs();
}
}
}
#endif

118
C/adtdefs.c
View File

@ -33,6 +33,7 @@ Prop STD_PROTO(PredPropByAtom,(Atom, Term));
#include "Heap.h"
#include "yapio.h"
#include <stdio.h>
#include <wchar.h>
#if HAVE_STRING_H
#include <string.h>
#endif
@ -139,6 +140,21 @@ SearchAtom(unsigned char *p, Atom a) {
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
LookupAtom(char *atom)
{ /* lookup atom in atom table */
@ -194,12 +210,80 @@ LookupAtom(char *atom)
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
Yap_LookupAtom(char *atom)
{ /* lookup atom in atom table */
return LookupAtom(atom);
}
Atom
Yap_LookupWideAtom(wchar_t *atom)
{ /* lookup atom in atom table */
return LookupWideAtom(atom);
}
Atom
Yap_FullLookupAtom(char *atom)
{ /* lookup atom in atom table */
@ -517,6 +601,7 @@ Yap_GetExpPropHavingLock(AtomEntry *ae, unsigned int arity)
p = RepExpProp(p0 = ae->PropsOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE);
return (p0);
}
@ -868,6 +953,19 @@ Yap_StringToList(char *s)
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
Yap_StringToDiffList(char *s, Term t)
{
@ -895,6 +993,22 @@ Yap_StringToListOfAtoms(char *s)
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
Yap_ArrayToList(register Term *tp, int nof)
{
@ -927,8 +1041,8 @@ Yap_GetName(char *s, UInt max, Term t)
if (!IsNumTerm(Head))
return (FALSE);
i = IntOfTerm(Head);
if (i < 0 || i > 255)
return (FALSE);
if (i < 0 || i > MAX_ISO_LATIN1)
return FALSE;
*s++ = i;
t = TailOfTerm(t);
if (--max == 0) {

86
C/agc.c
View File

@ -143,6 +143,7 @@ AtomAdjust(Atom a)
#define PtoHeapCellAdjust(P) (P)
#define PtoOpAdjust(P) (P)
#define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define PtoPredAdjust(P) (P)
#define PropAdjust(P) (P)
#define TrailAddrAdjust(P) (P)
@ -162,6 +163,25 @@ rehash(CELL *oldcode, int NOfE, int KindOfEntries)
#include "rheap.h"
static void
mark_hash_entry(AtomHashEntry *HashPtr)
{
Atom atm;
atm = HashPtr->Entry;
if (atm) {
AtomEntry *at = RepAtom(atm);
do {
#ifdef DEBUG_RESTORE1 /* useful during debug */
fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif
RestoreEntries(RepProp(at->PropsOfAE));
atm = at->NextOfAE;
at = RepAtom(CleanAtomMarkedBit(atm));
} while (!EndOfPAEntr(at));
}
}
/*
* This is the really tough part, to restore the whole of the heap
*/
@ -170,23 +190,17 @@ mark_atoms(void)
{
AtomHashEntry *HashPtr = HashChain;
register int i;
Atom atm;
AtomEntry *at;
Atom atm;
restore_codes();
for (i = 0; i < AtomHashTableSize; ++i) {
atm = HashPtr->Entry;
if (atm) {
at = RepAtom(atm);
do {
#ifdef DEBUG_RESTORE1 /* useful during debug */
fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif
RestoreEntries(RepProp(at->PropsOfAE));
atm = at->NextOfAE;
at = RepAtom(CleanAtomMarkedBit(atm));
} while (!EndOfPAEntr(at));
}
mark_hash_entry(HashPtr);
HashPtr++;
}
HashPtr = WideHashChain;
for (i = 0; i < WideAtomHashTableSize; ++i) {
mark_hash_entry(HashPtr);
HashPtr++;
}
@ -304,6 +318,29 @@ mark_stacks(void)
mark_global();
}
static void
clean_atom(AtomHashEntry *HashPtr)
{
Atom atm = HashPtr->Entry;
Atom *patm = &(HashPtr->Entry);
while (atm != NIL) {
AtomEntry *at = RepAtom(CleanAtomMarkedBit(atm));
if (AtomResetMark(at) || (AGCHook != NULL && !AGCHook(atm))) {
patm = &(at->NextOfAE);
atm = at->NextOfAE;
NOfAtoms--;
} else {
#ifdef DEBUG_RESTORE3
fprintf(stderr, "Purged %p:%s\n", at, at->StrOfAE);
#endif
*patm = at->NextOfAE;
atm = at->NextOfAE;
agc_collected += sizeof(AtomEntry)+strlen(at->StrOfAE);
Yap_FreeCodeSpace((char *)at);
}
}
}
/*
* This is the really tough part, to restore the whole of the heap
*/
@ -317,24 +354,11 @@ clean_atoms(void)
AtomEntry *at;
for (i = 0; i < AtomHashTableSize; ++i) {
atm = HashPtr->Entry;
patm = &(HashPtr->Entry);
while (atm != NIL) {
at = RepAtom(CleanAtomMarkedBit(atm));
if (AtomResetMark(at) || (AGCHook != NULL && !AGCHook(atm))) {
patm = &(at->NextOfAE);
atm = at->NextOfAE;
NOfAtoms--;
} else {
#ifdef DEBUG_RESTORE3
fprintf(stderr, "Purged %p:%s\n", at, at->StrOfAE);
#endif
*patm = at->NextOfAE;
atm = at->NextOfAE;
agc_collected += sizeof(AtomEntry)+strlen(at->StrOfAE);
Yap_FreeCodeSpace((char *)at);
}
}
clean_atom(HashPtr);
HashPtr++;
}
for (i = 0; i < WideAtomHashTableSize; ++i) {
clean_atom(HashPtr);
HashPtr++;
}
patm = &(INVISIBLECHAIN.Entry);

22
C/c_interface.c
View File

@ -10,8 +10,13 @@
* File: c_interface.c *
* 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 $
* 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
* 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_EndConsult,(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 char *STD_PROTO(YAP_CompileClause, (Term));
X_API void STD_PROTO(YAP_PutValue, (Atom,Term));
@ -344,9 +349,9 @@ static int do_yap_getc(int streamno) {
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);
return(ch);
}
@ -1002,9 +1007,10 @@ YAP_Error(int myerrno, Term t, char *buf,...)
Yap_Error(myerrno,t,tmpbuf);
}
static void myputc (int ch)
static wchar_t myputc (wchar_t ch)
{
putc(ch,stderr);
return ch;
}
X_API Term
@ -1130,12 +1136,12 @@ YAP_Read(int (*mygetc)(void))
BACKUP_MACHINE_REGS();
do_getf = mygetc;
sno = Yap_GetFreeStreamD();
sno = Yap_GetFreeStreamDForReading();
if (sno < 0) {
Yap_Error(SYSTEM_ERROR,TermNil, "new stream not available for YAP_Read");
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);
Stream[sno].status = Free_Stream_f;
if (Yap_ErrorMessage)
@ -1152,7 +1158,7 @@ YAP_Read(int (*mygetc)(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();

6
C/cdmgr.c
View File

@ -11,8 +11,11 @@
* File: cdmgr.c *
* 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 $
* Revision 1.199 2006/11/15 00:13:36 vsc
* fixes for indexing code.
*
* Revision 1.198 2006/11/14 11:42:25 vsc
* fix bug in growstack
*
@ -574,6 +577,7 @@ static_in_use(PredEntry *p, int check_everything)
#define PtoPredAdjust(X) (X)
#define PtoOpAdjust(X) (X)
#define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define XAdjust(X) (X)
#define YAdjust(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
#include <string.h>
#endif
#include <wchar.h>
STATIC_PROTO(Int compare, (Term, Term));
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))
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
CELL *pt1)
{
@ -73,10 +104,7 @@ static int compare_complex(register CELL *pt0, register CELL *pt0_end, register
if (d0 == d1) continue;
else if (IsAtomTerm(d0)) {
if (IsAtomTerm(d1))
out = strcmp(
RepAtom(AtomOfTerm(d0))->StrOfAE,
RepAtom(AtomOfTerm(d1))->StrOfAE
);
out = cmp_atoms(AtomOfTerm(d0), AtomOfTerm(d1));
else if (IsPrimitiveTerm(d1))
out = 1;
else out = -1;
@ -207,8 +235,7 @@ static int compare_complex(register CELL *pt0, register CELL *pt0_end, register
/* compare functors */
if (f != (Functor)*ap3) {
if (!(out = ArityOfFunctor(f)-ArityOfFunctor(f2)))
out = strcmp(RepAtom(NameOfFunctor(f))->StrOfAE,
RepAtom(NameOfFunctor(f2))->StrOfAE);
out = cmp_atoms(NameOfFunctor(f), NameOfFunctor(f2));
goto done;
}
#ifdef RATIONAL_TREES
@ -285,10 +312,7 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
if (IsAtomOrIntTerm(t1)) {
if (IsAtomTerm(t1)) {
if (IsAtomTerm(t2))
return strcmp(
RepAtom(AtomOfTerm(t1))->StrOfAE,
RepAtom(AtomOfTerm(t2))->StrOfAE
);
return cmp_atoms(AtomOfTerm(t1),AtomOfTerm(t2));
if (IsPrimitiveTerm(t2))
return 1;
return -1;
@ -404,8 +428,7 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
r = ArityOfFunctor(fun1) - ArityOfFunctor(fun2);
if (r)
return r;
r = strcmp(RepAtom(NameOfFunctor(fun1))->StrOfAE,
RepAtom(NameOfFunctor(fun2))->StrOfAE);
r = cmp_atoms(NameOfFunctor(fun1), NameOfFunctor(fun2));
if (r)
return r;
else

16
C/dbase.c
View File

@ -4845,6 +4845,22 @@ cont_current_key(void)
READ_UNLOCK(HashChain[i].AERWLock);
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) {
/* we have left the atom hash table */
/* we don't have a lock over the hash table any longer */

15
C/heapgc.c
View File

@ -1743,7 +1743,8 @@ mark_slots(CELL *ptr)
static void
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),
*lu_cl = NEXTOP(PredLogUpdClause->CodeOfPred,ld),
*su_cl = NEXTOP(PredStaticClause->CodeOfPred,ld);
@ -2017,6 +2018,17 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
case _retry_logical:
case _count_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 */
nargs = rtp->u.lld.t.s+1;
break;
@ -2024,6 +2036,7 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
case _count_trust_logical:
case _profiled_trust_logical:
/* mark timestamp */
mark_ref_in_use((DBRef)rtp->u.lld.t.block);
nargs = rtp->u.lld.d->ClPred->ArityOfPE+1;
break;
#ifdef DEBUG

31
C/index.c
View File

@ -11,8 +11,12 @@
* File: index.c *
* 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 $
* 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
* fixes for indexing code.
*
@ -776,7 +780,7 @@ delete_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
while (i < regs_count) {
if (regs[i] == copy) {
/* we found it */
regs[i] = regs[MAX_REG_COPIES-1];
regs[i] = regs[regs_count-1];
return regs_count-1;
}
i++;
@ -789,13 +793,12 @@ delete_regcopy(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
inline static int
regcopy_in(wamreg regs[MAX_REG_COPIES], int regs_count, wamreg copy)
{
int i = 0;
do {
int i;
for (i=0; i<regs_count; i++) {
if (regs[i] == copy) {
return TRUE;
}
i++;
} while (i < regs_count);
}
/* this copy could not be found */
return FALSE;
}
@ -1401,10 +1404,12 @@ add_info(ClauseDef *clause, UInt regno)
case _commit_b_x:
clause->Tag = (CELL)NULL;
return;
case _save_b_x:
case _write_x_val:
case _write_x_loc:
case _write_x_var:
cl = NEXTOP(cl,e);
break;
case _save_b_x:
case _put_list:
if (regcopy_in(myregs, nofregs, cl->u.x.x)) {
clause->Tag = (CELL)NULL;
@ -1772,6 +1777,10 @@ add_info(ClauseDef *clause, UInt regno)
} else {
nofregs = delete_regcopy(myregs, nofregs, cl->u.yx.x);
}
if (nofregs == 0 && !ycopy) {
clause->Tag = (CELL)NULL;
return;
}
cl = NEXTOP(cl,yx);
break;
case _get_y_val:
@ -5454,7 +5463,7 @@ expand_index(struct intermediates *cint) {
}
newpc = (yamop *)(fe->Label);
labp = (yamop **)(&(fe->Label));
labp = (yamop **)&(fe->Label);
if (newpc == e_code) {
/* we found it */
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;
}
#if defined(YAPOR) || defined(THREADS)
TR = B->cp_tr-1;
B->cp_tr--;
TR--;
LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl);
/* 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) &&
B->cp_tr != B->cp_b->cp_tr) {
TR = B->cp_tr-1;
B->cp_tr--;
TR--;
cl->ClFlags &= ~InUseMask;
/* next, recover space for the indexing code if it was erased */
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 ();
AtomHashTableSize = MaxHash;
WideAtomHashTableSize = MaxWideHash;
HashChain = (AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxHash);
if (HashChain == NULL) {
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);
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;
NOfWideAtoms = 0;
#if THREADS
SF_STORE->AtFoundVar = Yap_LookupAtom(".");
Yap_ReleaseAtom(AtomFoundVar);

593
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;
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:
varinfo = (VarEntry *) (Yap_tokptr->TokInfo);
if ((t = varinfo->VarAdr) == TermNil) {
@ -653,7 +668,7 @@ ParseTerm(int prio, JMPBUFF *FailBuff)
continue;
}
}
if (Yap_tokptr->Tok <= Ord(String_tok))
if (Yap_tokptr->Tok <= Ord(WString_tok))
FAIL;
break;
}

31
C/save.c
View File

@ -1301,6 +1301,25 @@ restore_heap(void)
do {
#ifdef DEBUG_RESTORE2 /* useful during debug */
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
at->PropsOfAE = PropAdjust(at->PropsOfAE);
RestoreEntries(RepProp(at->PropsOfAE));
@ -1343,6 +1362,18 @@ ShowAtoms()
}
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 */

147
C/scanner.c
View File

@ -57,7 +57,7 @@
STATIC_PROTO(int my_getch, (int (*) (int)));
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 */
static char chtype0[NUMBER_OF_CHARS+1] =
@ -231,8 +231,8 @@ read_int_overflow(const char *s, Int base, Int val)
#endif
}
static unsigned int
read_quoted_char(int *scan_nextp, int inp_stream, int (*QuotedNxtch)(int))
static wchar_t
read_quoted_char(int *scan_nextp, int inp_stream, wchar_t (*QuotedNxtch)(int))
{
int ch;
@ -273,6 +273,46 @@ read_quoted_char(int *scan_nextp, int inp_stream, int (*QuotedNxtch)(int))
return '\r';
case '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':
return '\v';
case '\\':
@ -415,7 +455,7 @@ read_quoted_char(int *scan_nextp, int inp_stream, int (*QuotedNxtch)(int))
/* reads a number, either integer or float */
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;
int ch = *chp;
@ -450,7 +490,7 @@ get_num(int *chp, int *chbuffp, int inp_stream, int (*Nxtch) (int), int (*Quoted
*sp++ = ch;
ch = Nxtch(inp_stream);
if (base == 0) {
Int ascii = ch;
wchar_t ascii = ch;
int scan_extra = TRUE;
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 */
if (scan_extra)
*chp = Nxtch(inp_stream);
return MkIntTerm(ascii);
return MkIntegerTerm(ascii);
} else if (base >= 10 && base <= 36) {
int upper_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
or end of file */
Term
Yap_scan_num(int (*Nxtch) (int))
Yap_scan_num(wchar_t (*Nxtch) (int))
{
Term out;
int sign = 1;
int ch, cherr;
wchar_t ch, cherr;
char *ptr;
Yap_ErrorMessage = NULL;
@ -655,7 +695,7 @@ Yap_scan_num(int (*Nxtch) (int))
Yap_clean_tokenizer(NULL, NULL, NULL);
return TermNil;
}
cherr = 0;
cherr = '\0';
if (ASP-H < 1024)
return TermNil;
out = get_num(&ch, &cherr, -1, Nxtch, Nxtch, ptr, 4096);
@ -672,15 +712,33 @@ Yap_scan_num(int (*Nxtch) (int))
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 *
Yap_tokenizer(int inp_stream)
{
TokEntry *t, *l, *p;
enum TokenKinds kind;
int solo_flag = TRUE;
int ch;
int (*Nxtch) (int) = Stream[inp_stream].stream_getc_for_read;
int (*QuotedNxtch) (int) = Stream[inp_stream].stream_getc;
wchar_t ch, *wcharp;
wchar_t (*Nxtch) (int) = Stream[inp_stream].stream_wgetc_for_read;
wchar_t (*QuotedNxtch) (int) = Stream[inp_stream].stream_wgetc;
Yap_ErrorMessage = NULL;
Yap_Error_Size = 0;
@ -694,7 +752,8 @@ Yap_tokenizer(int inp_stream)
LOCK(Stream[inp_stream].streamlock);
ch = Nxtch(inp_stream);
do {
int och, quote, isvar;
wchar_t och;
int quote, isvar;
char *charp, *mp;
unsigned int len;
char *TokImage = NULL;
@ -785,7 +844,8 @@ Yap_tokenizer(int inp_stream)
case NU:
{
int cherr, cha = ch;
wchar_t cherr;
wchar_t cha = ch;
char *ptr;
cherr = 0;
@ -915,12 +975,18 @@ Yap_tokenizer(int inp_stream)
quote = ch;
len = 0;
ch = QuotedNxtch(inp_stream);
while (1) {
wcharp = NULL;
while (TRUE) {
if (charp + 1024 > (char *)AuxSp) {
Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
Yap_ErrorMessage = "Heap Overflow While Scanning: please increase code space (-h)";
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) {
/* in ISO a new line terminates a string */
Yap_ErrorMessage = "layout character \n inside quotes";
@ -930,11 +996,25 @@ Yap_tokenizer(int inp_stream)
ch = QuotedNxtch(inp_stream);
if (ch != quote)
break;
*charp++ = ch;
if (wcharp)
*wcharp++ = ch;
else
*charp++ = ch;
ch = QuotedNxtch(inp_stream);
} else if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
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) {
ch = QuotedNxtch(inp_stream);
}
@ -943,7 +1023,10 @@ Yap_tokenizer(int inp_stream)
t->Tok = Ord(kind = eot_tok);
break;
} else {
*charp++ = ch;
if (wcharp)
*wcharp++ = ch;
else
*charp++ = ch;
ch = QuotedNxtch(inp_stream);
}
++len;
@ -958,9 +1041,16 @@ Yap_tokenizer(int inp_stream)
return l;
}
}
*charp = '\0';
if (wcharp)
*wcharp++ = '\0';
else
*charp = '\0';
if (quote == '"') {
mp = AllocScannerMemory(len + 1);
if (wcharp) {
mp = AllocScannerMemory(sizeof(wchar_t)*(len+1));
} else {
mp = AllocScannerMemory(len + 1);
}
if (mp == NULL) {
UNLOCK(Stream[inp_stream].streamlock);
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);
return l;
}
strcpy(mp, TokImage);
if (wcharp)
wcscpy((wchar_t *)mp,(wchar_t *)TokImage);
else
strcpy(mp, TokImage);
t->TokInfo = Unsigned(mp);
Yap_ReleasePreAllocCodeSpace((CODEADDR)TokImage);
t->Tok = Ord(kind = String_tok);
if (wcharp) {
t->Tok = Ord(kind = WString_tok);
} else {
t->Tok = Ord(kind = String_tok);
}
} else {
t->TokInfo = Unsigned(Yap_LookupAtom(TokImage));
if (wcharp) {
t->TokInfo = Unsigned(Yap_LookupWideAtom((wchar_t *)TokImage));
} else {
t->TokInfo = Unsigned(Yap_LookupAtom(TokImage));
}
Yap_ReleasePreAllocCodeSpace((CODEADDR)TokImage);
t->Tok = Ord(kind = Name_tok);
if (ch == '(')

916
C/stdpreds.c
View File

File diff suppressed because it is too large Load Diff

2
C/userpreds.c
View File

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

254
C/write.c
View File

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

8
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* 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 */
@ -546,6 +546,9 @@ typedef struct various_codes {
#endif
UInt n_of_atoms;
UInt atom_hash_table_size;
UInt wide_atom_hash_table_size;
UInt n_of_wide_atoms;
AtomHashEntry *wide_hash_chain;
AtomHashEntry *hash_chain;
} all_heap_codes;
@ -635,6 +638,9 @@ struct various_codes *Yap_heap_regs;
#define NOfAtoms Yap_heap_regs->n_of_atoms
#define AtomHashTableSize Yap_heap_regs->atom_hash_table_size
#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_TIMESTAMP Yap_heap_regs->int_keys_timestamp
#define INT_KEYS Yap_heap_regs->IntKeys

3
H/Yap.h
View File

@ -10,7 +10,7 @@
* File: Yap.h.m4 *
* mods: *
* 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"
@ -1102,6 +1102,7 @@ TailOfTermCell (Term t)
/*************** variables concerned with atoms table *******************/
#define MaxHash 1001
#define MaxWideHash (MaxHash/10+1)
#define FAIL_RESTORE 0
#define DO_EVERYTHING 1

74
H/Yatom.h
View File

@ -189,6 +189,7 @@ IsFunctorProperty (int flags)
ff df sparse functor
ff ex arithmetic property
ff f7 array
ff f8 wide atom
ff fa module property
ff fb blackboard 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 */
typedef struct
{

12
H/iopreds.h
View File

@ -29,6 +29,8 @@ static char SccsId[] = "%W% %G%";
#endif
#include <wchar.h>
#if HAVE_LIBREADLINE
#if _MSC_VER || defined(__MINGW32__)
@ -76,7 +78,7 @@ typedef struct stream_desc
} u;
Int charcount, linecount, linepos;
Int status;
Int och;
wchar_t och;
#if defined(YAPOR) || defined(THREADS)
lockvar streamlock; /* protect stream access */
#endif
@ -85,7 +87,12 @@ typedef struct stream_desc
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
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;
@ -115,6 +122,7 @@ StreamDesc;
#define InMemory_Stream_f 0x020000
#define Pipe_Stream_f 0x040000
#define Popen_Stream_f 0x080000
#define User_Stream_f 0x100000
#define StdInStream 0
#define StdOutStream 1

15
H/rclause.h
View File

@ -12,8 +12,11 @@
* File: rclause.h *
* 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 $
* 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
* improve indexing on floats
* fix sending large lists to DB
@ -170,15 +173,19 @@ restore_opcodes(yamop *pc)
break;
case _try_logical:
case _retry_logical:
case _trust_logical:
case _count_retry_logical:
case _count_trust_logical:
case _profiled_retry_logical:
case _profiled_trust_logical:
pc->u.lld.n = PtoOpAdjust(pc->u.lld.n);
pc->u.lld.d = PtoLUClauseAdjust(pc->u.lld.d);
pc = pc->u.lld.n;
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:
pc->u.Ill.I = (LogUpdIndex *)PtoOpAdjust((yamop *)(pc->u.Ill.I));
pc->u.Ill.l1 = PtoOpAdjust(pc->u.Ill.l1);

7
H/rheap.h
View File

@ -11,8 +11,11 @@
* File: rheap.h *
* 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 $
* Revision 1.70 2006/08/25 19:50:35 vsc
* global data structures
*
* Revision 1.69 2006/08/22 16:12:46 vsc
* global variables
*
@ -777,6 +780,8 @@ restore_codes(void)
PtoPredAdjust(Yap_heap_regs->logdb_erased_marker->ClPred);
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);
}
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 *);

38
H/yapio.h
View File

@ -169,6 +169,7 @@ enum TokenKinds {
Number_tok,
Var_tok,
String_tok,
WString_tok,
Ponctuation_tok,
Error_tok,
eot_tok
@ -243,6 +244,20 @@ typedef struct AliasDescS {
int alias_stream;
} * 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 **************************/
#define NUMBER_OF_CHARS 256
extern char *Yap_chtype;
@ -257,7 +272,7 @@ Term STD_PROTO(Yap_VarNames,(VarEntry *,Term));
/* routines in scanner.c */
TokEntry STD_PROTO(*Yap_tokenizer,(int));
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));
/* routines in iopreds.c */
@ -267,6 +282,7 @@ int STD_PROTO(Yap_GetStreamFd,(int));
void STD_PROTO(Yap_CloseStreams,(int));
void STD_PROTO(Yap_CloseStream,(int));
int STD_PROTO(Yap_PlGetchar,(void));
wchar_t STD_PROTO(Yap_PlGetWchar,(void));
int STD_PROTO(Yap_PlFGetchar,(void));
int STD_PROTO(Yap_GetCharForSIGINT,(void));
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_TermToString,(Term,char *,unsigned int,int));
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
Yap_c_input_stream,
@ -297,7 +318,7 @@ extern int
#define To_heap_f 16
/* 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 */
int STD_PROTO(Yap_growstack_in_parser, (tr_fr_ptr *, TokEntry **, VarEntry **));
@ -318,6 +339,7 @@ extern int Yap_Portray_delays;
#endif
EXTERN inline UInt STD_PROTO(HashFunction, (unsigned char *));
EXTERN inline UInt STD_PROTO(WideHashFunction, (wchar_t *));
EXTERN inline UInt
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 QUIET_ON_PARSER_ERROR 1
#define CONTINUE_ON_PARSER_ERROR 2

4
changes-5.1.html
View File

@ -16,6 +16,10 @@
<h2>Yap-5.1.2:</h2>
<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: mess with EOF and open (obs from Nicos Angelopoulos).</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
cd ../../../include
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 ../../../bins/cyg/*.h .
#/bin/mv config.h.mine config.h
cd ../console
cd ../../../console
splat
cd ../docs
splat

10
pl/boot.yap
View File

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

64
pl/consult.yap
View File

@ -41,7 +41,12 @@ load_files(Files,Opts) :-
'$process_lf_opts'(V,_,_,_,_,_,_,_,_,_,_,_,Call) :-
var(V), !,
'$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_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).
@ -61,8 +66,15 @@ load_files(Files,Opts) :-
( atom(Files) -> true ; '$do_error'(type_error(atom,Files),Call) ),
/* call make */
'$do_error'(domain_error(unimplemented_option,derived_from),Call).
'$process_lf_opt'(encoding(Encoding),_,_,_,_,_,_,_,_,_,_,_,Call) :-
'$do_error'(domain_error(unimplemented_option,encoding),Call).
'$process_lf_opt'(encoding(Encoding),_,_,_,_,_,_,_,_,EncCode,_,_,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) :-
'$do_error'(domain_error(unimplemented_option,expand),Call).
'$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).
'$lf'(user_input, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,SkipUnixComments,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),
'$open'(Y, '$csult', Stream, 0), !,
'$open'(Y, '$csult', Stream, 0, Enc), !,
'$set_changed_lfmode'(Changed),
'$start_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, Changed,SkipUnixComments,Reconsult,UseModule),
'$close'(Stream).
@ -305,7 +317,8 @@ use_module(M,F,Is) :-
'$values'('$included_file',OY,Y),
'$current_module'(Mod),
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)),
'$loop'(Stream,Status), '$close'(Stream)
;
@ -367,7 +380,8 @@ prolog_load_context(term_position, Position) :-
'$use_preds'(Imports,P, NM, M).
'$ensure_file_loaded'(F, M, _) :-
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
% be imported from any module.
@ -481,3 +495,39 @@ remove_from_path(New) :- '$check_path'(New,Path),
getenv('YAPSHAREDIR', Dir).
'$system_library_directories'(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'(thread_local(_)).
'$directive'(uncutable(_)).
'$directive'(encoding(_)).
'$exec_directives'((G1,G2), Mode, M) :- !,
'$exec_directives'(G1, Mode, M),
@ -64,6 +65,8 @@
'$discontiguous'(D,M).
'$exec_directive'(initialization(D), _, M) :-
'$initialization'(M:D).
'$exec_directive'(encoding(Enc), _, M) :-
'$current_encoding'(Enc).
'$exec_directive'(parallel, _, _) :-
'$parallel'.
'$exec_directive'(sequential, _, _) :-
@ -131,6 +134,16 @@ yap_flag(argv,L) :- '$argv'(L).
yap_flag(hide,Atom) :- !, hide(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
yap_flag(gc,V) :-
var(V), !,
@ -647,6 +660,7 @@ yap_flag(float_format,X) :-
V = discontiguous_warnings ;
V = dollar_as_lower_case ;
V = double_quotes ;
V = encoding ;
% V = fast ;
V = fileerrors ;
V = float_format ;

1
pl/init.yap
View File

@ -34,7 +34,6 @@ otherwise.
[] :- true.
:- set_value('$doindex',true).
% 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).
'$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) :-
'$do_error'(type_error(list,T),G).

2
pl/utils.yap
View File

@ -323,6 +323,8 @@ current_atom(A) :- % check
atom(A), !.
current_atom(A) :- % generate
'$current_atom'(A).
current_atom(A) :- % generate
'$current_wide_atom'(A).
current_predicate(A,T) :- var(T), !, % only for the predicate
'$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), !,
'$do_error'(type_error(variable,T),open(Source,M,T)).
open(File,Mode,Stream) :-
'$open'(File,Mode,Stream,16).
'$default_encoding'(Encoding),
'$open'(File,Mode,Stream,16,Encoding).
/* meaning of flags for '$write' is
1 quote illegal atoms
@ -58,42 +59,46 @@ close(S,Opts) :-
open(F,T,S,Opts) :-
'$check_io_opts'(Opts,open(F,T,S,Opts)),
'$process_open_opts'(Opts, 0, N, Aliases),
'$open2'(F,T,S,N),
'$process_open_opts'(Opts, 0, N, Aliases, E),
'$open2'(F,T,S,N,E),
'$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)).
'$open2'(Source,M,T,N) :- var(M), !,
'$open2'(Source,M,T,N,_) :- var(M), !,
'$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)).
'$open2'(File,Mode,Stream,N) :-
'$open'(File,Mode,Stream,N).
'$open2'(File,Mode,Stream,N,Encoding) :-
'$open'(File,Mode,Stream,N,Encoding).
'$process_open_aliases'([],_).
'$process_open_aliases'([Alias|Aliases],S) :-
'$add_alias_to_stream'(Alias, S),
'$process_open_aliases'(Aliases,S).
'$process_open_opts'([], N, N, []).
'$process_open_opts'([type(T)|L], N0, N, Aliases) :-
'$process_open_opts'([], N, N, [], DefaultEncoding) :-
'$default_encoding'(DefaultEncoding).
'$process_open_opts'([type(T)|L], N0, N, Aliases, Encoding) :-
'$value_open_opt'(T,type,I1,I2),
N1 is I1\/N0,
N2 is I2/\N1,
'$process_open_opts'(L,N2,N, Aliases).
'$process_open_opts'([reposition(T)|L], N0, N, Aliases) :-
'$process_open_opts'(L,N2,N, Aliases, Encoding).
'$process_open_opts'([reposition(T)|L], N0, N, Aliases, Encoding) :-
'$value_open_opt'(T,reposition,I1,I2),
N1 is I1\/N0,
N2 is I2/\N1,
'$process_open_opts'(L,N2,N, Aliases).
'$process_open_opts'([eof_action(T)|L], N0, N, Aliases) :-
'$process_open_opts'(L,N2,N, Aliases, Encoding).
'$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),
N1 is I1\/N0,
N2 is I2/\N1,
'$process_open_opts'(L,N2,N, Aliases).
'$process_open_opts'([alias(Alias)|L], N0, N, [Alias|Aliases]) :-
'$process_open_opts'(L,N0,N, Aliases).
'$process_open_opts'(L,N2,N, Aliases, Encoding).
'$process_open_opts'([alias(Alias)|L], N0, N, [Alias|Aliases], Encoding) :-
'$process_open_opts'(L,N0,N, Aliases, Encoding).
'$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_opt_open'(eof_action(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) :-
'$do_error'(domain_error(stream_option,A),G).
@ -223,6 +230,12 @@ open(F,T,S,Opts) :-
'$check_open_eof_action_arg'(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), !,
'$do_error'(instantiation_error,G).
'$check_read_syntax_errors_arg'(dec10,_) :- !.
@ -584,26 +597,26 @@ peek_char(S,V) :-
( I = -1 -> V = end_of_file ; atom_codes(V,[I])).
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)).
get_code(S,V) :-
'$get0'(S,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)).
get_code(V) :-
current_input(S),
'$get0'(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)).
peek_code(S,V) :-
'$peek'(S,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)).
peek_code(V) :-
current_input(S),
@ -649,7 +662,7 @@ put_char(S,V) :-
put_code(V) :- var(V), !,
'$do_error'(instantiation_error,put_code(V)).
put_code(V) :-
(\+ integer(V) ; V < 0 ; V > 256), !,
(\+ integer(V)), !,
'$do_error'(type_error(character_code,V),put_code(V)).
put_code(V) :-
current_output(S),
@ -659,7 +672,7 @@ put_code(V) :-
put_code(S,V) :- var(V), !,
'$do_error'(instantiation_error,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)).
put_code(S,V) :-
'$put'(S,V).
@ -904,7 +917,7 @@ absolute_file_name(RelFile, AbsFile) :-
'$exists'(F,Mode,AbsFile) :-
get_value(fileerrors,V),
set_value(fileerrors,0),
( '$open'(F,Mode,S,0), !,
( '$open'(F,Mode,S,0,0), !,
'$file_name'(S, AbsFile),
'$close'(S), set_value(fileerrors,V);
set_value(fileerrors,V), fail).