diff --git a/C/absmi.c b/C/absmi.c index aad8b9fce..eab69a0de 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -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 diff --git a/C/adtdefs.c b/C/adtdefs.c index 9ba6c57a3..799e71fc7 100644 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -33,6 +33,7 @@ Prop STD_PROTO(PredPropByAtom,(Atom, Term)); #include "Heap.h" #include "yapio.h" #include +#include #if HAVE_STRING_H #include #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) { diff --git a/C/agc.c b/C/agc.c index 400f682eb..baaa6be9c 100644 --- a/C/agc.c +++ b/C/agc.c @@ -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); diff --git a/C/c_interface.c b/C/c_interface.c index c1b464c1e..5dd8067b2 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -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(); diff --git a/C/cdmgr.c b/C/cdmgr.c index 48f71f442..da3951b1e 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -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) diff --git a/C/cmppreds.c b/C/cmppreds.c index b9944a247..a56bd9671 100644 --- a/C/cmppreds.c +++ b/C/cmppreds.c @@ -25,6 +25,7 @@ static char SccsId[] = "%W% %G%"; #if HAVE_STRING_H #include #endif +#include 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 diff --git a/C/dbase.c b/C/dbase.c index 1351ec15d..ae0d92730 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -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 */ diff --git a/C/heapgc.c b/C/heapgc.c index bd23a0a15..fe845d561 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -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 diff --git a/C/index.c b/C/index.c index afcf551c2..836380c0b 100644 --- a/C/index.c +++ b/C/index.c @@ -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; iTag = (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)) { diff --git a/C/init.c b/C/init.c index 888a2cca6..f59161213 100644 --- a/C/init.c +++ b/C/init.c @@ -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); diff --git a/C/iopreds.c b/C/iopreds.c index 4c2f09e18..15742a383 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -99,7 +99,7 @@ STATIC_PROTO (int PlGetc, (int)); STATIC_PROTO (int DefaultGets, (int,UInt,char*)); STATIC_PROTO (int PlGets, (int,UInt,char*)); STATIC_PROTO (int MemGetc, (int)); -STATIC_PROTO (int ISOGetc, (int)); +STATIC_PROTO (wchar_t ISOWGetc, (int)); STATIC_PROTO (int ConsoleGetc, (int)); STATIC_PROTO (int PipeGetc, (int)); STATIC_PROTO (int ConsolePipeGetc, (int)); @@ -166,6 +166,28 @@ STATIC_PROTO (Int p_startline, (void)); STATIC_PROTO (Int p_change_type_of_char, (void)); STATIC_PROTO (Int p_type_of_char, (void)); STATIC_PROTO (void CloseStream, (int)); +STATIC_PROTO (wchar_t get_wchar, (int)); +STATIC_PROTO (wchar_t put_wchar, (int,wchar_t)); + +static encoding_t +DefaultEncoding(void) +{ + char *s = getenv("LANG"); + /* if we don't have a LNAG then just use ISO_LATIN1 */ + if (s == NULL) + return ENC_ISO_LATIN1; + int sz = strlen(s); + if (sz > 5) { + if (s[sz-5] == 'U' && + s[sz-4] == 'T' && + s[sz-3] == 'F' && + s[sz-2] == '-' && + s[sz-1] == '8') { + return ENC_ISO_UTF8; + } + } + return ENC_ISO_ANSI; +} static int GetFreeStreamD(void) @@ -188,6 +210,25 @@ Yap_GetFreeStreamD(void) return GetFreeStreamD(); } +/* used from C-interface */ +int +Yap_GetFreeStreamDForReading(void) +{ + int sno = GetFreeStreamD(); + StreamDesc *s; + + if (sno < 0) return sno; + s = Stream+sno; + s->status |= User_Stream_f|Input_Stream_f; + s->stream_wgetc = get_wchar; + s->encoding = DefaultEncoding(); + if (CharConversionTable != NULL) + s->stream_wgetc_for_read = ISOWGetc; + else + s->stream_wgetc_for_read = s->stream_wgetc; + return sno; +} + static int yap_fflush(int sno) @@ -304,6 +345,7 @@ p_always_prompt_user(void) if (Stream[0].status & Tty_Stream_f && s->u.file.name == Stream[0].u.file.name) s->stream_putc = ReadlinePutc; + s->stream_wputc = put_wchar; } else #endif { @@ -351,27 +393,32 @@ InitStdStream (int sno, SMALLUNSGN flags, YP_File file) if (s->status & Socket_Stream_f) { /* Console is a socket and socket will prompt */ s->stream_putc = ConsoleSocketPutc; + s->stream_wputc = put_wchar; s->stream_getc = ConsoleSocketGetc; } else #endif if (s->status & Pipe_Stream_f) { /* Console is a socket and socket will prompt */ s->stream_putc = ConsolePipePutc; + s->stream_wputc = put_wchar; s->stream_getc = ConsolePipeGetc; } else if (s->status & InMemory_Stream_f) { s->stream_putc = MemPutc; + s->stream_wputc = put_wchar; s->stream_getc = MemGetc; } else { /* check if our console is promptable: may be tty or pipe */ if (s->status & (Promptable_Stream_f)) { /* the putc routine only has to check it is putting out a newline */ s->stream_putc = ConsolePutc; + s->stream_wputc = put_wchar; /* if a tty have a special routine to call readline */ #if HAVE_LIBREADLINE if (s->status & Tty_Stream_f) { if (Stream[0].status & Tty_Stream_f && is_same_tty(s->u.file.file,Stream[0].u.file.file)) s->stream_putc = ReadlinePutc; + s->stream_wputc = put_wchar; s->stream_getc = ReadlineGetc; } else #endif @@ -382,6 +429,7 @@ InitStdStream (int sno, SMALLUNSGN flags, YP_File file) } else { /* we are reading from a file, no need to check for prompts */ s->stream_putc = FilePutc; + s->stream_wputc = put_wchar; s->stream_getc = PlGetc; s->stream_gets = PlGetsFunc(); } @@ -398,10 +446,11 @@ InitStdStream (int sno, SMALLUNSGN flags, YP_File file) } s->u.file.user_name = MkAtomTerm (s->u.file.name); } + s->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - s->stream_getc_for_read = ISOGetc; + s->stream_wgetc_for_read = ISOWGetc; else - s->stream_getc_for_read = s->stream_getc; + s->stream_wgetc_for_read = s->stream_wgetc; #if LIGHT s->status |= Tty_Stream_f|Promptable_Stream_f; #endif @@ -776,7 +825,7 @@ ConsolePipePutc (int sno, int ch) DWORD written; if (WriteFile(s->u.pipe.hdl, &c, sizeof(c), &written, NULL) == FALSE) { PlIOError (SYSTEM_ERROR,TermNil, "write to pipe returned error"); - return(EOF); + return EOF; } } #else @@ -802,7 +851,7 @@ PipePutc (int sno, int ch) DWORD written; if (WriteFile(s->u.pipe.hdl, &c, sizeof(c), &written, NULL) == FALSE) { PlIOError (SYSTEM_ERROR,TermNil, "write to pipe returned error"); - return(EOF); + return EOF; } } #else @@ -954,7 +1003,7 @@ ReadlineGetc(int sno) while (ttyptr == NULL) { /* Only sends a newline if we are at the start of a line */ - if (myrl_line != NULL && myrl_line != (char *) EOF) + if (myrl_line) free (myrl_line); rl_instream = Stream[sno].u.file.file; rl_outstream = Stream[cur_out_sno].u.file.file; @@ -1002,7 +1051,7 @@ ReadlineGetc(int sno) newline=FALSE; strncpy (Prompt, RepAtom (*AtPrompt)->StrOfAE, MAX_PROMPT); /* window of vulnerability closed */ - if (myrl_line == NULL || myrl_line == (char *) EOF) + if (myrl_line == NULL) return(console_post_process_read_char(EOF, s)); if (myrl_line[0] != '\0' && myrl_line[1] != '\0') add_history (myrl_line); @@ -1012,7 +1061,8 @@ ReadlineGetc(int sno) ttyptr = NIL; ch = '\n'; } else { - ch = *ttyptr++; + ch = *((unsigned char *)ttyptr); + ttyptr++; } return(console_post_process_read_char(ch, s)); } @@ -1031,7 +1081,7 @@ Yap_GetCharForSIGINT(void) myrl_line = NULL; } else { myrl_line = readline ("Action (h for help): "); - if (myrl_line == (char *)NULL || myrl_line == (char *)EOF) { + if (!myrl_line) { ch = EOF; } else { ch = myrl_line[0]; @@ -1059,7 +1109,7 @@ EOFGetc(int sno) if (s->status & Push_Eof_Stream_f) { /* ok, we have pushed an EOF, send it away */ s->status &= ~Push_Eof_Stream_f; - return(EOF); + return EOF; } if (s->status & Eof_Error_Stream_f) { Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM,MkAtomTerm(s->u.file.name), @@ -1075,6 +1125,7 @@ EOFGetc(int sno) s->stream_putc = ConsoleSocketPutc; else s->stream_putc = SocketPutc; + s->stream_wputc = put_wchar; } else #endif if (s->status & Pipe_Stream_f) { @@ -1082,11 +1133,14 @@ EOFGetc(int sno) s->stream_putc = ConsolePipePutc; else s->stream_putc = PipePutc; + s->stream_wputc = put_wchar; } else if (s->status & InMemory_Stream_f) { s->stream_getc = MemGetc; s->stream_putc = MemPutc; + s->stream_wputc = put_wchar; } else if (s->status & Promptable_Stream_f) { s->stream_putc = ConsolePutc; + s->stream_wputc = put_wchar; #if HAVE_LIBREADLINE if (s->status & Tty_Stream_f) { s->stream_getc = ReadlineGetc; @@ -1102,12 +1156,11 @@ EOFGetc(int sno) s->stream_getc = PlGetc; s->stream_gets = PlGetsFunc(); } + s->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - s->stream_getc_for_read = ISOGetc; + s->stream_wgetc_for_read = ISOWGetc; else - s->stream_getc_for_read = s->stream_getc; - if (CharConversionTable != NULL) - s->stream_getc = ISOGetc; + s->stream_wgetc_for_read = s->stream_wgetc; /* next, reset our own error indicator */ s->status &= ~Eof_Stream_f; /* try reading again */ @@ -1115,7 +1168,7 @@ EOFGetc(int sno) } else { s->status |= Past_Eof_Stream_f; } - return (EOF); + return EOF; } /* check if we read a newline or an EOF */ @@ -1132,16 +1185,17 @@ post_process_read_char(int ch, StreamDesc *s) } else if (ch == EOF) { s->status |= Eof_Stream_f; s->stream_getc = EOFGetc; + s->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - s->stream_getc_for_read = ISOGetc; + s->stream_wgetc_for_read = ISOWGetc; else - s->stream_getc_for_read = s->stream_getc; - return (EOFCHAR); + s->stream_wgetc_for_read = s->stream_wgetc; + return EOFCHAR; } else { ++s->charcount; ++s->linepos; } - return(ch); + return ch; } /* check if we read a newline or an EOF */ @@ -1156,10 +1210,11 @@ console_post_process_read_char(int ch, StreamDesc *s) } else if (ch == EOF) { s->status |= Eof_Stream_f; s->stream_getc = EOFGetc; + s->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - s->stream_getc_for_read = ISOGetc; + s->stream_wgetc_for_read = ISOWGetc; else - s->stream_getc_for_read = s->stream_getc; + s->stream_wgetc_for_read = s->stream_wgetc; newline = FALSE; return (EOFCHAR); } else { @@ -1201,7 +1256,7 @@ SocketGetc(int sno) Yap_Error(SYSTEM_ERROR, TermNil, "(socket_getc)"); #endif - return(EOF); + return EOF; } return(post_process_read_char(ch, s)); } @@ -1259,7 +1314,7 @@ PipeGetc(int sno) DWORD count; if (WriteFile(s->u.pipe.hdl, &c, sizeof(c), &count, NULL) == FALSE) { PlIOError (SYSTEM_ERROR,TermNil, "write to pipe returned error"); - return(EOF); + return EOF; } #else int count; @@ -1393,19 +1448,18 @@ MemGetc (int sno) } /* I dispise this code!!!!! */ -static int -ISOGetc (int sno) +static wchar_t +ISOWGetc (int sno) { - int ch = Stream[sno].stream_getc(sno); + wchar_t ch = Stream[sno].stream_wgetc(sno); if (ch != EOF && CharConversionTable != NULL) { - int nch; - nch = CharConversionTable[ch]; - if (nch != '\0') { - ch = nch; + if (ch < NUMBER_OF_CHARS) { + /* only do this in ASCII */ + return CharConversionTable[ch]; } } - return(ch); + return ch; } /* send a prompt, and use the system for internal buffering. Speed is @@ -1465,14 +1519,17 @@ PlUnGetc (int sno) if (s->status & InMemory_Stream_f) { s->stream_getc = MemGetc; s->stream_putc = MemPutc; + s->stream_wputc = put_wchar; } else if (s->status & Promptable_Stream_f) { s->stream_putc = ConsolePutc; + s->stream_wputc = put_wchar; #if HAVE_LIBREADLINE if (s->status & Tty_Stream_f) { s->stream_getc = ReadlineGetc; if (Stream[0].status & Tty_Stream_f && is_same_tty(s->u.file.file,Stream[0].u.file.file)) s->stream_putc = ReadlinePutc; + s->stream_wputc = put_wchar; } else #endif { @@ -1484,6 +1541,187 @@ PlUnGetc (int sno) return(post_process_read_char(ch, s)); } +static int +utf8_nof(char ch) +{ + if (!(ch & 0x20)) + return 1; + if (!(ch & 0x10)) + return 2; + if (!(ch & 0x08)) + return 3; + if (!(ch & 0x04)) + return 4; + return 5; +} + +static wchar_t +get_wchar(int sno) +{ + wchar_t wch; + int ch; + int how_many = 0; + + while (TRUE) { + ch = Stream[sno].stream_getc(sno); + if (ch == -1) { + if (how_many) { + /* error */ + } + return EOF; + } + switch (Stream[sno].encoding) { + case ENC_OCTET: + return ch; + case ENC_ISO_LATIN1: + return ch; + case ENC_ISO_ASCII: + if (ch & 0x80) { + /* error */ + } + return ch; + case ENC_ISO_ANSI: + { + char buf[1]; + int out; + + if (!how_many) { + memset((void *)&(Stream[sno].mbstate), 0, sizeof(mbstate_t)); + } + buf[0] = ch; + if ((out = mbrtowc(&wch, buf, 1, &(Stream[sno].mbstate))) == 1) + return wch; + if (out == -1) { + /* error */ + } + how_many++; + break; + } + case ENC_ISO_UTF8: + { + if (!how_many) { + if (ch & 0x80) { + how_many = utf8_nof(ch); + /* + keep a backup of the start character in case we meet an error, + useful if we are scanning ISO files. + */ + Stream[sno].och = ch; + wch = (ch & ((1<<(6-how_many))-1))<<(6*how_many); + } else { + return ch; + } + } else { + how_many--; + if ((ch & 0xc0) == 0x80) { + wch += (ch & ~0xc0) << (how_many*6); + } else { + /* error */ + /* try to recover character, assume this is our first character */ + wchar_t och = Stream[sno].och; + + Stream[sno].och = ch; + Stream[sno].stream_getc = PlUnGetc; + Stream[sno].stream_wgetc = get_wchar; + return och; + } + if (!how_many) { + return wch; + } + } + } + break; + case ENC_UNICODE_BE: + if (how_many) { + return wch+ch; + } + how_many=1; + wch = ch << 8; + break; + case ENC_UNICODE_LE: + if (how_many) { + return wch+(ch<<8); + } + how_many=1; + ch = ch; + break; + } + } + return EOF; +} + +#ifndef MB_LEN_MAX +#define MB_LEN_MAX 6 +#endif + +static wchar_t +put_wchar(int sno, wchar_t ch) +{ + + /* pass the bug if we can */ + if (ch < 0x80) + return Stream[sno].stream_putc(sno, ch); + switch (Stream[sno].encoding) { + case ENC_OCTET: + return Stream[sno].stream_putc(sno, ch); + case ENC_ISO_LATIN1: + if (ch >= 0xff) { + /* error */ + } + return Stream[sno].stream_putc(sno, ch); + case ENC_ISO_ASCII: + if (ch >= 0x80) { + /* error */ + } + return Stream[sno].stream_putc(sno, ch); + case ENC_ISO_ANSI: + { + char buf[MB_LEN_MAX]; + int n; + + memset((void *)&(Stream[sno].mbstate), 0, sizeof(mbstate_t)); + if ( (n = wcrtomb(buf, ch, &(Stream[sno].mbstate))) < 0 ) { + /* error */ + Stream[sno].stream_putc(sno, ch); + return -1; + } else { + int i; + + for (i =0; i< n; i++) { + Stream[sno].stream_putc(sno, buf[i]); + } + return ch; + } + case ENC_ISO_UTF8: + { + if (ch < 0x800) { + Stream[sno].stream_putc(sno, 0xC0 | ch>>6); + return Stream[sno].stream_putc(sno, 0x80 | (ch & 0x3F)); + } else if (ch < 0x10000) { + Stream[sno].stream_putc(sno, 0xE0 | ch>>12); + Stream[sno].stream_putc(sno, 0x80 | (ch>>6 & 0x3F)); + return Stream[sno].stream_putc(sno, 0x80 | (ch & 0x3F)); + } else if (ch < 0x200000) { + Stream[sno].stream_putc(sno, 0xF0 | ch>>18); + Stream[sno].stream_putc(sno, 0x80 | (ch>>12 & 0x3F)); + Stream[sno].stream_putc(sno, 0x80 | (ch>>6 & 0x3F)); + return Stream[sno].stream_putc(sno, 0x80 | (ch & 0x3F)); + } else { + /* should never happen */ + return -1; + } + } + break; + case ENC_UNICODE_BE: + Stream[sno].stream_putc(sno, (ch>>8)); + return Stream[sno].stream_putc(sno, (ch&0xff)); + case ENC_UNICODE_LE: + Stream[sno].stream_putc(sno, (ch&0xff)); + return Stream[sno].stream_putc(sno, (ch>>8)); + } + } + return -1; +} /* used by user-code to read characters from the current input stream */ int @@ -1492,6 +1730,12 @@ Yap_PlGetchar (void) return(Stream[Yap_c_input_stream].stream_getc(Yap_c_input_stream)); } +wchar_t +Yap_PlGetWchar (void) +{ + return get_wchar(Yap_c_input_stream); +} + /* avoid using a variable to call a function */ int Yap_PlFGetchar (void) @@ -1601,12 +1845,14 @@ Yap_InitSocketStream(int fd, socket_info flags, socket_domain domain) { st->linecount = 1; st->linepos = 0; st->stream_putc = SocketPutc; + st->stream_wputc = put_wchar; st->stream_getc = SocketGetc; st->stream_gets = DefaultGets; + st->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - st->stream_getc_for_read = ISOGetc; + st->stream_wgetc_for_read = ISOWGetc; else - st->stream_getc_for_read = st->stream_getc; + st->stream_wgetc_for_read = st->stream_wgetc; return(MkStream(sno)); } @@ -1675,13 +1921,14 @@ binary_file(char *file_name) static Int p_open (void) { /* '$open'(+File,+Mode,?Stream,-ReturnCode) */ - Term file_name, t, t2, topts; + Term file_name, t, t2, topts, tenc; Atom open_mode; int sno; SMALLUNSGN s; char io_mode[8]; StreamDesc *st; Int opts; + UInt encoding; file_name = Deref(ARG1); /* we know file_name is bound */ @@ -1722,6 +1969,11 @@ p_open (void) if (IsVarTerm(topts) || !IsIntTerm(topts)) return(FALSE); opts = IntOfTerm(topts); + /* can never happen */ + tenc = Deref(ARG5); + if (IsVarTerm(tenc) || !IsIntTerm(tenc)) + return FALSE; + encoding = IntOfTerm(tenc); #ifdef _WIN32 if (st->status & Binary_Stream_f) { strncat(io_mode, "b", 8); @@ -1758,8 +2010,14 @@ p_open (void) st->u.file.user_name = file_name; st->linepos = 0; st->stream_putc = FilePutc; + st->stream_wputc = put_wchar; st->stream_getc = PlGetc; st->stream_gets = PlGetsFunc(); + if (st->status & Binary_Stream_f) { + st->encoding = ENC_OCTET; + } else { + st->encoding = encoding; + } unix_upd_stream_info (st); if (opts != 0) { if (opts & 2) @@ -1771,20 +2029,24 @@ p_open (void) #if USE_SOCKET if (st->status & Socket_Stream_f) { st->stream_putc = SocketPutc; + st->stream_wputc = put_wchar; st->stream_getc = SocketGetc; st->stream_gets = DefaultGets; } else #endif if (st->status & Pipe_Stream_f) { st->stream_putc = PipePutc; + st->stream_wputc = put_wchar; st->stream_getc = PipeGetc; st->stream_gets = DefaultGets; } else if (st->status & InMemory_Stream_f) { st->stream_putc = MemPutc; + st->stream_wputc = put_wchar; st->stream_getc = MemGetc; st->stream_gets = DefaultGets; } else { st->stream_putc = ConsolePutc; + st->stream_wputc = put_wchar; st->stream_getc = PlGetc; st->stream_gets = PlGetsFunc(); } @@ -1803,6 +2065,7 @@ p_open (void) } if (opts & 16) { st->status &= ~Reset_Eof_Stream_f; + st->status |= Eof_Error_Stream_f; } if (opts & 32) { st->status &= ~Reset_Eof_Stream_f; @@ -1813,10 +2076,11 @@ p_open (void) st->status |= Reset_Eof_Stream_f; } } + st->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - st->stream_getc_for_read = ISOGetc; + st->stream_wgetc_for_read = ISOWGetc; else - st->stream_getc_for_read = st->stream_getc; + st->stream_wgetc_for_read = st->stream_wgetc; t = MkStream (sno); st->status &= ~(Free_Stream_f); return (Yap_unify (ARG3, t)); @@ -1957,9 +2221,11 @@ p_open_null_stream (void) st->charcount = 0; st->linecount = 1; st->stream_putc = NullPutc; + st->stream_wputc = put_wchar; st->stream_getc = PlGetc; st->stream_gets = PlGetsFunc(); - st->stream_getc_for_read = PlGetc; + st->stream_wgetc = get_wchar; + st->stream_wgetc_for_read = get_wchar; st->u.file.user_name = MkAtomTerm (st->u.file.name = Yap_LookupAtom ("/dev/null")); t = MkStream (sno); return (Yap_unify (ARG1, t)); @@ -2005,21 +2271,25 @@ Yap_OpenStream(FILE *fd, char *name, Term file_name, int flags) st->stream_gets = PlGetsFunc(); if (flags & YAP_PIPE_STREAM) { st->stream_putc = PipePutc; + st->stream_wputc = put_wchar; st->stream_getc = PipeGetc; } else if (flags & YAP_TTY_STREAM) { st->stream_putc = ConsolePutc; + st->stream_wputc = put_wchar; st->stream_getc = ConsoleGetc; } else { st->stream_putc = FilePutc; + st->stream_wputc = put_wchar; st->stream_getc = PlGetc; unix_upd_stream_info (st); } + st->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - st->stream_getc_for_read = ISOGetc; + st->stream_wgetc_for_read = ISOWGetc; else - st->stream_getc_for_read = st->stream_getc; + st->stream_wgetc_for_read = st->stream_wgetc; t = MkStream (sno); - return (t); + return t; } static Int @@ -2057,12 +2327,14 @@ p_open_pipe_stream (void) st->charcount = 0; st->linecount = 1; st->stream_putc = PipePutc; + st->stream_wputc = put_wchar; st->stream_getc = PipeGetc; st->stream_gets = DefaultGets; + st->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - st->stream_getc_for_read = ISOGetc; + st->stream_wgetc_for_read = ISOWGetc; else - st->stream_getc_for_read = PipeGetc; + st->stream_wgetc_for_read = st->stream_wgetc; #if _MSC_VER || defined(__MINGW32__) st->u.pipe.hdl = ReadPipe; #else @@ -2077,12 +2349,14 @@ p_open_pipe_stream (void) st->charcount = 0; st->linecount = 1; st->stream_putc = PipePutc; + st->stream_wputc = put_wchar; st->stream_getc = PipeGetc; st->stream_gets = DefaultGets; + st->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - st->stream_getc_for_read = ISOGetc; + st->stream_wgetc_for_read = ISOWGetc; else - st->stream_getc_for_read = st->stream_getc; + st->stream_wgetc_for_read = st->stream_wgetc; #if _MSC_VER || defined(__MINGW32__) st->u.pipe.hdl = WritePipe; #else @@ -2109,12 +2383,14 @@ open_buf_read_stream(char *nbuf, Int nchars) st->charcount = 0; st->linecount = 1; st->stream_putc = MemPutc; + st->stream_wputc = put_wchar; st->stream_getc = MemGetc; st->stream_gets = DefaultGets; + st->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - st->stream_getc_for_read = ISOGetc; + st->stream_wgetc_for_read = ISOWGetc; else - st->stream_getc_for_read = MemGetc; + st->stream_wgetc_for_read = st->stream_wgetc; st->u.mem_string.pos = 0; st->u.mem_string.buf = nbuf; st->u.mem_string.max_size = nchars; @@ -2185,12 +2461,14 @@ open_buf_write_stream(char *nbuf, UInt sz) st->charcount = 0; st->linecount = 1; st->stream_putc = MemPutc; + st->stream_wputc = put_wchar; st->stream_getc = MemGetc; st->stream_gets = DefaultGets; + st->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - st->stream_getc_for_read = ISOGetc; + st->stream_wgetc_for_read = ISOWGetc; else - st->stream_getc_for_read = MemGetc; + st->stream_wgetc_for_read = st->stream_wgetc; st->u.mem_string.pos = 0; st->u.mem_string.buf = nbuf; st->u.mem_string.max_size = sz; @@ -2752,10 +3030,11 @@ p_peek_byte (void) s->och = ch; /* mark a special function to recover this character */ s->stream_getc = PlUnGetc; + s->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - s->stream_getc_for_read = ISOGetc; + s->stream_wgetc_for_read = ISOWGetc; else - s->stream_getc_for_read = s->stream_getc; + s->stream_wgetc_for_read = s->stream_wgetc; UNLOCK(s->streamlock); return(Yap_unify_constant(ARG2,MkIntTerm(ch))); } @@ -2784,16 +3063,11 @@ p_peek (void) /* sequence of peeks */ return Yap_unify_constant(ARG2,ch); } - if (status & Eof_Error_Stream_f) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM, ARG1, "peek/2"); - return FALSE; - } s = Stream+sno; ocharcount = s->charcount; olinecount = s->linecount; olinepos = s->linepos; - ch = Stream[sno].stream_getc(sno); + ch = get_wchar(sno); s->charcount = ocharcount; s->linecount = olinecount; s->linepos = olinepos; @@ -2801,10 +3075,11 @@ p_peek (void) s->och = ch; /* mark a special function to recover this character */ s->stream_getc = PlUnGetc; + s->stream_wgetc = get_wchar; if (CharConversionTable != NULL) - s->stream_getc_for_read = ISOGetc; + s->stream_wgetc_for_read = ISOWGetc; else - s->stream_getc_for_read = s->stream_getc; + s->stream_wgetc_for_read = s->stream_wgetc; UNLOCK(Stream[sno].streamlock); return(Yap_unify_constant(ARG2,MkIntTerm(ch))); } @@ -2882,7 +3157,7 @@ p_current_output (void) int beam_write (void) { Yap_StartSlots(); - Yap_plwrite (ARG1, Stream[Yap_c_output_stream].stream_putc, 0); + Yap_plwrite (ARG1, Stream[Yap_c_output_stream].stream_wputc, 0); if (EX != 0L) { Term ball = EX; EX = 0L; @@ -2900,7 +3175,7 @@ p_write (void) /* notice: we must have ASP well set when using portray, otherwise we cannot make recursive Prolog calls */ Yap_StartSlots(); - Yap_plwrite (ARG2, Stream[Yap_c_output_stream].stream_putc, flags); + Yap_plwrite (ARG2, Stream[Yap_c_output_stream].stream_wputc, flags); if (EX != 0L) { Term ball = EX; EX = 0L; @@ -2923,7 +3198,7 @@ p_write2 (void) /* notice: we must have ASP well set when using portray, otherwise we cannot make recursive Prolog calls */ Yap_StartSlots(); - Yap_plwrite (ARG3, Stream[Yap_c_output_stream].stream_putc, (int) IntOfTerm (Deref (ARG2))); + Yap_plwrite (ARG3, Stream[Yap_c_output_stream].stream_wputc, (int) IntOfTerm (Deref (ARG2))); Yap_c_output_stream = old_output_stream; if (EX != 0L) { Term ball = EX; @@ -3004,6 +3279,12 @@ syntax_error (TokEntry * tokptr) ts[0] = Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("string"),1),1,&t0); } break; + case WString_tok: + { + Term t0 = Yap_WStringToList((wchar_t *)info); + ts[0] = Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom("string"),1),1,&t0); + } + break; case Error_tok: case eot_tok: break; @@ -3333,7 +3614,7 @@ static Int static Int p_read (void) { /* '$read'(+Flag,?Term,?Module,?Vars,-Pos,-Err) */ - return(do_read(Yap_c_input_stream, 6)); + return do_read(Yap_c_input_stream, 6); } static Int @@ -3628,32 +3909,26 @@ static Int p_get (void) { /* '$get'(Stream,-N) */ int sno = CheckStream (ARG1, Input_Stream_f, "get/2"); - Int ch; + wchar_t ch; Int status; if (sno < 0) - return(FALSE); + return FALSE; if (Stream[sno].stream_getc == PlUnGetc) { ch = PlUnGetc(sno); if (ch <= 32 && ch >= 0) { /* done */ UNLOCK(Stream[sno].streamlock); - return (Yap_unify_constant (ARG2, MkIntTerm (ch))); + return Yap_unify_constant (ARG2, MkIntegerTerm (ch)); } } status = Stream[sno].status; - if (status & (Binary_Stream_f|Eof_Stream_f)) { - if (status & Binary_Stream_f) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get/2"); - return(FALSE); - } else if (status & Eof_Error_Stream_f) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM, ARG1, "get/2"); - return(FALSE); - } + if (status & Binary_Stream_f) { + UNLOCK(Stream[sno].streamlock); + Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get/2"); + return FALSE; } - while ((ch = Stream[sno].stream_getc(sno)) <= 32 && ch >= 0); + while ((ch = get_wchar(sno)) <= 32 && ch >= 0); UNLOCK(Stream[sno].streamlock); return (Yap_unify_constant (ARG2, MkIntTerm (ch))); } @@ -3671,21 +3946,15 @@ p_get0 (void) out = PlUnGetc(sno); } else { status = Stream[sno].status; - if (status & (Binary_Stream_f|Eof_Stream_f)) { - if (status & Binary_Stream_f) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get0/2"); - return(FALSE); - } else if (status & (Eof_Error_Stream_f)) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM, ARG1, "get0/2"); - return(FALSE); - } + if (status & Binary_Stream_f) { + UNLOCK(Stream[sno].streamlock); + Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get0/2"); + return FALSE; } - out = Stream[sno].stream_getc(sno); + out = get_wchar(sno); } UNLOCK(Stream[sno].streamlock); - return (Yap_unify_constant (ARG2, MkIntTerm (out)) ); + return (Yap_unify_constant (ARG2, MkIntegerTerm (out)) ); } static Term @@ -3694,7 +3963,7 @@ read_line(int sno) Term tail; Int ch; - if ((ch = Stream[sno].stream_getc(sno)) == 10) { + if ((ch = Stream[sno].stream_wgetc(sno)) == 10) { return(TermNil); } tail = read_line(sno); @@ -3719,16 +3988,10 @@ p_get0_line_codes (void) rewind = FALSE; } status = Stream[sno].status; - if (status & (Binary_Stream_f|Eof_Stream_f)) { - if (status & Binary_Stream_f) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get0/2"); - return(FALSE); - } else if (status & (Eof_Error_Stream_f)) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM, ARG1, "get0/2"); - return(FALSE); - } + if (status & Binary_Stream_f) { + UNLOCK(Stream[sno].streamlock); + Yap_Error(PERMISSION_ERROR_INPUT_BINARY_STREAM, ARG1, "get0/2"); + return FALSE; } out = read_line(sno); UNLOCK(Stream[sno].streamlock); @@ -3754,18 +4017,9 @@ p_get_byte (void) Yap_Error(PERMISSION_ERROR_INPUT_TEXT_STREAM, ARG1, "get_byte/2"); return(FALSE); } - if (Stream[sno].stream_getc == PlUnGetc) { - out = MkIntTerm(PlUnGetc(sno)); - } else { - if ((status & (Eof_Stream_f|Eof_Error_Stream_f)) == (Eof_Stream_f|Eof_Error_Stream_f)) { - UNLOCK(Stream[sno].streamlock); - Yap_Error(PERMISSION_ERROR_INPUT_PAST_END_OF_STREAM, ARG1, "get_byte/2"); - return FALSE; - } - out = MkIntTerm (Stream[sno].stream_getc(sno)); - } + out = MkIntTerm(Stream[sno].stream_getc(sno)); UNLOCK(Stream[sno].streamlock); - return (Yap_unify_constant (ARG2, out)); + return Yap_unify_constant (ARG2, out); } static Int @@ -3779,7 +4033,7 @@ p_put (void) Yap_Error(PERMISSION_ERROR_OUTPUT_BINARY_STREAM, ARG1, "get0/2"); return(FALSE); } - Stream[sno].stream_putc (sno, (int) IntOfTerm (Deref (ARG2))); + Stream[sno].stream_wputc (sno, (int) IntegerOfTerm (Deref (ARG2))); /* * if (!(Stream[sno].status & Null_Stream_f)) * yap_fflush(Stream[sno].u.file.file); @@ -3800,7 +4054,7 @@ p_put_byte (void) Yap_Error(PERMISSION_ERROR_OUTPUT_TEXT_STREAM, ARG1, "get0/2"); return(FALSE); } - Stream[sno].stream_putc(sno, (int) IntOfTerm (Deref (ARG2))); + Stream[sno].stream_putc(sno, (int) IntegerOfTerm (Deref (ARG2))); /* * if (!(Stream[sno].status & Null_Stream_f)) * yap_fflush(Stream[sno].u.file.file); @@ -3823,8 +4077,8 @@ typedef struct format_status { pads pad_entries[16], *pad_max; } format_info; -static int -format_putc(int sno, int ch) { +static wchar_t +format_putc(int sno, wchar_t ch) { if (FormatInfo->format_buf_size == -1) return EOF; if (ch == 10) { @@ -3929,7 +4183,7 @@ static void fill_pads(int nchars) } static int -format_print_str (Int sno, Int size, Int has_size, Term args, int (* f_putc)(int, int)) +format_print_str (Int sno, Int size, Int has_size, Term args, wchar_t (* f_putc)(int, wchar_t)) { Term arghd; while (!has_size || size > 0) { @@ -4095,7 +4349,7 @@ format(volatile Term otail, volatile Term oargs, int sno) char *fstr = NULL, *fptr; Term args; Term tail; - int (* f_putc)(int, int); + wchar_t (* f_putc)(int, wchar_t); int has_tabs; jmp_buf format_botch; volatile void *old_handler; @@ -4211,7 +4465,7 @@ format(volatile Term otail, volatile Term oargs, int sno) finfo.format_buf_size = FORMAT_MAX_SIZE; f_putc = format_putc; } else { - f_putc = Stream[sno].stream_putc; + f_putc = Stream[sno].stream_wputc; finfo.format_base = NULL; } while ((ch = *fptr++)) { @@ -4695,7 +4949,8 @@ static Int p_skip (void) { /* '$skip'(Stream,N) */ int sno = CheckStream (ARG1, Input_Stream_f, "skip/2"); - Int n = IntOfTerm (Deref (ARG2)), ch; + Int n = IntOfTerm (Deref (ARG2)); + wchar_t ch; if (sno < 0) return (FALSE); @@ -4703,7 +4958,7 @@ p_skip (void) UNLOCK(Stream[sno].streamlock); return (FALSE); } - while ((ch = Stream[sno].stream_getc(sno)) != n && ch != -1); + while ((ch = get_wchar(sno)) != n && ch != -1); UNLOCK(Stream[sno].streamlock); return (TRUE); } @@ -4945,7 +5200,7 @@ p_force_char_conversion(void) return(TRUE); for (i = 0; i < MaxStreams; i++) { if (!(Stream[i].status & Free_Stream_f)) - Stream[i].stream_getc_for_read = ISOGetc; + Stream[i].stream_wgetc_for_read = ISOWGetc; } CharConversionTable = CharConversionTable2; return(TRUE); @@ -4958,7 +5213,7 @@ p_disable_char_conversion(void) for (i = 0; i < MaxStreams; i++) { if (!(Stream[i].status & Free_Stream_f)) - Stream[i].stream_getc_for_read = Stream[i].stream_getc; + Stream[i].stream_wgetc_for_read = Stream[i].stream_wgetc; } CharConversionTable = NULL; return(TRUE); @@ -5141,55 +5396,64 @@ p_same_file(void) { char *f1 = RepAtom(AtomOfTerm(Deref(ARG1)))->StrOfAE; char *f2 = RepAtom(AtomOfTerm(Deref(ARG2)))->StrOfAE; if (strcmp(f1,f2) == 0) - return(TRUE); + return TRUE; #if HAVE_LSTAT { - struct stat buf1, buf2; + struct stat *b1, *b2; + while ((char *)H+sizeof(struct stat)*2 > (char *)(ASP-1024)) { + if (!Yap_gcl(2*sizeof(struct stat), 2, ENV, P)) { + Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); + return FALSE; + } + } + b1 = (struct stat *)H; + b2 = b1+1; if (strcmp(f1,"user_input") == 0) { - if (fstat(fileno(Stream[0].u.file.file), &buf1) == -1) { + if (fstat(fileno(Stream[0].u.file.file), b1) == -1) { /* file does not exist, but was opened? Return -1 */ - return(FALSE); + return FALSE; } } else if (strcmp(f1,"user_output") == 0) { - if (fstat(fileno(Stream[1].u.file.file), &buf1) == -1) { + if (fstat(fileno(Stream[1].u.file.file), b1) == -1) { /* file does not exist, but was opened? Return -1 */ - return(FALSE); + return FALSE; } } else if (strcmp(f1,"user_error") == 0) { - if (fstat(fileno(Stream[2].u.file.file), &buf1) == -1) { + if (fstat(fileno(Stream[2].u.file.file), b1) == -1) { /* file does not exist, but was opened? Return -1 */ - return(FALSE); + return FALSE; } - } else if (stat(f1, &buf1) == -1) { - /* file does not exist, but was opened? Return -1 */ - return(FALSE); - } - if (strcmp(f2,"user_input") == 0) { - if (fstat(fileno(Stream[0].u.file.file), &buf2) == -1) { - /* file does not exist, but was opened? Return -1 */ - return(FALSE); - } - } else if (strcmp(f2,"user_output") == 0) { - if (fstat(fileno(Stream[1].u.file.file), &buf2) == -1) { - /* file does not exist, but was opened? Return -1 */ - return(FALSE); - } - } else if (strcmp(f2,"user_error") == 0) { - if (fstat(fileno(Stream[2].u.file.file), &buf2) == -1) { - /* file does not exist, but was opened? Return -1 */ - return(FALSE); - } - } else if (stat(f2, &buf2) == -1) { + } else if (stat(f1, b1) == -1) { /* file does not exist, but was opened? Return -1 */ return FALSE; } - return(buf1.st_ino == buf2.st_ino + if (strcmp(f2,"user_input") == 0) { + if (fstat(fileno(Stream[0].u.file.file), b2) == -1) { + /* file does not exist, but was opened? Return -1 */ + return FALSE; + } + } else if (strcmp(f2,"user_output") == 0) { + if (fstat(fileno(Stream[1].u.file.file), b2) == -1) { + /* file does not exist, but was opened? Return -1 */ + return FALSE; + } + } else if (strcmp(f2,"user_error") == 0) { + if (fstat(fileno(Stream[2].u.file.file), b2) == -1) { + /* file does not exist, but was opened? Return -1 */ + return FALSE; + } + } else if (stat(f2, b2) == -1) { + /* file does not exist, but was opened? Return -1 */ + return FALSE; + } + int out = (b1->st_ino == b2->st_ino #ifdef __LCC__ - && memcmp((const void *)&(buf1.st_dev),(const void *)&(buf2.st_dev),sizeof(buf1.st_dev)) == 0 + && memcmp((const void *)&(b1->st_dev),(const void *)&(b2->st_dev),sizeof(buf1.st_dev)) == 0 #else - && buf1.st_dev == buf2.st_dev + && b1->st_dev == b2->st_dev #endif ); + return out; } #else return(FALSE); @@ -5206,6 +5470,23 @@ p_float_format(void) return TRUE; } +static Int +p_get_default_encoding(void) +{ + Term out = MkIntegerTerm(DefaultEncoding()); + return Yap_unify(ARG1, out); +} + +static Int +p_set_encoding (void) +{ /* '$set_encoding'(Stream,N) */ + int sno = CheckStream (ARG1, Input_Stream_f|Output_Stream_f, "encoding/2"); + if (sno < 0) + return FALSE; + Stream[sno].encoding = IntegerOfTerm(Deref(ARG2)); + UNLOCK(Stream[sno].streamlock); + return TRUE; +} Term Yap_StringToTerm(char *s,Term *tp) @@ -5257,7 +5538,7 @@ Yap_TermToString(Term t, char *s, unsigned int sz, int flags) return FALSE; Yap_StartSlots(); Yap_c_output_stream = sno; - Yap_plwrite (t, Stream[sno].stream_putc, flags); + Yap_plwrite (t, Stream[sno].stream_wputc, flags); s[Stream[sno].u.mem_string.pos] = '\0'; Stream[sno].status = Free_Stream_f; Yap_c_output_stream = old_output_stream; @@ -5293,7 +5574,7 @@ Yap_InitIOPreds(void) Yap_InitCPred ("$get0", 2, p_get0, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$get0_line_codes", 2, p_get0_line_codes, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$get_byte", 2, p_get_byte, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred ("$open", 4, p_open, SafePredFlag|SyncPredFlag|HiddenPredFlag); + Yap_InitCPred ("$open", 5, p_open, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$file_expansion", 2, p_file_expansion, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$open_null_stream", 1, p_open_null_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$open_pipe_stream", 2, p_open_pipe_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag); @@ -5345,7 +5626,9 @@ Yap_InitIOPreds(void) Yap_InitCPred ("$change_alias_to_stream", 2, p_change_alias_to_stream, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$check_if_valid_new_alias", 1, p_check_if_valid_new_alias, TestPredFlag|SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$fetch_stream_alias", 2, p_fetch_stream_alias, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred ("$stream", 1, p_stream, SafePredFlag|TestPredFlag), + Yap_InitCPred ("$stream", 1, p_stream, SafePredFlag|TestPredFlag); + Yap_InitCPred ("$get_default_encoding", 1, p_get_default_encoding, SafePredFlag|TestPredFlag); + Yap_InitCPred ("$set_encoding", 2, p_set_encoding, SafePredFlag|TestPredFlag), #if HAVE_SELECT Yap_InitCPred ("stream_select", 3, p_stream_select, SafePredFlag|SyncPredFlag); #endif diff --git a/C/parser.c b/C/parser.c index cc6c156d2..8211a1ae7 100644 --- a/C/parser.c +++ b/C/parser.c @@ -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; } diff --git a/C/save.c b/C/save.c index 1af3c42c6..0afcc0881 100644 --- a/C/save.c +++ b/C/save.c @@ -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 */ diff --git a/C/scanner.c b/C/scanner.c index a93025ae3..263c8bc81 100644 --- a/C/scanner.c +++ b/C/scanner.c @@ -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 == '(') diff --git a/C/stdpreds.c b/C/stdpreds.c index a2f03c364..a582b03cb 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -11,8 +11,11 @@ * File: stdpreds.c * * 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 $ +* 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 * fix argument order in db statistics. * @@ -217,6 +220,7 @@ static char SccsId[] = "%W% %G%"; #if HAVE_MALLOC_H #include #endif +#include STD_PROTO(static Int p_setval, (void)); STD_PROTO(static Int p_value, (void)); @@ -519,6 +523,31 @@ FindAtom(codeToFind, arity) 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; return (0); } @@ -605,13 +634,13 @@ strtod(s, pe) static char *cur_char_ptr; -static int +static wchar_t get_char_from_string(int s) { if (cur_char_ptr[0] == '\0') return(-1); 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 p_name(void) { /* name(?Atomic,?String) */ char *String, *s; /* alloc temp space on trail */ Term t = Deref(ARG2), NewT, AtomNameT = Deref(ARG1); + wchar_t *ws = NULL; restart_aux: if (!IsVarTerm(AtomNameT)) { + if (!IsVarTerm(t) && !IsPairTerm(t) && t != TermNil) { + Yap_Error(TYPE_ERROR_LIST,ARG2, + "name/2"); + return FALSE; + } 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)) { String = Yap_PreAllocCodeSpace(); if (String + 1024 > (char *)AuxSp) @@ -794,11 +851,6 @@ p_name(void) return FALSE; } 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); } s = String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE; @@ -817,22 +869,49 @@ p_name(void) Yap_Error(INSTANTIATION_ERROR,Head,"name/2"); return FALSE; } - if (!IsIntTerm(Head)) { + if (!IsIntegerTerm(Head)) { Yap_Error(TYPE_ERROR_INTEGER,Head,"name/2"); return FALSE; } - i = IntOfTerm(Head); - if (i < 0 || i > 255) { - if (i<0) + i = IntegerOfTerm(Head); + if (i < 0 || i >= 255) { + if (i<0) { Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,Head,"name/2"); - return FALSE; + return FALSE; + } else { + ws = ch_to_wide(String, s); + } } - if (s > (char *)AuxSp-1024) { - goto expand_auxsp; + if (ws) { + if (ws > (wchar_t *)AuxSp-1024) { + goto expand_auxsp; + } + *ws++ = i; + } else { + if (s > (char *)AuxSp-1024) { + goto expand_auxsp; + } + *s++ = i; } - *s++ = i; 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'; if (IsVarTerm(t)) { Yap_Error(INSTANTIATION_ERROR,t,"name/2"); @@ -882,20 +961,32 @@ p_atom_chars(void) restart_aux: if (!IsVarTerm(t1)) { Term NewT; + Atom at; + if (!IsAtomTerm(t1)) { Yap_Error(TYPE_ERROR_ATOM, t1, "atom_chars/2"); return(FALSE); } - if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) { - NewT = Yap_StringToList(RepAtom(AtomOfTerm(t1))->StrOfAE); + at = AtomOfTerm(t1); + if (IsWideAtom(at)) { + if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) { + NewT = Yap_WStringToList((wchar_t *)RepAtom(at)->StrOfAE); + } else { + NewT = Yap_WStringToListOfAtoms((wchar_t *)RepAtom(AtomOfTerm(t1))->StrOfAE); + } } else { - NewT = Yap_StringToListOfAtoms(RepAtom(AtomOfTerm(t1))->StrOfAE); + if (yap_flags[YAP_TO_CHARS_FLAG] == QUINTUS_TO_CHARS) { + NewT = Yap_StringToList(RepAtom(at)->StrOfAE); + } else { + NewT = Yap_StringToListOfAtoms(RepAtom(AtomOfTerm(t1))->StrOfAE); + } } return Yap_unify(NewT, ARG2); } else { /* ARG1 unbound */ Term t = Deref(ARG2); char *s; + wchar_t *ws = NULL; Atom at; String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE; @@ -921,19 +1012,29 @@ p_atom_chars(void) if (IsVarTerm(Head)) { Yap_Error(INSTANTIATION_ERROR,Head,"atom_chars/2"); return(FALSE); - } else if (!IsIntTerm(Head)) { + } else if (!IsIntegerTerm(Head)) { Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2"); return(FALSE); } - i = IntOfTerm(Head); - if (i < 0 || i > 255) { + i = IntegerOfTerm(Head); + if (i < 0) { Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_chars/2"); return(FALSE); } - if (s+1024 > (char *)AuxSp) { - goto expand_auxsp; + 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) { + goto expand_auxsp; + } + *s++ = i; } - *s++ = i; t = TailOfTerm(t); if (IsVarTerm(t)) { 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"); return(FALSE); } - is = RepAtom(AtomOfTerm(Head))->StrOfAE; - if (is[1] != '\0') { - Yap_Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2"); - return(FALSE); + 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') { + Yap_Error(TYPE_ERROR_CHARACTER,Head,"atom_chars/2"); + return(FALSE); + } + if (ws) { + if (ws+1024 == (wchar_t *)AuxSp) { + goto expand_auxsp; + } + *ws++ = is[0]; + } else { + if (s+1024 == (char *)AuxSp) { + goto expand_auxsp; + } + *s++ = is[0]; + } } - if (s+1024 == (char *)AuxSp) { - goto expand_auxsp; - } - *s++ = is[0]; t = TailOfTerm(t); if (IsVarTerm(t)) { Yap_Error(INSTANTIATION_ERROR,t,"atom_chars/2"); @@ -976,11 +1100,21 @@ p_atom_chars(void) } } } - *s++ = '\0'; - while ((at = Yap_LookupAtom(String)) == NIL) { - if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); - return FALSE; + 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'; + while ((at = Yap_LookupAtom(String)) == NIL) { + if (!Yap_growheap(FALSE, 0, NULL)) { + Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); + return FALSE; + } } } return Yap_unify_constant(ARG1, MkAtomTerm(at)); @@ -1000,64 +1134,138 @@ p_atom_chars(void) static Int p_atom_concat(void) { - Term t1 = Deref(ARG1); - char *cptr = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE, *cpt0; - char *top = (char *)AuxSp; - char *atom_str; + Term t1; + int wide_mode = FALSE; UInt sz; restart: - cpt0 = cptr; + t1 = Deref(ARG1); /* we need to have a list */ if (IsVarTerm(t1)) { Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2"); - return(FALSE); + return FALSE; } - 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); - } - atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE; - /* check for overflows */ - 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); + 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)) { + Term thead = HeadOfTerm(t1); + if (IsVarTerm(thead)) { + Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); + Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2"); return(FALSE); } - goto restart; - } - memcpy((void *)cptr, (void *)atom_str, sz); - cptr += sz; - 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_LookupAtom(cpt0)) == NIL) { - if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); + if (!IsAtomTerm(thead)) { + Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); + Yap_Error(TYPE_ERROR_ATOM, ARG1, "atom_concat/2"); + 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; } } - Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); - return Yap_unify(ARG2, MkAtomTerm(at)); + 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; + /* check for overflows */ + 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; + } + memcpy((void *)cptr, (void *)atom_str, sz); + cptr += sz; + 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_LookupAtom(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)); + } } Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2"); @@ -1067,104 +1275,233 @@ p_atom_concat(void) static Int p_atomic_concat(void) { - Term t1 = Deref(ARG1); - char *cptr = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE, *cpt0; - char *top = (char *)AuxSp; - char *atom_str; - UInt sz; + Term t1; + int wide_mode = FALSE; + char *base; restart: - if (cptr+1024 > (char *)AuxSp) { - cptr = Yap_ExpandPreAllocCodeSpace(0,NULL); - if (cptr + 1024 > (char *)AuxSp) { + base = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE; + while (base+1024 > (char *)AuxSp) { + base = Yap_ExpandPreAllocCodeSpace(0,NULL); + if (base + 1024 > (char *)AuxSp) { /* crash in flames */ Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "allocating temp space in atomic_concat/2"); return FALSE; } } - cpt0 = cptr; + t1 = Deref(ARG1); /* we need to have a list */ if (IsVarTerm(t1)) { Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2"); - return(FALSE); + return FALSE; } - 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_str = RepAtom(AtomOfTerm(thead))->StrOfAE; - /* check for overflows */ - sz = strlen(atom_str); - if (cptr+sz >= top-1024) { + 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); - if (!Yap_growheap(FALSE, sz+1024, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); - return(FALSE); - } - goto restart; - } - memcpy((void *)cptr, (void *)atom_str, sz); - cptr += sz; - } else if (IsIntegerTerm(thead)) { -#if HAVE_SNPRINTF - snprintf(cptr, (top-cptr)-1024,"%ld", (long int)IntegerOfTerm(thead)); -#else - sprintf(cptr,"%ld", (long int)IntegerOfTerm(thead)); -#endif - while (*cptr && cptr < top-1024) cptr++; - } else if (IsFloatTerm(thead)) { -#if HAVE_SNPRINTF - snprintf(cptr,(top-cptr)-1024,"%g", FloatOfTerm(thead)); -#else - sprintf(cptr,"%g", FloatOfTerm(thead)); -#endif - while (*cptr && cptr < top-1024) cptr++; -#if USE_GMP - } else if (IsBigIntTerm(thead)) { - MP_INT *n = Yap_BigIntOfTerm(thead); - int sz; - - if ((sz = mpz_sizeinbase (n, 10)) > (top-cptr)-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(cptr, 10, n); - while (*cptr) cptr++; -#endif - } - 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_LookupAtom(cpt0)) == NIL) { - if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); + 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)) { + Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); + Yap_Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2"); + 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)) { + 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)) { + char *atom_str; + UInt sz; + + if (IsWideAtom(AtomOfTerm(thead))) { + Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); + wide_mode = TRUE; + goto restart; + } + atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE; + /* check for overflows */ + 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; + } + memcpy((void *)cptr, (void *)atom_str, sz); + cptr += sz; + } else if (IsIntegerTerm(thead)) { +#if HAVE_SNPRINTF + snprintf(cptr, (top-cptr)-1024,"%ld", (long int)IntegerOfTerm(thead)); +#else + sprintf(cptr,"%ld", (long int)IntegerOfTerm(thead)); +#endif + while (*cptr && cptr < top-1024) cptr++; + } else if (IsFloatTerm(thead)) { +#if HAVE_SNPRINTF + snprintf(cptr,(top-cptr)-1024,"%g", FloatOfTerm(thead)); +#else + sprintf(cptr,"%g", FloatOfTerm(thead)); +#endif + while (*cptr && cptr < top-1024) cptr++; +#if USE_GMP + } else if (IsBigIntTerm(thead)) { + MP_INT *n = Yap_BigIntOfTerm(thead); + int sz; + + if ((sz = mpz_sizeinbase (n, 10)) > (top-cptr)-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(cptr, 10, n); + while (*cptr) cptr++; +#endif + } + 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_LookupAtom(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)); } - Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); - return Yap_unify(ARG2, MkAtomTerm(at)); } Yap_ReleasePreAllocCodeSpace((ADDR)cpt0); Yap_Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2"); @@ -1180,16 +1517,24 @@ p_atom_codes(void) restart_pred: if (!IsVarTerm(t1)) { Term NewT; + Atom at; + if (!IsAtomTerm(t1)) { Yap_Error(TYPE_ERROR_ATOM, t1, "atom_codes/2"); 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)); } else { /* ARG1 unbound */ Term t = Deref(ARG2); char *s; + wchar_t *ws = NULL; String = ((AtomEntry *)Yap_PreAllocCodeSpace())->StrOfAE; if (String + 1024 > (char *)AuxSp) { @@ -1219,14 +1564,24 @@ p_atom_codes(void) return(FALSE); } i = IntOfTerm(Head); - if (i < 0 || i > 255) { + if (i < 0) { Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"atom_codes/2"); return(FALSE); } - if (s+1024 > (char *)AuxSp) { - goto expand_auxsp; + 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) { + goto expand_auxsp; + } + *s++ = i; } - *s++ = i; t = TailOfTerm(t); if (IsVarTerm(t)) { Yap_Error(INSTANTIATION_ERROR,t,"atom_codes/2"); @@ -1236,8 +1591,13 @@ p_atom_codes(void) return(FALSE); } } - *s++ = '\0'; - return (Yap_unify_constant(ARG1, MkAtomTerm(Yap_LookupAtom(String)))); + if (ws) { + *ws++ = '\0'; + return Yap_unify_constant(ARG1, MkAtomTerm(Yap_LookupWideAtom((wchar_t *)String))); + } else { + *s++ = '\0'; + return Yap_unify_constant(ARG1, MkAtomTerm(Yap_LookupAtom(String))); + } } /* error handling */ expand_auxsp: @@ -1259,7 +1619,7 @@ p_atom_length(void) { Term t1 = Deref(ARG1); Term t2 = Deref(ARG2); - Int len; + Atom at; if (IsVarTerm(t1)) { 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"); return(FALSE); } + at = AtomOfTerm(t1); if (!IsVarTerm(t2)) { - if (!IsIntTerm(t2)) { + size_t len; + if (!IsIntegerTerm(t2)) { Yap_Error(TYPE_ERROR_INTEGER, t2, "atom_length/2"); return(FALSE); } - if ((len = IntOfTerm(t2)) < 0) { + if ((len = IntegerOfTerm(t2)) < 0) { Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "atom_length/2"); return(FALSE); } - return((Int)strlen(RepAtom(AtomOfTerm(t1))->StrOfAE) == len); + if (IsWideAtom(at)) { + return wcslen((wchar_t *)RepAtom(at)->StrOfAE) == len; + } else { + return(strlen(RepAtom(at)->StrOfAE) == len); + } } else { - Term tj = MkIntegerTerm(strlen(RepAtom(AtomOfTerm(t1))->StrOfAE)); + 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); } } +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 */ static Int p_atom_split(void) { Term t1 = Deref(ARG1); Term t2 = Deref(ARG2); - Int len; - char *s, *s1; + size_t len; int i; Term to1, to2; + Atom at; - s1 = (char *)H; if (IsVarTerm(t1)) { Yap_Error(INSTANTIATION_ERROR, t1, "$atom_split/4"); return(FALSE); @@ -1318,16 +1703,64 @@ p_atom_split(void) Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t2, "$atom_split/4"); return(FALSE); } - s = RepAtom(AtomOfTerm(t1))->StrOfAE; - if (len > (Int)strlen(s)) return(FALSE); - for (i = 0; i< len; i++) { - if (s1 > (char *)LCL0-1024) + at = AtomOfTerm(t1); + if (IsWideAtom(at)) { + wchar_t *ws, *ws1 = (wchar_t *)H; + 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"); - s1[i] = s[i]; + 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[len] = '\0'; + to1 = MkAtomTerm(Yap_LookupAtom(s1)); + to2 = MkAtomTerm(Yap_LookupAtom(s+len)); } - s1[len] = '\0'; - to1 = MkAtomTerm(Yap_LookupAtom(s1)); - to2 = MkAtomTerm(Yap_LookupAtom(s+len)); return(Yap_unify_constant(ARG3,to1) && Yap_unify_constant(ARG4,to2)); } @@ -1923,6 +2356,87 @@ init_current_atom(void) 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 cont_current_predicate(void) { @@ -2562,6 +3076,27 @@ p_statistics_atom_info(void) 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)) && Yap_unify(ARG2, MkIntegerTerm(spaceused)); } @@ -3023,6 +3558,9 @@ Yap_InitBackCPreds(void) { Yap_InitCPredBack("$current_atom", 1, 2, init_current_atom, cont_current_atom, 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, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPredBack("$current_predicate_for_atom", 3, 1, init_current_predicate_for_atom, cont_current_predicate_for_atom, diff --git a/C/userpreds.c b/C/userpreds.c index 04c170d8f..d607281b4 100644 --- a/C/userpreds.c +++ b/C/userpreds.c @@ -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); diff --git a/C/write.c b/C/write.c index 51ab5fbef..2b22170f2 100644 --- a/C/write.c +++ b/C/write.c @@ -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; diff --git a/H/Heap.h b/H/Heap.h index 43c0dfadb..7ee1a3d60 100644 --- a/H/Heap.h +++ b/H/Heap.h @@ -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 diff --git a/H/Yap.h b/H/Yap.h index 811441453..54fa72821 100644 --- a/H/Yap.h +++ b/H/Yap.h @@ -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 diff --git a/H/Yatom.h b/H/Yatom.h index 05379b0a9..715222161 100644 --- a/H/Yatom.h +++ b/H/Yatom.h @@ -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 { diff --git a/H/iopreds.h b/H/iopreds.h index d2f8cc2b8..b97adbdd2 100644 --- a/H/iopreds.h +++ b/H/iopreds.h @@ -29,6 +29,8 @@ static char SccsId[] = "%W% %G%"; #endif +#include + #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 diff --git a/H/rclause.h b/H/rclause.h index 5b4f6df93..c939b47f0 100644 --- a/H/rclause.h +++ b/H/rclause.h @@ -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); diff --git a/H/rheap.h b/H/rheap.h index 128ef81de..9d0fce169 100644 --- a/H/rheap.h +++ b/H/rheap.h @@ -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)); } diff --git a/H/sshift.h b/H/sshift.h index b8f2b827e..d0b9bd27f 100644 --- a/H/sshift.h +++ b/H/sshift.h @@ -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 *); diff --git a/H/yapio.h b/H/yapio.h index ba1816316..5b05e174a 100644 --- a/H/yapio.h +++ b/H/yapio.h @@ -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 diff --git a/changes-5.1.html b/changes-5.1.html index c3b12a17f..ff8ac9cd6 100644 --- a/changes-5.1.html +++ b/changes-5.1.html @@ -16,6 +16,10 @@

Yap-5.1.2:

    +
  • NEW: partial support for UNICODE.
    • +
  • FIXED: ÿ has ISO-LATIN1 code 255, so it would be confused with EOF +(obs from Miguel Filgueiras).
    • +
  • FIXED: mess with \+ meta-call and modules (obs from Nicos Angelopoulos).
  • FIXED: reconsult with spy was broken (obs from Miguel Filgueiras).
  • FIXED: mess with EOF and open (obs from Nicos Angelopoulos).
  • FIXED: make use_module/3 handle case where module is given.
    • diff --git a/distribute b/distribute index e19a5c6e2..c1b2c8b77 100755 --- a/distribute +++ b/distribute @@ -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 diff --git a/pl/boot.yap b/pl/boot.yap index 2ce0ca286..499904bc3 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -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: diff --git a/pl/consult.yap b/pl/consult.yap index 07f1333c4..16c574942 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -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 + ). + + + + + diff --git a/pl/directives.yap b/pl/directives.yap index d4b3052f9..9b500e487 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -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 ; diff --git a/pl/init.yap b/pl/init.yap index 1e743b183..d91df3fe9 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -34,7 +34,6 @@ otherwise. [] :- true. - :- set_value('$doindex',true). % force having indexing code for throw. diff --git a/pl/sockets.yap b/pl/sockets.yap index ae718efa0..37550808a 100644 --- a/pl/sockets.yap +++ b/pl/sockets.yap @@ -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). diff --git a/pl/utils.yap b/pl/utils.yap index effe33181..2c0d133f1 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -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), diff --git a/pl/yio.yap b/pl/yio.yap index fc840c022..00d6faf47 100644 --- a/pl/yio.yap +++ b/pl/yio.yap @@ -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).