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

upgrade to latest SWI

Browse Source
This commit is contained in:
Vitor Santos Costa 2011-02-10 00:01:19 +00:00
parent 8e8c361671
commit 232a740d43
48 changed files with 12317 additions and 2703 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
C/c_interface.c
View File

@ -397,7 +397,7 @@ X_API Term STD_PROTO(YAP_MkAtomTerm,(Atom));
X_API Atom STD_PROTO(YAP_AtomOfTerm,(Term));
X_API Atom STD_PROTO(YAP_LookupAtom,(char *));
X_API Atom STD_PROTO(YAP_LookupWideAtom,(wchar_t *));
X_API int STD_PROTO(YAP_AtomNameLength,(Atom));
X_API size_t STD_PROTO(YAP_AtomNameLength,(Atom));
X_API Atom STD_PROTO(YAP_FullLookupAtom,(char *));
X_API int STD_PROTO(YAP_IsWideAtom,(Atom));
X_API char *STD_PROTO(YAP_AtomName,(Atom));
@ -406,6 +406,7 @@ X_API Term STD_PROTO(YAP_MkPairTerm,(Term,Term));
X_API Term STD_PROTO(YAP_MkNewPairTerm,(void));
X_API Term STD_PROTO(YAP_HeadOfTerm,(Term));
X_API Term STD_PROTO(YAP_TailOfTerm,(Term));
X_API Int STD_PROTO(YAP_SkipList,(Term *, Term **));
X_API Term STD_PROTO(YAP_MkApplTerm,(Functor,UInt,Term *));
X_API Term STD_PROTO(YAP_MkNewApplTerm,(Functor,UInt));
X_API Functor STD_PROTO(YAP_FunctorOfTerm,(Term));
@ -475,6 +476,7 @@ X_API Int STD_PROTO(YAP_NewSlots,(int));
X_API Int STD_PROTO(YAP_InitSlot,(Term));
X_API Term STD_PROTO(YAP_GetFromSlot,(Int));
X_API Term *STD_PROTO(YAP_AddressFromSlot,(Int));
X_API Term *STD_PROTO(YAP_AddressOfTermInSlot,(Int));
X_API void STD_PROTO(YAP_PutInSlot,(Int, Term));
X_API int STD_PROTO(YAP_RecoverSlots,(int));
X_API Int STD_PROTO(YAP_ArgsToSlots,(int));
@ -523,6 +525,9 @@ X_API int STD_PROTO(YAP_ExactlyEqual,(Term, Term));
X_API Int STD_PROTO(YAP_TermHash,(Term, Int, Int, int));
X_API void STD_PROTO(YAP_signal,(int));
X_API int STD_PROTO(YAP_SetYAPFlag,(yap_flag_t, int));
X_API Int STD_PROTO(YAP_VarSlotToNumber,(Int));
X_API Term STD_PROTO(YAP_ModuleUser,(void));
X_API Int STD_PROTO(YAP_NumberOfClausesForPredicate,(PredEntry *));
static int (*do_getf)(void);
@ -840,9 +845,12 @@ YAP_FullLookupAtom(char *c)
}
}
X_API int
X_API size_t
YAP_AtomNameLength(Atom at)
{
if (IsBlob(at)) {
return RepAtom(at)->rep.blob->length;
}
if (IsWideAtom(at)) {
wchar_t *c = RepAtom(at)->WStrOfAE;
@ -915,6 +923,34 @@ YAP_TailOfTerm(Term t)
return (TailOfTerm(t));
}
X_API Int
YAP_SkipList(Term *l, Term **tailp)
{
Int length = 0;
Term *s; /* slow */
Term v; /* temporary */
v = Derefa(l);
s = l;
if ( IsPairTerm(*l) )
{ intptr_t power = 1, lam = 0;
do
{ if ( power == lam )
{ s = l;
power *= 2;
lam = 0;
}
lam++;
length++;
l = RepPair(*l)+1; v = Derefa(l);
} while ( *l != *s && IsPairTerm(*l) );
}
*tailp = l;
return length;
}
X_API Term
YAP_MkApplTerm(Functor f,UInt arity, Term args[])
{
@ -1137,6 +1173,23 @@ YAP_AddressFromSlot(Int slot)
return Yap_AddressFromSlot(slot);
}
X_API Term *
YAP_AddressOfTermInSlot(Int slot)
{
Term *b = Yap_AddressFromSlot(slot);
Term a = *b;
restart:
if (!IsVarTerm(a)) {
return(b);
} else if (a == (CELL)b) {
return(b);
} else {
b = (CELL *)a;
a = *b;
goto restart;
}
}
X_API void
YAP_PutInSlot(Int slot, Term t)
{
@ -3277,4 +3330,21 @@ YAP_SetYAPFlag(yap_flag_t flag, int val)
}
/* Int YAP_VarSlotToNumber(Int) */
Int YAP_VarSlotToNumber(Int s) {
Term *t = (CELL *)Deref(Yap_GetFromSlot(s));
if (t < H)
return t-H0;
return t-LCL0;
}
/* Term YAP_ModuleUser() */
Term YAP_ModuleUser(void) {
return MkAtomTerm(AtomUser);
}
/* int YAP_PredicateHasClauses() */
Int YAP_NumberOfClausesForPredicate(PredEntry *pe) {
return pe->cs.p_code.NOfClauses;
}

18
H/iswiatoms.h
View File

@ -26,6 +26,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("append");
SWI_Atoms[i++] = Yap_LookupAtom("=:=");
SWI_Atoms[i++] = Yap_LookupAtom("=\\=");
SWI_Atoms[i++] = Yap_LookupAtom("arity");
SWI_Atoms[i++] = Yap_LookupAtom("argument");
SWI_Atoms[i++] = Yap_LookupAtom("argumentlimit");
SWI_Atoms[i++] = Yap_LookupAtom("as");
@ -42,6 +43,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("@<");
SWI_Atoms[i++] = Yap_LookupAtom("@=<");
SWI_Atoms[i++] = Yap_LookupAtom("atan");
SWI_Atoms[i++] = Yap_LookupAtom("atan2");
SWI_Atoms[i++] = Yap_LookupAtom("atom");
SWI_Atoms[i++] = Yap_LookupAtom("atom_garbage_collection");
SWI_Atoms[i++] = Yap_LookupAtom("atomic");
@ -58,6 +60,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("binary");
SWI_Atoms[i++] = Yap_LookupAtom("bind");
SWI_Atoms[i++] = Yap_LookupAtom("\\/");
SWI_Atoms[i++] = Yap_LookupAtom("blobs");
SWI_Atoms[i++] = Yap_LookupAtom("bof");
SWI_Atoms[i++] = Yap_LookupAtom("bom");
SWI_Atoms[i++] = Yap_LookupAtom("bool");
@ -69,8 +72,8 @@
SWI_Atoms[i++] = Yap_LookupAtom("buffer_size");
SWI_Atoms[i++] = Yap_LookupAtom("built_in_procedure");
SWI_Atoms[i++] = Yap_LookupAtom("busy");
SWI_Atoms[i++] = Yap_LookupAtom("><");
SWI_Atoms[i++] = Yap_LookupAtom("byte");
SWI_Atoms[i++] = Yap_LookupAtom("c_stack");
SWI_Atoms[i++] = Yap_LookupAtom("call");
SWI_Atoms[i++] = Yap_LookupAtom("callable");
SWI_Atoms[i++] = Yap_LookupAtom("$callpred");
@ -91,6 +94,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("clause_reference");
SWI_Atoms[i++] = Yap_LookupAtom("close");
SWI_Atoms[i++] = Yap_LookupAtom("close_on_abort");
SWI_Atoms[i++] = Yap_LookupAtom("close_on_exec");
SWI_Atoms[i++] = Yap_LookupAtom("close_option");
SWI_Atoms[i++] = Yap_LookupAtom("cm");
SWI_Atoms[i++] = Yap_LookupAtom("cntrl");
@ -153,6 +157,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("digit");
SWI_Atoms[i++] = Yap_LookupAtom("directory");
SWI_Atoms[i++] = Yap_LookupAtom("discontiguous");
SWI_Atoms[i++] = Yap_LookupAtom("div");
SWI_Atoms[i++] = Yap_LookupAtom("//");
SWI_Atoms[i++] = Yap_LookupAtom("/");
SWI_Atoms[i++] = Yap_LookupAtom("$load");
@ -409,6 +414,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("past_end_of_stream");
SWI_Atoms[i++] = Yap_LookupAtom("pattern");
SWI_Atoms[i++] = Yap_LookupAtom("pc");
SWI_Atoms[i++] = Yap_LookupAtom("peek");
SWI_Atoms[i++] = Yap_LookupAtom("period");
SWI_Atoms[i++] = Yap_LookupAtom("permission_error");
SWI_Atoms[i++] = Yap_LookupAtom("pi");
@ -441,6 +447,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("property");
SWI_Atoms[i++] = Yap_LookupAtom("protocol");
SWI_Atoms[i++] = Yap_LookupAtom(":-");
SWI_Atoms[i++] = Yap_LookupAtom("public");
SWI_Atoms[i++] = Yap_LookupAtom("punct");
SWI_Atoms[i++] = Yap_LookupAtom("?-");
SWI_Atoms[i++] = Yap_LookupAtom("?");
@ -488,6 +495,7 @@
SWI_Atoms[i++] = Yap_LookupAtom(";");
SWI_Atoms[i++] = Yap_LookupAtom("separated");
SWI_Atoms[i++] = Yap_LookupAtom("set");
SWI_Atoms[i++] = Yap_LookupAtom("set_end_of_stream");
SWI_Atoms[i++] = Yap_LookupAtom("setup_call_catcher_cleanup");
SWI_Atoms[i++] = Yap_LookupAtom("shared");
SWI_Atoms[i++] = Yap_LookupAtom("shared_object");
@ -600,6 +608,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("unicode_le");
SWI_Atoms[i++] = Yap_LookupAtom("unify");
SWI_Atoms[i++] = Yap_LookupAtom("?=");
SWI_Atoms[i++] = Yap_LookupAtom("uninstantiation_error");
SWI_Atoms[i++] = Yap_LookupAtom("unique");
SWI_Atoms[i++] = Yap_LookupAtom("=..");
SWI_Atoms[i++] = Yap_LookupAtom("unknown");
@ -624,6 +633,7 @@
SWI_Atoms[i++] = Yap_LookupAtom("very_deep");
SWI_Atoms[i++] = Yap_LookupAtom("vmi");
SWI_Atoms[i++] = Yap_LookupAtom("volatile");
SWI_Atoms[i++] = Yap_LookupAtom("wait");
SWI_Atoms[i++] = Yap_LookupAtom("wakeup");
SWI_Atoms[i++] = Yap_LookupAtom("walltime");
SWI_Atoms[i++] = Yap_LookupAtom("warning");
@ -642,7 +652,6 @@
SWI_Atoms[i++] = Yap_LookupAtom("@");
SWI_Atoms[i++] = Yap_LookupAtom("yf");
SWI_Atoms[i++] = Yap_LookupAtom("yfx");
SWI_Atoms[i++] = Yap_LookupAtom("yfy");
SWI_Atoms[i++] = Yap_LookupAtom("zero_divisor");
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_abs),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_access),1);
@ -656,6 +665,7 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_asserta),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_atan),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_atan),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_atan2),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_atom),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_att),3);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_backslash),1);
@ -669,7 +679,6 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_buffer),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_buffer_size),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_busy),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_bw_xor),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_call),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_callpred),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_catch),3);
@ -679,6 +688,7 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_chars),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_clause),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_close_on_abort),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_close_on_exec),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_codes),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_codes),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_colon),2);
@ -702,6 +712,7 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dforeign_registered),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dgarbage_collect),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_div),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_gdiv),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_divide),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dmessage_queue),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_dmutex),1);
@ -851,6 +862,7 @@
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_type_error),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_undefinterc),4);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_unify_determined),2);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_uninstantiation_error),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_var),1);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_wakeup),3);
SWI_Functors[j++] = Yap_MkFunctor(SWIAtomToAtom(ATOM_warning),3);

4
include/SWI-Prolog.h
View File

@ -443,6 +443,7 @@ extern X_API int PL_get_name_arity(term_t, atom_t *, int *);
extern X_API int PL_get_nil(term_t);
extern X_API int PL_get_pointer(term_t, void **);
extern X_API int PL_get_intptr(term_t, intptr_t *);
extern X_API int PL_get_uintptr(term_t, uintptr_t *);
extern X_API int PL_get_tail(term_t, term_t);
/* end PL_get_* functions =============================*/
/* begin PL_new_* functions =============================*/
@ -702,7 +703,9 @@ PL_EXPORT(void*) PL_blob_data(atom_t a,
PL_EXPORT(void) PL_register_blob_type(PL_blob_t *type);
PL_EXPORT(PL_blob_t*) PL_find_blob_type(const char* name);
PL_EXPORT(PL_blob_t*) YAP_find_blob_type(YAP_Atom at);
PL_EXPORT(int) PL_unregister_blob_type(PL_blob_t *type);
PL_EXPORT(int) PL_raise(int sig);
#if USE_GMP
@ -717,7 +720,6 @@ extern X_API const char *PL_cwd(void);
void swi_install(void);
X_API int PL_error(const char *pred, int arity, const char *msg, int id, ...);
X_API int PL_warning(const char *msg, ...);

4
include/SWI-Stream.h
View File

@ -164,6 +164,8 @@ typedef struct io_stream
struct io_stream * upstream; /* stream providing our input */
struct io_stream * downstream; /* stream providing our output */
unsigned newline : 2; /* Newline mode */
unsigned erased : 1; /* Stream was erased */
unsigned references : 4; /* Reference-count */
int io_errno; /* Save errno value */
void * exception; /* pending exception (record_t) */
intptr_t reserved[2]; /* reserved for extension */
@ -235,6 +237,8 @@ PL_EXPORT_DATA(IOSTREAM) S__iob[3]; /* Libs standard streams */
: S__fillbuf(s))
#define Sgetc(s) S__updatefilepos_getc((s), Snpgetc(s))
PL_EXPORT(int) Speekcode(IOSTREAM *s);
/* Control-operations */
#define SIO_GETSIZE (1) /* get size of underlying object */
#define SIO_GETFILENO (2) /* get underlying file (if any) */

20
include/YapInterface.h
View File

@ -66,6 +66,7 @@ __BEGIN_DECLS
/* Primitive Functions */
#define YAP_Deref(t) (t)
extern X_API YAP_Term PROTO(YAP_A,(int));
#define YAP_ARG1 YAP_A(1)
#define YAP_ARG2 YAP_A(2)
@ -151,7 +152,7 @@ extern X_API YAP_Atom PROTO(YAP_LookupWideAtom,(CONST wchar_t *));
extern X_API YAP_Atom PROTO(YAP_FullLookupAtom,(CONST char *));
/* int AtomNameLength(Atom) */
extern X_API int PROTO(YAP_AtomNameLength,(YAP_Atom));
extern X_API size_t PROTO(YAP_AtomNameLength,(YAP_Atom));
/* const char* IsWideAtom(YAP_Atom) */
extern X_API int *PROTO(YAP_IsWideAtom,(YAP_Atom));
@ -174,6 +175,9 @@ extern X_API YAP_Term PROTO(YAP_HeadOfTerm,(YAP_Term));
/* Term TailOfTerm(Term) */
extern X_API YAP_Term PROTO(YAP_TailOfTerm,(YAP_Term));
/* Int AddressOfTailOfTerm(Term *, Term **) */
extern X_API YAP_Int PROTO(YAP_SkipList,(YAP_Term *, YAP_Term **));
/* Term TailOfTerm(Term) */
extern X_API YAP_Term PROTO(YAP_TermNil,(void));
@ -417,9 +421,12 @@ extern X_API YAP_Int PROTO(YAP_InitSlot,(YAP_Term));
/* YAP_Term YAP_GetFromSlots(t) */
extern X_API YAP_Term PROTO(YAP_GetFromSlot,(YAP_Int));
/* YAP_Term YAP_AddressFromSlots(t) */
/* YAP_Term *YAP_AddressFromSlots(t) */
extern X_API YAP_Term *PROTO(YAP_AddressFromSlot,(YAP_Int));
/* YAP_Term *YAP_AddressOfTermInSlot(t) */
extern X_API YAP_Term *PROTO(YAP_AddressOfTermInSlot,(YAP_Int));
/* YAP_Term YAP_PutInSlots(t) */
extern X_API void PROTO(YAP_PutInSlot,(YAP_Int, YAP_Term));
@ -521,6 +528,15 @@ extern X_API void PROTO(YAP_signal,(int));
/* stack expansion control */
extern X_API int PROTO(YAP_SetYAPFlag,(yap_flag_t,int));
/* void *YAP_GlobalBase(Term) */
extern X_API YAP_Int PROTO(YAP_VarSlotToNumber,(YAP_Int));
/* Term YAP_ModuleUser() */
extern X_API YAP_Term PROTO(YAP_ModuleUser,(void));
/* Int YAP_NumberOfClausesForPredicate() */
extern X_API YAP_Int PROTO(YAP_NumberOfClausesForPredicate,(YAP_PredEntryPtr));
#define YAP_InitCPred(N,A,F) YAP_UserCPredicate(N,F,A)
__END_DECLS

1634
include/dswiatoms.h
View File

File diff suppressed because it is too large Load Diff

15
library/dialect/swi/fli/blobs.c
View File

@ -101,8 +101,19 @@ PL_register_blob_type(PL_blob_t *type)
PL_EXPORT(PL_blob_t*)
PL_find_blob_type(const char* name)
{
fprintf(stderr,"PL_find_blob_type not implemented yet\n");
return NULL;
Atom at = Yap_LookupAtom((char *)name);
return YAP_find_blob_type((YAP_Atom)at);
}
PL_EXPORT(PL_blob_t*)
YAP_find_blob_type(YAP_Atom at)
{
AtomEntry *a = RepAtom((Atom)at);
if (!IsBlob(a)) {
return SWI_Blobs;
}
return RepBlobProp(a->PropsOfAE)->blob_t;
}
PL_EXPORT(int)

311
library/dialect/swi/fli/swi.c
View File

@ -304,6 +304,17 @@ X_API int PL_get_intptr(term_t ts, intptr_t *a)
return 1;
}
/* SWI: int PL_get_atom(term_t t, YAP_Atom *a)
YAP: YAP_Atom YAP_AtomOfTerm(Term) */
X_API int PL_get_uintptr(term_t ts, uintptr_t *a)
{
Term t = Yap_GetFromSlot(ts);
if ( !IsIntegerTerm(t) )
return 0;
*a = (uintptr_t)(IntegerOfTerm(t));
return 1;
}
/* SWI: int PL_get_atom_chars(term_t t, char **s)
YAP: char* AtomName(Atom) */
X_API int PL_get_atom_chars(term_t ts, char **a) /* SAM check type */
@ -1269,34 +1280,6 @@ X_API void PL_fatal_error(const char *msg)
Yap_exit(1);
}
static char *
OsError(void)
{
#ifdef HAVE_STRERROR
#ifdef __WINDOWS__
return NULL;
#else
return strerror(errno);
#endif
#else /*HAVE_STRERROR*/
static char errmsg[64];
#ifdef __unix__
extern int sys_nerr;
#if !EMX
extern char *sys_errlist[];
#endif
extern int errno;
if ( errno < sys_nerr )
return sys_errlist[errno];
#endif
Ssprintf(errmsg, "Unknown Error (%d)", errno);
return errmsg;
#endif /*HAVE_STRERROR*/
}
X_API int PL_warning(const char *msg, ...) {
va_list args;
va_start(args, msg);
@ -1308,218 +1291,6 @@ X_API int PL_warning(const char *msg, ...) {
PL_fail;
}
X_API int PL_error(const char *pred, int arity, const char *msg, int id, ...)
{
term_t formal, swi, predterm, msgterm, except;
va_list args;
formal = PL_new_term_ref();
swi = PL_new_term_ref();
predterm = PL_new_term_ref();
msgterm = PL_new_term_ref();
except = PL_new_term_ref();
if ( msg == ((char *)(-1)) )
{ if ( errno == EPLEXCEPTION )
return FALSE;
msg = OsError();
}
/* This would really require having pl-error.c, but we'll make do so as */
va_start(args, id);
switch(id) {
case ERR_INSTANTIATION:
err_instantiation:
PL_unify_atom(formal, ATOM_instantiation_error);
break;
case ERR_TYPE: /* ERR_INSTANTIATION if var(actual) */
{ atom_t expected = va_arg(args, atom_t);
term_t actual = va_arg(args, term_t);
if ( PL_is_variable(actual) && expected != ATOM_variable )
goto err_instantiation;
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_ATOM, expected,
PL_TERM, actual);
break;
}
case ERR_DOMAIN: /* ERR_INSTANTIATION if var(arg) */
{ atom_t domain = va_arg(args, atom_t);
term_t arg = va_arg(args, term_t);
if ( PL_is_variable(arg) )
goto err_instantiation;
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_domain_error2,
PL_ATOM, domain,
PL_TERM, arg);
break;
}
case ERR_REPRESENTATION:
{ atom_t what = va_arg(args, atom_t);
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_representation_error1,
PL_ATOM, what);
break;
}
case ERR_NOT_IMPLEMENTED_PROC:
{ const char *name = va_arg(args, const char *);
int arity = va_arg(args, int);
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_not_implemented2,
PL_ATOM, ATOM_procedure,
PL_FUNCTOR, FUNCTOR_divide2,
PL_CHARS, name,
PL_INT, arity);
break;
}
case ERR_EXISTENCE:
{ atom_t type = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, type,
PL_TERM, obj);
break;
}
case ERR_PERMISSION:
{ atom_t type = va_arg(args, atom_t);
atom_t op = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, type,
PL_ATOM, op,
PL_TERM, obj);
break;
}
case ERR_SYSCALL:
{ const char *op = va_arg(args, const char *);
if ( !msg )
msg = op;
switch(errno)
{ case ENOMEM:
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_no_memory);
break;
default:
PL_unify_atom(formal, ATOM_system_error);
break;
}
break;
}
case ERR_TIMEOUT:
{ atom_t op = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_timeout_error2,
PL_ATOM, op,
PL_TERM, obj);
break;
}
case ERR_FILE_OPERATION:
{ atom_t action = va_arg(args, atom_t);
atom_t type = va_arg(args, atom_t);
term_t file = va_arg(args, term_t);
switch(errno)
{ case EACCES:
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, action,
PL_ATOM, type,
PL_TERM, file);
break;
case EMFILE:
case ENFILE:
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_max_files);
break;
#ifdef EPIPE
case EPIPE:
if ( !msg )
msg = "Broken pipe";
/*FALLTHROUGH*/
#endif
default: /* what about the other cases? */
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, type,
PL_TERM, file);
break;
}
break;
}
case ERR_NOMEM:
{ PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_no_memory);
break;
}
case ERR_EVALUATION:
{ atom_t what = va_arg(args, atom_t);
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, what);
break;
}
case ERR_STREAM_OP:
{ atom_t action = va_arg(args, atom_t);
term_t stream = va_arg(args, term_t);
int rc;
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_io_error2,
PL_ATOM, action,
PL_TERM, stream);
break;
}
default:
fprintf(stderr, "unimplemented SWI error %d\n",id);
goto err_instantiation;
}
va_end(args);
if ( pred )
{ PL_unify_term(predterm,
PL_FUNCTOR, FUNCTOR_divide2,
PL_CHARS, pred,
PL_INT, arity);
}
if ( msg )
{
PL_put_atom_chars(msgterm, msg);
}
PL_unify_term(swi,
PL_FUNCTOR, FUNCTOR_context2,
PL_TERM, predterm,
PL_TERM, msgterm);
PL_unify_term(except,
PL_FUNCTOR, FUNCTOR_error2,
PL_TERM, formal,
PL_TERM, swi);
return PL_raise_exception(except);
}
/* begin PL_unify_* functions =============================*/
X_API int PL_unify(term_t t1, term_t t2)
@ -2524,23 +2295,66 @@ X_API predicate_t PL_predicate(const char *name, int arity, const char *m)
return YAP_Predicate((YAP_Atom)at, arity, mod);
}
X_API int PL_unify_predicate(term_t head, predicate_t *pred, const char *m)
{
Term mod;
Atom at;
Term t;
Int arity;
Functor fun;
if (m == NULL) {
mod = CurrentModule;
if (!mod) mod = USER_MODULE;
} else {
Atom at;
while (!(at = Yap_LookupAtom((char *)m))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
return 0;
}
}
mod = MkAtomTerm(at);
}
t = Yap_GetFromSlot(head);
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
arity = 0;
} else if (IsApplTerm(t)) {
Functor f;
f = FunctorOfTerm(t);
if (IsExtensionFunctor(fun)) {
return 0;
}
at = NameOfFunctor(f);
arity = ArityOfFunctor(f);
} else
return 0;
*pred = YAP_Predicate((YAP_Atom)at, arity, mod);
return pred != NULL;
}
X_API void PL_predicate_info(predicate_t p,atom_t *name, int *arity, module_t *m)
{
PredEntry *pd = (PredEntry *)p;
Atom aname;
if (pd->ArityOfPE) {
*arity = pd->ArityOfPE;
if (arity)
*arity = pd->ArityOfPE;
aname = NameOfFunctor(pd->FunctorOfPred);
} else {
*arity = 0;
if (arity)
*arity = 0;
aname = (Atom)(pd->FunctorOfPred);
}
if (pd->ModuleOfPred)
if (pd->ModuleOfPred && m)
*m = (module_t)pd->ModuleOfPred;
else
else if (m)
*m = (module_t)TermProlog;
*name = AtomToSWIAtom(aname);
if (name)
*name = AtomToSWIAtom(aname);
}
X_API fid_t
@ -2954,6 +2768,13 @@ PL_free(void *obj)
free(obj);
}
static int
PL_error(const char *pred, int arity, const char *msg, int id, ...)
{
fprintf(stderr,"Internal PL_error Not implemented\n");
return 0;
}
X_API int
PL_eval_expression_to_int64_ex(term_t t, int64_t *val)
{

20
misc/SWIATOMS
View File

@ -32,6 +32,7 @@ A anonvar "_"
A append "append"
A ar_equals "=:="
A ar_not_equal "=\\="
A arity "arity"
A argument "argument"
A argumentlimit "argumentlimit"
A as "as"
@ -48,6 +49,7 @@ A at_not_equals "\\=@="
A at_smaller "@<"
A at_smaller_eq "@=<"
A atan "atan"
A atan2 "atan2"
A atom "atom"
A atom_garbage_collection "atom_garbage_collection"
A atomic "atomic"
@ -64,6 +66,7 @@ A begin "begin"
A binary "binary"
A bind "bind"
A bitor "\\/"
A blobs "blobs"
A bof "bof"
A bom "bom"
A bool "bool"
@ -75,8 +78,8 @@ A buffer "buffer"
A buffer_size "buffer_size"
A built_in_procedure "built_in_procedure"
A busy "busy"
A bw_xor "><"
A byte "byte"
A c_stack "c_stack"
A call "call"
A callable "callable"
A callpred "$callpred"
@ -97,6 +100,7 @@ A clause "clause"
A clause_reference "clause_reference"
A close "close"
A close_on_abort "close_on_abort"
A close_on_exec "close_on_exec"
A close_option "close_option"
A cm "cm"
A cntrl "cntrl"
@ -159,7 +163,8 @@ A dgarbage_collect "$garbage_collect"
A digit "digit"
A directory "directory"
A discontiguous "discontiguous"
A div "//"
A div "div"
A gdiv "//"
A divide "/"
A dload "$load"
A dmessage_queue "$message_queue"
@ -415,6 +420,7 @@ A past "past"
A past_end_of_stream "past_end_of_stream"
A pattern "pattern"
A pc "pc"
A peek "peek"
A period "period"
A permission_error "permission_error"
A pi "pi"
@ -447,6 +453,7 @@ A prompt "|:"
A property "property"
A protocol "protocol"
A prove ":-"
A public "public"
A punct "punct"
A query "?-"
A question_mark "?"
@ -494,6 +501,7 @@ A select "select"
A semicolon ";"
A separated "separated"
A set "set"
A set_end_of_stream "set_end_of_stream"
A setup_call_catcher_cleanup "setup_call_catcher_cleanup"
A shared "shared"
A shared_object "shared_object"
@ -606,6 +614,7 @@ A unicode_be "unicode_be"
A unicode_le "unicode_le"
A unify "unify"
A unify_determined "?="
A uninstantiation_error "uninstantiation_error"
A unique "unique"
A univ "=.."
A unknown "unknown"
@ -630,6 +639,7 @@ A variables "variables"
A very_deep "very_deep"
A vmi "vmi"
A volatile "volatile"
A wait "wait"
A wakeup "wakeup"
A walltime "walltime"
A warning "warning"
@ -648,7 +658,6 @@ A xor "xor"
A xpceref "@"
A yf "yf"
A yfx "yfx"
A yfy "yfy"
A zero_divisor "zero_divisor"
F abs 1
@ -663,6 +672,7 @@ F assert 1
F asserta 1
F atan 1
F atan 2
F atan2 2
F atom 1
F att 3
F backslash 1
@ -676,7 +686,6 @@ F break 3
F buffer 1
F buffer_size 1
F busy 2
F bw_xor 2
F call 1
F callpred 2
F catch 3
@ -686,6 +695,7 @@ F chars 1
F chars 2
F clause 1
F close_on_abort 1
F close_on_exec 1
F codes 1
F codes 2
F colon 2
@ -709,6 +719,7 @@ F dexit 2
F dforeign_registered 2
F dgarbage_collect 1
F div 2
F gdiv 2
F divide 2
F dmessage_queue 1
F dmutex 1
@ -858,6 +869,7 @@ F type 1
F type_error 2
F undefinterc 4
F unify_determined 2
F uninstantiation_error 1
F var 1
F wakeup 3
F warning 3

18
packages/PLStream/Makefile.in
View File

@ -39,8 +39,11 @@ CWD=$(PWD)
#
HEADERS=$(srcdir)/atoms.h $(srcdir)/pl-buffer.h $(srcdir)/pl-ctype.h \
$(srcdir)/pl-codelist.h \
$(srcdir)/pl-dtoa.h $(srcdir)/dtoa.c \
$(srcdir)/pl-incl.h \
$(srcdir)/pl-mswchar.h \
$(srcdir)/pl-option.h \
$(srcdir)/pl-opts.h \
$(srcdir)/pl-os.h \
$(srcdir)/pl-privitf.h \
@ -49,20 +52,29 @@ HEADERS=$(srcdir)/atoms.h $(srcdir)/pl-buffer.h $(srcdir)/pl-ctype.h \
$(srcdir)/pl-text.h $(srcdir)/pl-utf8.h \
$(srcdir)/pl-yap.h @ENABLE_WINCONSOLE@ $(srcdir)/uxnt/dirent.h $(srcdir)/uxnt/utf8.h $(srcdir)/pl-utf8.c $(srcdir)/uxnt/uxnt.h
C_SOURCES=$(srcdir)/pl-buffer.c $(srcdir)/pl-ctype.c \
$(srcdir)/pl-codelist.c \
$(srcdir)/pl-dtoa.c \
$(srcdir)/pl-error.c \
$(srcdir)/pl-file.c $(srcdir)/pl-files.c \
$(srcdir)/pl-file.c \
$(srcdir)/pl-files.c \
$(srcdir)/pl-fmt.c \
$(srcdir)/pl-glob.c \
$(srcdir)/pl-option.c \
$(srcdir)/pl-os.c \
$(srcdir)/pl-privitf.c \
$(srcdir)/pl-stream.c $(srcdir)/pl-string.c \
$(srcdir)/pl-table.c \
$(srcdir)/pl-text.c \
$(srcdir)/pl-util.c \
$(srcdir)/pl-write.c \
$(srcdir)/pl-yap.c @ENABLE_WINCONSOLE@ $(srcdir)/popen.c $(srcdir)/uxnt/uxnt.c
OBJS=pl-buffer.o pl-ctype.o pl-error.o \
pl-file.o pl-files.o pl-glob.o pl-os.o pl-privitf.o \
OBJS=pl-buffer.o pl-codelist.o pl-ctype.o pl-dtoa.o pl-error.o \
pl-file.o pl-files.o pl-fmt.o \
pl-glob.o pl-option.o \
pl-os.o pl-privitf.o \
pl-stream.o pl-string.o pl-table.o \
pl-text.o pl-util.o pl-utf8.o \
pl-write.o \
pl-yap.o @ENABLE_WINCONSOLE@ uxnt.o
SOBJS=libplstream.@SO@

4322
packages/PLStream/dtoa.c Normal file
View File

File diff suppressed because it is too large Load Diff

105
packages/PLStream/pl-buffer.c
View File

@ -24,10 +24,45 @@
#include "pl-incl.h"
// vsc: changed from SWI
#define discardable_buffer (LD->discardable_buffer)
#define buffer_ring (LD->buffer_ring)
#define current_buffer_id (LD->current_buffer_id)
void
growBuffer(Buffer b, size_t minfree)
{ size_t osz = b->max - b->base, sz = osz;
size_t top = b->top - b->base;
if ( b->max - b->top >= (int)minfree )
return;
if ( sz < 512 )
sz = 512; /* minimum reasonable size */
while( top + minfree > sz )
sz *= 2;
if ( b->base != b->static_buffer )
{ b->base = realloc(b->base, sz);
if ( !b->base )
outOfCore();
} else /* from static buffer */
{ char *new;
if ( !(new = malloc(sz)) )
outOfCore();
memcpy(new, b->static_buffer, osz);
b->base = new;
}
b->top = b->base + top;
b->max = b->base + sz;
}
/*******************************
* BUFFER RING *
*******************************/
#define discardable_buffer (LD->fli._discardable_buffer)
#define buffer_ring (LD->fli._buffer_ring)
#define current_buffer_id (LD->fli._current_buffer_id)
Buffer
findBuffer(int flags)
@ -48,58 +83,6 @@ findBuffer(int flags)
return b;
}
int
unfindBuffer(int flags)
{ GET_LD
if ( flags & BUF_RING )
{ if ( --current_buffer_id <= 0 )
current_buffer_id = BUFFER_RING_SIZE-1;
}
fail;
}
void
growBuffer(Buffer b, size_t minfree)
{ size_t osz = b->max - b->base, sz = osz;
size_t top = b->top - b->base;
if ( b->max - b->top >= (int)minfree )
return;
if ( sz < 512 )
sz = 512; /* minimum reasonable size */
while( top + minfree > sz )
sz *= 2;
if ( b->base != b->static_buffer )
{
#ifdef BUFFER_USES_MALLOC
b->base = realloc(b->base, sz);
if ( !b->base )
outOfCore();
#else
char *old = b->base;
b->base = allocHeap(sz);
memcpy(b->base, old, osz);
#endif
} else /* from static buffer */
{ char *new;
#ifdef BUFFER_USES_MALLOC
if ( !(new = malloc(sz)) )
outOfCore();
#else
new = allocHeap(sz);
#endif
memcpy(new, b->static_buffer, osz);
b->base = new;
}
b->top = b->base + top;
b->max = b->base + sz;
}
char *
buffer_string(const char *s, int flags)
@ -112,3 +95,13 @@ buffer_string(const char *s, int flags)
}
int
unfindBuffer(int flags)
{ GET_LD
if ( flags & BUF_RING )
{ if ( --current_buffer_id <= 0 )
current_buffer_id = BUFFER_RING_SIZE-1;
}
fail;
}

34
packages/PLStream/pl-buffer.h
View File

@ -26,9 +26,6 @@
#define BUFFER_H_INCLUDED
#define STATIC_BUFFER_SIZE (512)
#define BUFFER_USES_MALLOC 1
#define BUFFER_RING_SIZE 16 /* foreign buffer ring (pl-fli.c) */
typedef struct
{ char * base; /* allocated base */
@ -46,14 +43,6 @@ typedef struct
void growBuffer(Buffer b, size_t minfree);
Buffer findBuffer(int flags);
char *buffer_string(const char *s, int flags);
int unfindBuffer(int flags);
Buffer codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide);
#define addBuffer(b, obj, type) \
do \
{ if ( (b)->top + sizeof(type) > (b)->max ) \
@ -61,7 +50,7 @@ Buffer codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide);
*((type *)(b)->top) = obj; \
(b)->top += sizeof(type); \
} while(0)
#define addMultipleBuffer(b, ptr, times, type) \
do \
{ size_t _tms = (times); \
@ -74,7 +63,7 @@ Buffer codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide);
*_d++ = *_s++; \
(b)->top = (char *)_d; \
} while(0)
#define baseBuffer(b, type) ((type *) (b)->base)
#define topBuffer(b, type) ((type *) (b)->top)
#define inBuffer(b, addr) ((char *) (addr) >= (b)->base && \
@ -91,7 +80,6 @@ Buffer codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide);
#define emptyBuffer(b) ((b)->top = (b)->base)
#define isEmptyBuffer(b) ((b)->top == (b)->base)
#ifdef BUFFER_USES_MALLOC
#define discardBuffer(b) \
do \
{ if ( (b)->base && (b)->base != (b)->static_buffer ) \
@ -99,14 +87,14 @@ Buffer codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide);
(b)->base = (b)->static_buffer; \
} \
} while(0)
#else
#define discardBuffer(b) \
do \
{ if ( (b)->base && (b)->base != (b)->static_buffer ) \
{ freeHeap((b)->base, (b)->max - (b)->base); \
(b)->base = (b)->static_buffer; \
} \
} while(0)
#endif
/*******************************
* FUNCTIONS *
*******************************/
COMMON(Buffer) findBuffer(int flags);
COMMON(int) unfindBuffer(int flags);
COMMON(char *) buffer_string(const char *s, int flags);
#endif /*BUFFER_H_INCLUDED*/

144
packages/PLStream/pl-codelist.c Normal file
View File

@ -0,0 +1,144 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2011, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include "pl-incl.h"
#include "pl-codelist.h"
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide, CVT_code *status)
If l represents a list of codes or characters, return a buffer holding
the characters. If wide == TRUE the buffer contains objects of type
pl_wchar_t. Otherwise it contains traditional characters.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
Buffer
codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide, CVT_result *result)
{ GET_LD
Buffer b;
word list = valHandle(l);
word slow;
Word arg, tail;
int step_slow = TRUE;
enum { CHARS, CODES } type;
if ( isList(list) )
{ intptr_t c = -1;
arg = argTermP(list, 0);
deRef(arg);
if ( isTaggedInt(*arg) )
{ c = valInt(*arg);
type = CODES;
} else
{ c = charCode(*arg);
type = CHARS;
}
result->culprit = *arg;
if ( c < 0 || (!wide && c > 0xff) )
{ if ( canBind(*arg) )
result->status = CVT_partial;
else if ( c < 0 )
result->status = CVT_nocode;
else if ( c > 0xff )
result->status = CVT_wide;
return NULL;
}
} else if ( isNil(list) )
{ return findBuffer(flags);
} else
{ if ( canBind(list) )
result->status = CVT_partial;
else
result->status = CVT_nolist;
return NULL;
}
b = findBuffer(flags);
slow = list;
while( isList(list) )
{ intptr_t c = -1;
arg = argTermP(list, 0);
deRef(arg);
switch(type)
{ case CODES:
if ( isTaggedInt(*arg) )
c = valInt(*arg);
break;
case CHARS:
c = charCode(*arg);
break;
}
if ( c < 0 || (!wide && c > 0xff) )
{ result->culprit = *arg;
unfindBuffer(flags); /* TBD: check unicode range */
if ( canBind(*arg) )
result->status = CVT_partial;
else if ( c < 0 )
result->status = (type == CODES ? CVT_nocode : CVT_nochar);
else if ( c > 0xff )
result->status = CVT_wide;
return NULL;
}
if ( wide )
addBuffer(b, (pl_wchar_t)c, pl_wchar_t);
else
addBuffer(b, (unsigned char)c, unsigned char);
tail = argTermP(list, 1);
deRef(tail);
list = *tail;
if ( list == slow ) /* cyclic */
{ unfindBuffer(flags);
result->status = CVT_nolist;
return NULL;
}
if ( (step_slow = !step_slow) )
{ tail = argTermP(slow, 1);
deRef(tail);
slow = *tail;
}
}
if ( !isNil(list) )
{ unfindBuffer(flags);
if ( canBind(list) )
result->status = CVT_partial;
else
result->status = CVT_nolist;
return NULL;
}
result->status = CVT_ok;
return b;
}

33
packages/PLStream/pl-codelist.h Normal file
View File

@ -0,0 +1,33 @@
#ifndef PL_CODELIST_H
#define PL_CODELIST_H
static inline Word
INIT_SEQ_STRING(size_t n)
{
return (Word)YAP_OpenList(n);
}
static inline Word
EXTEND_SEQ_CODES(Word gstore, int c) {
return (Word)YAP_ExtendList((YAP_Term)gstore, YAP_MkIntTerm(c));
}
static inline Word
EXTEND_SEQ_CHARS(Word gstore, int c) {
return (Word)YAP_ExtendList((YAP_Term)gstore, codeToAtom(c));
}
static inline int
CLOSE_SEQ_STRING(Word gstore, Word lp, word arg2, word arg3, term_t l) {
if (arg2 == 0) {
if (!YAP_CloseList((YAP_Term)gstore, YAP_TermNil()))
return FALSE;
} else {
if (!YAP_CloseList((YAP_Term)gstore, YAP_GetFromSlot(arg2)))
return FALSE;
}
return YAP_Unify(YAP_GetFromSlot(arg3), (YAP_Term)lp);
}
#endif

61
packages/PLStream/pl-ctype.c
View File

@ -35,9 +35,6 @@ This module defines:
See manual for details.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define CHAR_MODE 0
#define CODE_MODE 1
#define CTX_CHAR 0 /* Class(Char) */
#define CTX_CODE 1 /* Class(Int) */
@ -61,30 +58,12 @@ typedef struct
} generator;
static int unicode_separator(wint_t c);
static int
iswhite(wint_t chr)
{ return chr == ' ' || chr == '\t';
}
#ifdef __YAP_PROLOG__
#include "pl-umap.c" /* Unicode map */
#define CharTypeW(c, t, w) \
((unsigned)(c) <= 0xff ? (_PL_char_types[(unsigned)(c)] t) \
: (uflagsW(c) & w))
#define PlBlankW(c) CharTypeW(c, <= SP, U_SEPARATOR)
inline int
unicode_separator(wint_t c)
{ return PlBlankW(c);
}
#endif
static int
fiscsym(wint_t chr)
{ return iswalnum(chr) || chr == '_';
@ -255,6 +234,7 @@ static const char_type char_types[] =
{ NULL_ATOM, NULL }
};
static const char_type *
char_type_by_name(atom_t name, int arity)
{ const char_type *cc;
@ -285,12 +265,14 @@ advanceGen(generator *gen)
static int
unify_char_type(term_t type, const char_type *ct, int context, int how)
{ if ( ct->arity == 0 )
return PL_unify_atom(type, ct->name);
else /*if ( ct->arity == 1 )*/
{ GET_LD
if ( ct->arity == 0 )
{ return PL_unify_atom(type, ct->name);
} else /*if ( ct->arity == 1 )*/
{ if ( PL_unify_functor(type, PL_new_functor(ct->name, 1)) )
{ term_t a = PL_new_term_ref();
_PL_get_arg(1, type, a);
if ( ct->ctx_type == CTX_CHAR )
@ -788,11 +770,11 @@ PRED_IMPL("setlocale", 3, setlocale, 0)
*******************************/
BeginPredDefs(ctype)
PRED_DEF("swi_char_type", 2, char_type, PL_FA_NONDETERMINISTIC)
PRED_DEF("swi_code_type", 2, code_type, PL_FA_NONDETERMINISTIC)
PRED_DEF("char_type", 2, char_type, PL_FA_NONDETERMINISTIC)
PRED_DEF("code_type", 2, code_type, PL_FA_NONDETERMINISTIC)
PRED_DEF("setlocale", 3, setlocale, 0)
PRED_DEF("swi_downcase_atom", 2, downcase_atom, 0)
PRED_DEF("swi_upcase_atom", 2, upcase_atom, 0)
PRED_DEF("downcase_atom", 2, downcase_atom, 0)
PRED_DEF("upcase_atom", 2, upcase_atom, 0)
PRED_DEF("normalize_space", 2, normalize_space, 0)
EndPredDefs
@ -876,9 +858,6 @@ initEncoding(void)
}
}
#if __YAP_PROLOG__
PL_register_extensions(PL_predicates_from_ctype);
#endif
return LD->encoding;
}
@ -888,22 +867,6 @@ initEncoding(void)
void
initCharTypes(void)
{
initEncoding();
{ initEncoding();
}
#if __SWI_PROLOG__
bool
systemMode(bool accept)
{ GET_LD
bool old = SYSTEM_MODE ? TRUE : FALSE;
if ( accept )
debugstatus.styleCheck |= DOLLAR_STYLE;
else
debugstatus.styleCheck &= ~DOLLAR_STYLE;
return old;
}
#endif

5
packages/PLStream/pl-ctype.h
View File

@ -46,6 +46,7 @@ extern const char _PL_char_types[]; /* array of character types */
#define isSolo(c) (_PL_char_types[(unsigned)(c) & 0xff] == SO)
#define isAlpha(c) (_PL_char_types[(unsigned)(c) & 0xff] >= UC)
#define isLetter(c) (isLower(c) || isUpper(c))
#define isSign(c) ((c) == '-' || (c) == '+')
#define toLower(c) ((c) + 'a' - 'A')
#define makeLower(c) ((c) >= 'A' && (c) <= 'Z' ? toLower(c) : (c))
@ -80,7 +81,3 @@ extern const char _PL_char_types[]; /* array of character types */
#define toLowerW(c) ((unsigned)(c) <= 'Z' ? (c) + 'a' - 'A' : towlower(c))
#define makeLowerW(c) ((c) >= 'A' && (c) <= 'Z' ? toLower(c) : towlower(c))
#ifndef HAVE_STRICMP
int stricmp(const char *s1, const char *s2);
#endif

61
packages/PLStream/pl-dtoa.c Normal file
View File

@ -0,0 +1,61 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2010, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include "pl-incl.h"
#include "pl-dtoa.h"
#define IEEE_8087 1
#define MALLOC PL_malloc
#define FREE PL_free
#ifdef _REENTRANT
#define Long int /* 32-bits */
#define MULTIPLE_THREADS
/* TBD: Use the pl-thread.[ch] locks for better speed on Windows
*/
static pthread_mutex_t mutex_0 = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t mutex_1 = PTHREAD_MUTEX_INITIALIZER;
static inline void
ACQUIRE_DTOA_LOCK(int n)
{ if ( n == 0 )
pthread_mutex_lock(&mutex_0);
else
pthread_mutex_lock(&mutex_1);
}
static inline void
FREE_DTOA_LOCK(int n)
{ if ( n == 0 )
pthread_mutex_unlock(&mutex_0);
else
pthread_mutex_unlock(&mutex_1);
}
#endif /*MULTIPLE_THREADS*/
#include "dtoa.c"

35
packages/PLStream/pl-dtoa.h Normal file
View File

@ -0,0 +1,35 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2010, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifndef PL_DTOA_H_INCLUDED
#define PL_DTOA_H_INCLUDED
#define strtod PL_strtod /* avoid library conflicts */
COMMON(char *) dtoa(double dd, int mode, int ndigits,
int *decpt, int *sign, char **rve);
COMMON(void) freedtoa(char *s);
double strtod(const char *in, char **end);
#endif /*PL_DTOA_H_INCLUDED*/

766
packages/PLStream/pl-error.c
View File

@ -1,8 +1,669 @@
#include "pl-incl.h"
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
throw(error(<Formal>, <SWI-Prolog>))
<SWI-Prolog> ::= context(Name/Arity, Message)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#include "pl-incl.h"
/* BeOS has EACCES defined elsewhere, but errno is here */
#if !defined(EACCES) || defined(__BEOS__)
#include <errno.h>
#endif
static int
put_name_arity(term_t t, functor_t f)
{ GET_LD
FunctorDef fdef = valueFunctor(f);
term_t a;
if ( (a=PL_new_term_refs(2)) )
{ PL_put_atom(a+0, fdef->name);
return (PL_put_integer(a+1, fdef->arity) &&
PL_cons_functor(t, FUNCTOR_divide2, a+0, a+1));
}
return FALSE;
}
static void
rewrite_callable(atom_t *expected, term_t actual)
{ GET_LD
term_t a = 0;
int loops = 0;
while ( PL_is_functor(actual, FUNCTOR_colon2) )
{ if ( !a )
a = PL_new_term_ref();
_PL_get_arg(1, actual, a);
if ( !PL_is_atom(a) )
{ *expected = ATOM_atom;
PL_put_term(actual, a);
return;
} else
{ _PL_get_arg(2, actual, a);
PL_put_term(actual, a);
}
if ( ++loops > 100 && !PL_is_acyclic(actual) )
break;
}
}
int
PL_error(const char *pred, int arity, const char *msg, PL_error_code id, ...)
{ GET_LD
Definition caller;
term_t except, formal, swi;
va_list args;
int do_throw = FALSE;
fid_t fid;
int rc;
if ( environment_frame )
caller = environment_frame->predicate;
else
caller = NULL;
if ( id == ERR_FILE_OPERATION &&
!truePrologFlag(PLFLAG_FILEERRORS) )
fail;
if ( msg == MSG_ERRNO )
{ if ( errno == EPLEXCEPTION )
return FALSE;
msg = OsError();
}
LD->exception.processing = TRUE; /* allow using spare stack */
if ( !(fid = PL_open_foreign_frame()) )
goto nomem;
except = PL_new_term_ref();
formal = PL_new_term_ref();
swi = PL_new_term_ref();
/* build (ISO) formal part */
va_start(args, id);
switch(id)
{ case ERR_INSTANTIATION:
err_instantiation:
rc = PL_unify_atom(formal, ATOM_instantiation_error);
break;
case ERR_UNINSTANTIATION:
{ int argn = va_arg(args, int);
term_t bound = va_arg(args, term_t);
char buf[50];
if ( !msg && argn > 0 )
{ Ssprintf(buf, "%d-%s argument",
argn, argn == 1 ? "st" : argn == 2 ? "nd" : "th");
msg = buf;
}
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_uninstantiation_error1,
PL_TERM, bound);
break;
}
case ERR_TYPE: /* ERR_INSTANTIATION if var(actual) */
{ atom_t expected = va_arg(args, atom_t);
term_t actual = va_arg(args, term_t);
if ( expected == ATOM_callable )
rewrite_callable(&expected, actual);
if ( PL_is_variable(actual) && expected != ATOM_variable )
goto err_instantiation;
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_ATOM, expected,
PL_TERM, actual);
break;
}
case ERR_CHARS_TYPE: /* ERR_INSTANTIATION if var(actual) */
{ const char *expected = va_arg(args, const char*);
term_t actual = va_arg(args, term_t);
if ( PL_is_variable(actual) && !streq(expected, "variable") )
goto err_instantiation;
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_CHARS, expected,
PL_TERM, actual);
break;
}
case ERR_AR_TYPE: /* arithmetic type error */
{ atom_t expected = va_arg(args, atom_t);
Number num = va_arg(args, Number);
term_t actual = PL_new_term_ref();
rc = (_PL_put_number(actual, num) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_ATOM, expected,
PL_TERM, actual));
break;
}
case ERR_AR_UNDEF:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_undefined);
break;
}
case ERR_AR_OVERFLOW:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_float_overflow);
break;
}
case ERR_AR_UNDERFLOW:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_float_underflow);
break;
}
case ERR_DOMAIN: /* ERR_INSTANTIATION if var(arg) */
{ atom_t domain = va_arg(args, atom_t);
term_t arg = va_arg(args, term_t);
if ( PL_is_variable(arg) )
goto err_instantiation;
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_domain_error2,
PL_ATOM, domain,
PL_TERM, arg);
break;
}
case ERR_REPRESENTATION:
{ atom_t what = va_arg(args, atom_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_representation_error1,
PL_ATOM, what);
break;
}
case ERR_MODIFY_STATIC_PROC:
{ Procedure proc = va_arg(args, Procedure);
term_t pred = PL_new_term_ref();
rc = (unify_definition(MODULE_user, pred, proc->definition, 0,
GP_NAMEARITY|GP_HIDESYSTEM) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, ATOM_modify,
PL_ATOM, ATOM_static_procedure,
PL_TERM, pred));
break;
}
case ERR_MODIFY_THREAD_LOCAL_PROC:
{ Procedure proc = va_arg(args, Procedure);
term_t pred = PL_new_term_ref();
rc = (unify_definition(MODULE_user, pred, proc->definition, 0,
GP_NAMEARITY|GP_HIDESYSTEM) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, ATOM_modify,
PL_ATOM, ATOM_thread_local_procedure,
PL_TERM, pred));
break;
}
case ERR_UNDEFINED_PROC:
{ Definition def = va_arg(args, Definition);
Definition clr = va_arg(args, Definition);
term_t pred = PL_new_term_ref();
if ( clr )
caller = clr;
rc = (unify_definition(MODULE_user, pred, def, 0, GP_NAMEARITY) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, ATOM_procedure,
PL_TERM, pred));
break;
}
case ERR_PERMISSION_PROC:
{ atom_t op = va_arg(args, atom_t);
atom_t type = va_arg(args, atom_t);
predicate_t pred = va_arg(args, predicate_t);
term_t pi = PL_new_term_ref();
rc = ( PL_unify_predicate(pi, pred, GP_NAMEARITY|GP_HIDESYSTEM) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, op,
PL_ATOM, type,
PL_TERM, pi));
break;
}
case ERR_NOT_IMPLEMENTED_PROC:
{ const char *name = va_arg(args, const char *);
int arity = va_arg(args, int);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_not_implemented2,
PL_ATOM, ATOM_procedure,
PL_FUNCTOR, FUNCTOR_divide2,
PL_CHARS, name,
PL_INT, arity);
break;
}
case ERR_FAILED:
{ term_t goal = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_failure_error1,
PL_TERM, goal);
break;
}
case ERR_EVALUATION:
{ atom_t what = va_arg(args, atom_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, what);
break;
}
case ERR_NOT_EVALUABLE:
{ functor_t f = va_arg(args, functor_t);
term_t actual = PL_new_term_ref();
rc = (put_name_arity(actual, f) &&
PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_type_error2,
PL_ATOM, ATOM_evaluable,
PL_TERM, actual));
break;
}
case ERR_DIV_BY_ZERO:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_evaluation_error1,
PL_ATOM, ATOM_zero_divisor);
break;
}
case ERR_PERMISSION:
{ atom_t type = va_arg(args, atom_t);
atom_t op = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, type,
PL_ATOM, op,
PL_TERM, obj);
break;
}
case ERR_OCCURS_CHECK:
{ Word p1 = va_arg(args, Word);
Word p2 = va_arg(args, Word);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_occurs_check2,
PL_TERM, wordToTermRef(p1),
PL_TERM, wordToTermRef(p2));
break;
}
case ERR_TIMEOUT:
{ atom_t op = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_timeout_error2,
PL_ATOM, op,
PL_TERM, obj);
break;
}
case ERR_EXISTENCE:
{ atom_t type = va_arg(args, atom_t);
term_t obj = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, type,
PL_TERM, obj);
break;
}
case ERR_FILE_OPERATION:
{ atom_t action = va_arg(args, atom_t);
atom_t type = va_arg(args, atom_t);
term_t file = va_arg(args, term_t);
switch(errno)
{ case EAGAIN:
action = ATOM_lock; /* Hack for file-locking*/
/*FALLTHROUGH*/
case EACCES:
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_permission_error3,
PL_ATOM, action,
PL_ATOM, type,
PL_TERM, file);
break;
case EMFILE:
case ENFILE:
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_max_files);
break;
#ifdef EPIPE
case EPIPE:
if ( !msg )
msg = "Broken pipe";
/*FALLTHROUGH*/
#endif
default: /* what about the other cases? */
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, type,
PL_TERM, file);
break;
}
break;
}
case ERR_STREAM_OP:
{ atom_t action = va_arg(args, atom_t);
term_t stream = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_io_error2,
PL_ATOM, action,
PL_TERM, stream);
break;
}
case ERR_DDE_OP:
{ const char *op = va_arg(args, const char *);
const char *err = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_dde_error2,
PL_CHARS, op,
PL_CHARS, err);
break;
}
case ERR_SHARED_OBJECT_OP:
{ atom_t action = va_arg(args, atom_t);
const char *err = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_shared_object2,
PL_ATOM, action,
PL_CHARS, err);
break;
}
case ERR_NOT_IMPLEMENTED: /* non-ISO */
{ const char *what = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_not_implemented2,
PL_ATOM, ATOM_feature,
PL_CHARS, what);
break;
}
case ERR_RESOURCE:
{ atom_t what = va_arg(args, atom_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, what);
break;
}
case ERR_SYNTAX:
{ const char *what = va_arg(args, const char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_syntax_error1,
PL_CHARS, what);
break;
}
case ERR_NOMEM:
{ rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_no_memory);
break;
}
case ERR_SYSCALL:
{ const char *op = va_arg(args, const char *);
if ( !msg )
msg = op;
switch(errno)
{ case ENOMEM:
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_resource_error1,
PL_ATOM, ATOM_no_memory);
break;
default:
rc = PL_unify_atom(formal, ATOM_system_error);
break;
}
break;
}
case ERR_SHELL_FAILED:
{ term_t cmd = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_shell2,
PL_ATOM, ATOM_execute,
PL_TERM, cmd);
break;
}
case ERR_SHELL_SIGNALLED:
{ term_t cmd = va_arg(args, term_t);
int sig = va_arg(args, int);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_shell2,
PL_FUNCTOR, FUNCTOR_signal1,
PL_INT, sig,
PL_TERM, cmd);
break;
}
case ERR_SIGNALLED:
{ int sig = va_arg(args, int);
char *signame = va_arg(args, char *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_signal2,
PL_CHARS, signame,
PL_INT, sig);
break;
}
case ERR_CLOSED_STREAM:
{ IOSTREAM *s = va_arg(args, IOSTREAM *);
rc = PL_unify_term(formal,
PL_FUNCTOR, FUNCTOR_existence_error2,
PL_ATOM, ATOM_stream,
PL_POINTER, s);
do_throw = TRUE;
break;
}
case ERR_BUSY:
{ atom_t type = va_arg(args, atom_t);
term_t mutex = va_arg(args, term_t);
rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_busy2, type, mutex);
break;
}
case ERR_FORMAT:
{ const char *s = va_arg(args, const char*);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "format", 1,
PL_CHARS, s);
break;
}
case ERR_FORMAT_ARG:
{ const char *s = va_arg(args, const char*);
term_t arg = va_arg(args, term_t);
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "format_argument_type", 2,
PL_CHARS, s,
PL_TERM, arg);
break;
}
default:
assert(0);
}
va_end(args);
/* build SWI-Prolog context term */
if ( rc && (pred || msg || caller) )
{ term_t predterm = PL_new_term_ref();
term_t msgterm = PL_new_term_ref();
if ( pred )
{ rc = PL_unify_term(predterm,
PL_FUNCTOR, FUNCTOR_divide2,
PL_CHARS, pred,
PL_INT, arity);
} else if ( caller )
{ rc = unify_definition(MODULE_user, predterm, caller, 0, GP_NAMEARITY);
}
if ( rc && msg )
{ rc = PL_put_atom_chars(msgterm, msg);
}
if ( rc )
rc = PL_unify_term(swi,
PL_FUNCTOR, FUNCTOR_context2,
PL_TERM, predterm,
PL_TERM, msgterm);
}
if ( rc )
rc = PL_unify_term(except,
PL_FUNCTOR, FUNCTOR_error2,
PL_TERM, formal,
PL_TERM, swi);
if ( !rc )
{ nomem:
fatalError("Cannot report error: no memory");
}
if ( do_throw )
rc = PL_throw(except);
else
rc = PL_raise_exception(except);
PL_close_foreign_frame(fid);
return rc;
}
char *
tostr(char *buf, const char *fmt, ...)
{ va_list args;
va_start(args, fmt);
Svsprintf(buf, fmt, args);
va_end(args);
return buf;
}
/*******************************
* PRINTING MESSAGES *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
printMessage(atom_t severity, ...)
Calls print_message(severity, term), where ... are arguments as for
PL_unify_term(). This predicate saves possible pending exceptions and
restores them to make the call from B_THROW possible.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define OK_RECURSIVE 10
int
printMessage(atom_t severity, ...)
{ GET_LD
wakeup_state wstate;
term_t av;
predicate_t pred = PROCEDURE_print_message2;
va_list args;
int rc;
if ( ++LD->in_print_message >= OK_RECURSIVE*3 )
fatalError("printMessage(): recursive call\n");
if ( !saveWakeup(&wstate, TRUE PASS_LD) )
{ LD->in_print_message--;
return FALSE;
}
av = PL_new_term_refs(2);
va_start(args, severity);
PL_put_atom(av+0, severity);
rc = PL_unify_termv(av+1, args);
va_end(args);
if ( rc )
{ if ( isDefinedProcedure(pred) && LD->in_print_message <= OK_RECURSIVE )
{ rc = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_CATCH_EXCEPTION,
pred, av);
} else if ( LD->in_print_message <= OK_RECURSIVE*2 )
{ Sfprintf(Serror, "Message: ");
rc = PL_write_term(Serror, av+1, 1200, 0);
Sfprintf(Serror, "\n");
} else /* in_print_message == 2 */
{ Sfprintf(Serror, "printMessage(): recursive call\n");
}
}
restoreWakeup(&wstate PASS_LD);
LD->in_print_message--;
return rc;
}
void outOfCore(void) {}
void fatalError(const char *fm, ...) {exit(1);}
void printMessage(int type, ...) {}
/*******************************
* ERROR-CHECKING *_get() *
@ -21,7 +682,7 @@ PL_get_chars_ex(term_t t, char **s, unsigned int flags)
int
PL_get_atom_ex(term_t t, atom_t *a)
PL_get_atom_ex__LD(term_t t, atom_t *a ARG_LD)
{ if ( PL_get_atom(t, a) )
succeed;
@ -31,7 +692,9 @@ PL_get_atom_ex(term_t t, atom_t *a)
int
PL_get_integer_ex(term_t t, int *i)
{ if ( PL_get_integer(t, i) )
{ GET_LD
if ( PL_get_integer(t, i) )
succeed;
if ( PL_is_integer(t) )
@ -43,7 +706,9 @@ PL_get_integer_ex(term_t t, int *i)
int
PL_get_long_ex(term_t t, long *i)
{ if ( PL_get_long(t, i) )
{ GET_LD
if ( PL_get_long(t, i) )
succeed;
if ( PL_is_integer(t) )
@ -55,7 +720,9 @@ PL_get_long_ex(term_t t, long *i)
int
PL_get_int64_ex(term_t t, int64_t *i)
{ if ( PL_get_int64(t, i) )
{ GET_LD
if ( PL_get_int64(t, i) )
succeed;
if ( PL_is_integer(t) )
@ -76,6 +743,28 @@ PL_get_intptr_ex(term_t t, intptr_t *i)
}
int
PL_get_size_ex(term_t t, size_t *i)
{ int64_t val;
if ( !PL_get_int64_ex(t, &val) )
fail;
if ( val < 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_not_less_than_zero, t);
#if SIZEOF_VOIDP < 8
#if SIZEOF_LONG == SIZEOF_VOIDP
if ( val > (int64_t)ULONG_MAX )
return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_size_t);
#endif
#endif
*i = (size_t)val;
return TRUE;
}
int
PL_get_bool_ex(term_t t, int *i)
{ if ( PL_get_bool(t, i) )
@ -103,14 +792,26 @@ PL_get_char_ex(term_t t, int *p, int eof)
}
int
PL_get_pointer_ex(term_t t, void **addrp)
{ GET_LD
if ( PL_get_pointer(t, addrp) )
succeed;
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_address, t);
}
int
PL_unify_list_ex(term_t l, term_t h, term_t t)
{ if ( PL_unify_list(l, h, t) )
{ GET_LD
if ( PL_unify_list(l, h, t) )
succeed;
if ( PL_get_nil(l) )
fail;
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
}
@ -129,12 +830,14 @@ PL_unify_nil_ex(term_t l)
int
PL_get_list_ex(term_t l, term_t h, term_t t)
{ if ( PL_get_list(l, h, t) )
{ GET_LD
if ( PL_get_list(l, h, t) )
succeed;
if ( PL_get_nil(l) )
fail;
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
}
@ -149,18 +852,10 @@ PL_get_nil_ex(term_t l)
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
}
int
PL_get_module_ex(term_t name, module_t *m)
{ if ( !PL_get_module(name, m) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, name);
succeed;
}
int
PL_unify_bool_ex(term_t t, bool val)
{ bool v;
PL_unify_bool_ex(term_t t, int val)
{ GET_LD
bool v;
if ( PL_is_variable(t) )
return PL_unify_atom(t, val ? ATOM_true : ATOM_false);
@ -173,8 +868,27 @@ PL_unify_bool_ex(term_t t, bool val)
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, t);
}
word
notImplemented(char *name, int arity)
{ return (word)PL_error(NULL, 0, NULL, ERR_NOT_IMPLEMENTED_PROC, name, arity);
int
PL_get_arg_ex(int n, term_t term, term_t arg)
{ GET_LD
if ( PL_get_arg(n, term, arg) )
{ succeed;
} else
{ term_t a = PL_new_term_ref();
PL_put_integer(a, n);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_natural, a);
}
}
int
PL_get_module_ex(term_t name, Module *m)
{ if ( !PL_get_module(name, m) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, name);
succeed;
}

122
packages/PLStream/pl-error.h
View File

@ -22,45 +22,89 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#define ERR_NO_ERROR 0
#define ERR_INSTANTIATION 1 /* void */
#define ERR_TYPE 2 /* atom_t expected, term_t value */
#define ERR_DOMAIN 3 /* atom_t domain, term_t value */
#define ERR_REPRESENTATION 4 /* atom_t what */
#define ERR_MODIFY_STATIC_PROC 5 /* predicate_t proc */
#define ERR_EVALUATION 6 /* atom_t what */
#define ERR_AR_TYPE 7 /* atom_t expected, Number value */
#define ERR_NOT_EVALUABLE 8 /* functor_t func */
#define ERR_DIV_BY_ZERO 9 /* void */
#define ERR_FAILED 10 /* predicate_t proc */
#define ERR_FILE_OPERATION 11 /* atom_t action, atom_t type, term_t */
#define ERR_PERMISSION 12 /* atom_t type, atom_t op, term_t obj*/
#define ERR_NOT_IMPLEMENTED_FEATURE 13 /* const char *what */
#define ERR_EXISTENCE 14 /* atom_t type, term_t obj */
#define ERR_STREAM_OP 15 /* atom_t action, term_t obj */
#define ERR_RESOURCE 16 /* atom_t resource */
#define ERR_NOMEM 17 /* void */
#define ERR_SYSCALL 18 /* void */
#define ERR_SHELL_FAILED 19 /* term_t command */
#define ERR_SHELL_SIGNALLED 20 /* term_t command, int signal */
#define ERR_AR_UNDEF 21 /* void */
#define ERR_AR_OVERFLOW 22 /* void */
#define ERR_AR_UNDERFLOW 23 /* void */
#define ERR_UNDEFINED_PROC 24 /* Definition def */
#define ERR_SIGNALLED 25 /* int sig, char *name */
#define ERR_CLOSED_STREAM 26 /* IOSTREAM * */
#define ERR_BUSY 27 /* mutexes */
#define ERR_PERMISSION_PROC 28 /* op, type, Definition */
#define ERR_DDE_OP 29 /* op, error */
#define ERR_SYNTAX 30 /* what */
#define ERR_SHARED_OBJECT_OP 31 /* op, error */
#define ERR_TIMEOUT 32 /* op, object */
#define ERR_NOT_IMPLEMENTED_PROC 33 /* name, arity */
#define ERR_FORMAT 34 /* message */
#define ERR_FORMAT_ARG 35 /* seq, term */
#define ERR_OCCURS_CHECK 36 /* Word, Word */
#define ERR_CHARS_TYPE 37 /* char *, term */
#define ERR_MUST_BE_VAR 38 /* int argn, term_t term */
#ifndef COMMON
#ifndef SO_LOCAL
#ifdef HAVE_VISIBILITY_ATTRIBUTE
#define SO_LOCAL __attribute__((visibility("hidden")))
#else
#define SO_LOCAL
#endif
#endif
#define COMMON(type) SO_LOCAL type
#endif
typedef enum
{ ERR_NO_ERROR = 0,
/* Used in os-directory and maybe elsewhere */
ERR_DOMAIN, /* atom_t domain, term_t value */
ERR_EXISTENCE, /* atom_t type, term_t obj */
ERR_FILE_OPERATION, /* atom_t action, atom_t type, term_t */
ERR_FORMAT, /* message */
ERR_FORMAT_ARG, /* seq, term */
ERR_INSTANTIATION, /* void */
ERR_NOMEM, /* void */
ERR_NOT_IMPLEMENTED, /* const char *what */
ERR_PERMISSION, /* atom_t type, atom_t op, term_t obj*/
ERR_REPRESENTATION, /* atom_t what */
ERR_RESOURCE, /* atom_t resource */
ERR_SHELL_FAILED, /* term_t command */
ERR_SHELL_SIGNALLED, /* term_t command, int signal */
ERR_STREAM_OP, /* atom_t action, term_t obj */
ERR_SYSCALL, /* void */
ERR_TIMEOUT, /* op, object */
ERR_TYPE, /* atom_t expected, term_t value */
ERR_UNINSTANTIATION, /* int argn, term_t term */
/* Only used on SWI-Prolog itself */
ERR_AR_OVERFLOW, /* void */
ERR_AR_TYPE, /* atom_t expected, Number value */
ERR_AR_UNDEF, /* void */
ERR_AR_UNDERFLOW, /* void */
ERR_BUSY, /* mutexes */
ERR_CHARS_TYPE, /* char *, term */
ERR_CLOSED_STREAM, /* IOSTREAM * */
ERR_DDE_OP, /* op, error */
ERR_DIV_BY_ZERO, /* void */
ERR_EVALUATION, /* atom_t what */
ERR_FAILED, /* predicate_t proc */
ERR_MODIFY_STATIC_PROC, /* predicate_t proc */
ERR_MODIFY_THREAD_LOCAL_PROC, /* Procedure proc */
ERR_NOT_EVALUABLE, /* functor_t func */
ERR_NOT_IMPLEMENTED_PROC, /* name, arity */
ERR_OCCURS_CHECK, /* Word, Word */
ERR_PERMISSION_PROC, /* op, type, Definition */
ERR_SHARED_OBJECT_OP, /* op, error */
ERR_SIGNALLED, /* int sig, char *name */
ERR_SYNTAX, /* what */
ERR_UNDEFINED_PROC /* Definition def */
} PL_error_code;
#define MSG_ERRNO ((char *)(-1))
COMMON(int) PL_error(const char *pred, int arity, const char *msg,
PL_error_code id, ...);
COMMON(char *) tostr(char *buf, const char *fmt, ...);
COMMON(int) printMessage(atom_t severity, ...);
COMMON(int) PL_get_nchars_ex(term_t t, size_t *len, char **s,
unsigned int flags);
COMMON(int) PL_get_chars_ex(term_t t, char **s, unsigned int flags);
COMMON(int) PL_get_atom_ex(term_t t, atom_t *a);
#ifdef ARG_LD
COMMON(int) PL_get_atom_ex__LD(term_t t, atom_t *a ARG_LD);
#endif
COMMON(int) PL_get_integer_ex(term_t t, int *i);
COMMON(int) PL_get_long_ex(term_t t, long *i);
COMMON(int) PL_get_int64_ex(term_t t, int64_t *i);
COMMON(int) PL_get_intptr_ex(term_t t, intptr_t *i);
COMMON(int) PL_get_size_ex(term_t t, size_t *i);
COMMON(int) PL_get_bool_ex(term_t t, int *i);
COMMON(int) PL_get_float_ex(term_t t, double *f);
COMMON(int) PL_get_char_ex(term_t t, int *p, int eof);
COMMON(int) PL_get_pointer_ex(term_t t, void **addrp);
COMMON(int) PL_unify_list_ex(term_t l, term_t h, term_t t);
COMMON(int) PL_unify_nil_ex(term_t l);
COMMON(int) PL_get_list_ex(term_t l, term_t h, term_t t);
COMMON(int) PL_get_nil_ex(term_t l);
COMMON(int) PL_unify_bool_ex(term_t t, int val);
COMMON(int) PL_get_arg_ex(int n, term_t term, term_t arg);
COMMON(int) PL_get_module_ex(term_t name, Module *m);

1013
packages/PLStream/pl-file.c
View File

File diff suppressed because it is too large Load Diff

180
packages/PLStream/pl-files.c
View File

@ -23,19 +23,15 @@
*/
#include "pl-incl.h"
#include "pl-utf8.h"
#include <stdio.h>
/**** stuff from uxnt ****/
#ifdef O_XOS
#include "uxnt/uxnt.h"
#endif
#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
#ifdef O_XOS
#define statstruct struct _stat
#define statstruct struct _stati64
#else
#define statstruct struct stat
#define statfunc stat
@ -351,7 +347,7 @@ MarkExecutable(const char *name)
* FIND FILES FROM C *
*********************************/
static int
int
unifyTime(term_t t, time_t time)
{ return PL_unify_float(t, (double)time);
}
@ -374,12 +370,12 @@ add_option(term_t options, functor_t f, atom_t val)
#define CVT_FILENAME (CVT_ATOM|CVT_STRING|CVT_LIST)
int
PL_get_file_name(term_t n, char **namep, int flags)
static int
get_file_name(term_t n, char **namep, char *tmp, int flags)
{ GET_LD
char *name;
char tmp[MAXPATHLEN];
char ospath[MAXPATHLEN];
int chflags;
size_t len;
if ( flags & PL_FILE_SEARCH )
{ fid_t fid;
@ -405,7 +401,12 @@ PL_get_file_name(term_t n, char **namep, int flags)
if ( rc ) rc = PL_unify_nil(options);
if ( rc ) rc = PL_call_predicate(NULL, cflags, pred, av);
if ( rc ) rc = PL_get_chars_ex(av+1, namep, CVT_ATOMIC|BUF_RING|REP_FN);
if ( rc ) rc = PL_get_nchars(av+1, &len, namep,
CVT_ATOMIC|BUF_RING|REP_FN);
if ( rc && strlen(*namep) != len )
{ n = av+1;
goto code0;
}
PL_discard_foreign_frame(fid);
return rc;
@ -414,12 +415,17 @@ PL_get_file_name(term_t n, char **namep, int flags)
return FALSE;
}
if ( flags & PL_FILE_NOERRORS )
{ if ( !PL_get_chars(n, &name, CVT_FILENAME|REP_FN) )
return FALSE;
} else
{ if ( !PL_get_chars_ex(n, &name, CVT_FILENAME|REP_FN) )
return FALSE;
chflags = CVT_FILENAME;
if ( !(flags&(REP_UTF8|REP_MB)) )
chflags |= REP_FN;
if ( !(flags & PL_FILE_NOERRORS) )
chflags |= CVT_EXCEPTION;
if ( !PL_get_nchars(n, &len, &name, chflags) )
return FALSE;
if ( strlen(name) != len )
{ code0:
return PL_error(NULL, 0, "file name contains a 0-code",
ERR_DOMAIN, ATOM_file_name, n);
}
if ( truePrologFlag(PLFLAG_FILEVARS) )
@ -430,6 +436,10 @@ PL_get_file_name(term_t n, char **namep, int flags)
if ( !(flags & PL_FILE_NOERRORS) )
{ atom_t op = 0;
if ( (flags&(PL_FILE_READ|PL_FILE_WRITE|PL_FILE_EXECUTE|PL_FILE_EXIST)) &&
!AccessFile(name, ACCESS_EXIST) )
return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_file, n);
if ( (flags&PL_FILE_READ) && !AccessFile(name, ACCESS_READ) )
op = ATOM_read;
if ( !op && (flags&PL_FILE_WRITE) && !AccessFile(name, ACCESS_WRITE) )
@ -438,10 +448,7 @@ PL_get_file_name(term_t n, char **namep, int flags)
op = ATOM_execute;
if ( op )
return PL_error(NULL, 0, NULL, ERR_PERMISSION, ATOM_file, op, n);
if ( (flags & PL_FILE_EXIST) && !AccessFile(name, ACCESS_EXIST) )
return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_file, n);
return PL_error(NULL, 0, NULL, ERR_PERMISSION, op, ATOM_file, n);
}
if ( flags & PL_FILE_ABSOLUTE )
@ -449,13 +456,61 @@ PL_get_file_name(term_t n, char **namep, int flags)
return FALSE;
}
if ( flags & PL_FILE_OSPATH )
{ if ( !(name = OsPath(name, ospath)) )
return FALSE;
*namep = buffer_string(name, BUF_RING);
return TRUE;
}
int
PL_get_file_name(term_t n, char **namep, int flags)
{ char buf[MAXPATHLEN];
char ospath[MAXPATHLEN];
char *name;
int rc;
if ( (rc=get_file_name(n, &name, buf, flags)) )
{ if ( (flags & PL_FILE_OSPATH) )
{ if ( !(name = OsPath(name, ospath)) )
return FALSE;
}
*namep = buffer_string(name, BUF_RING);
}
*namep = buffer_string(name, BUF_RING);
return TRUE;
return rc;
}
int
PL_get_file_nameW(term_t n, wchar_t **namep, int flags)
{ char buf[MAXPATHLEN];
char ospath[MAXPATHLEN];
char *name;
int rc;
if ( (rc=get_file_name(n, &name, buf, flags|REP_UTF8)) )
{ Buffer b;
const char *s;
if ( (flags & PL_FILE_OSPATH) )
{ if ( !(name = OsPath(name, ospath)) )
return FALSE;
}
b = findBuffer(BUF_RING);
for(s = name; *s; )
{ int chr;
s = utf8_get_char(s, &chr);
addBuffer(b, (wchar_t)chr, wchar_t);
}
addBuffer(b, (wchar_t)0, wchar_t);
*namep = baseBuffer(b, wchar_t);
}
return rc;
}
@ -686,7 +741,7 @@ PRED_IMPL("tmp_file_stream", 3, tmp_file_stream, 0)
if ( !PL_unify_atom(A2, fn) )
{ close(fd);
return PL_error(NULL, 0, NULL, ERR_MUST_BE_VAR, 2);
return PL_error(NULL, 0, NULL, ERR_UNINSTANTIATION, 2, A2);
}
s = Sfdopen(fd, mode);
@ -823,8 +878,9 @@ PRED_IMPL("working_directory", 2, working_directory, 0)
if ( truePrologFlag(PLFLAG_FILEERRORS) )
return PL_error(NULL, 0, NULL, ERR_FILE_OPERATION,
ATOM_chdir, ATOM_directory, new);
return FALSE;
}
return FALSE;
}
return TRUE;
@ -858,7 +914,7 @@ has_extension(const char *name, const char *ext)
static int
name_too_long(void)
name_too_long()
{ return PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_path_length);
}
@ -891,12 +947,8 @@ PRED_IMPL("file_name_extension", 3, file_name_extension, 0)
} else
{ TRY(PL_unify_chars(ext, PL_ATOM|REP_FN, -1, &s[1]));
}
if ( s-f > MAXPATHLEN )
return name_too_long();
strncpy(buf, f, s-f);
buf[s-f] = EOS;
return PL_unify_chars(base, PL_ATOM|REP_FN, -1, buf);
return PL_unify_chars(base, PL_ATOM|REP_FN, s-f, f);
}
if ( PL_unify_atom_chars(ext, "") &&
PL_unify(full, base) )
@ -977,35 +1029,6 @@ PRED_IMPL("mark_executable", 1, mark_executable, 0)
}
/*******************************
* PUBLISH PREDICATES *
*******************************/
BeginPredDefs(files)
PRED_DEF("swi_working_directory", 2, working_directory, 0)
PRED_DEF("swi_access_file", 2, access_file, 0)
PRED_DEF("swi_time_file", 2, time_file, 0)
PRED_DEF("swi_size_file", 2, size_file, 0)
PRED_DEF("swi_read_link", 3, read_link, 0)
PRED_DEF("swi_exists_file", 1, exists_file, 0)
PRED_DEF("swi_exists_directory", 1, exists_directory, 0)
PRED_DEF("swi_tmp_file", 2, tmp_file, 0)
PRED_DEF("swi_tmp_file_stream", 3, tmp_file_stream, 0)
PRED_DEF("swi_delete_file", 1, delete_file, 0)
PRED_DEF("swi_delete_directory", 1, delete_directory, 0)
PRED_DEF("swi_make_directory", 1, make_directory, 0)
PRED_DEF("swi_same_file", 2, same_file, 0)
PRED_DEF("swi_rename_file", 2, rename_file, 0)
PRED_DEF("swi_is_absolute_file_name", 1, is_absolute_file_name, 0)
PRED_DEF("swi_file_base_name", 2, file_base_name, 0)
PRED_DEF("swi_file_directory_name", 2, file_directory_name, 0)
PRED_DEF("swi_file_name_extension", 3, file_name_extension, 0)
PRED_DEF("swi_prolog_to_os_filename", 2, prolog_to_os_filename, 0)
PRED_DEF("swi_$mark_executable", 1, mark_executable, 0)
PRED_DEF("swi_$absolute_file_name", 2, absolute_file_name, 0)
EndPredDefs
/*******************************
* INIT *
*******************************/
@ -1013,6 +1036,33 @@ EndPredDefs
void
initFiles(void)
{
PL_register_extensions(PL_predicates_from_files);
}
/*******************************
* PUBLISH PREDICATES *
*******************************/
BeginPredDefs(files)
PRED_DEF("working_directory", 2, working_directory, 0)
PRED_DEF("access_file", 2, access_file, 0)
PRED_DEF("time_file", 2, time_file, 0)
PRED_DEF("size_file", 2, size_file, 0)
PRED_DEF("read_link", 3, read_link, 0)
PRED_DEF("exists_file", 1, exists_file, 0)
PRED_DEF("exists_directory", 1, exists_directory, 0)
PRED_DEF("tmp_file", 2, tmp_file, 0)
PRED_DEF("tmp_file_stream", 3, tmp_file_stream, 0)
PRED_DEF("delete_file", 1, delete_file, 0)
PRED_DEF("delete_directory", 1, delete_directory, 0)
PRED_DEF("make_directory", 1, make_directory, 0)
PRED_DEF("same_file", 2, same_file, 0)
PRED_DEF("rename_file", 2, rename_file, 0)
PRED_DEF("is_absolute_file_name", 1, is_absolute_file_name, 0)
PRED_DEF("file_base_name", 2, file_base_name, 0)
PRED_DEF("file_directory_name", 2, file_directory_name, 0)
PRED_DEF("file_name_extension", 3, file_name_extension, 0)
PRED_DEF("prolog_to_os_filename", 2, prolog_to_os_filename, 0)
PRED_DEF("$mark_executable", 1, mark_executable, 0)
PRED_DEF("$absolute_file_name", 2, absolute_file_name, 0)
EndPredDefs

41
packages/PLStream/pl-files.h Normal file
View File

@ -0,0 +1,41 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2008, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifndef PL_FILES_H_INCLUDED
#define PL_FILES_H_INCLUDED
#define ACCESS_EXIST 0 /* AccessFile() modes */
#define ACCESS_EXECUTE 1
#define ACCESS_READ 2
#define ACCESS_WRITE 4
COMMON(void) initFiles(void);
COMMON(time_t) LastModifiedFile(const char *f);
COMMON(int) RemoveFile(const char *path);
COMMON(int) AccessFile(const char *path, int mode);
COMMON(char *) DeRefLink(const char *link, char *buf);
COMMON(int) ExistsFile(const char *path);
COMMON(int) ExistsDirectory(const char *path);
#endif /*PL_FILES_H_INCLUDED*/

1042
packages/PLStream/pl-fmt.c Normal file
View File

File diff suppressed because it is too large Load Diff

13
packages/PLStream/pl-glob.c
View File

@ -653,14 +653,7 @@ PRED_IMPL("directory_files", 2, directory_files, 0)
*******************************/
BeginPredDefs(glob)
PRED_DEF("swi_expand_file_name", 2, expand_file_name, 0)
PRED_DEF("swi_wildcard_match", 2, wildcard_match, 0)
PRED_DEF("swi_directory_files", 2, directory_files, 0)
PRED_DEF("expand_file_name", 2, expand_file_name, 0)
PRED_DEF("wildcard_match", 2, wildcard_match, 0)
PRED_DEF("directory_files", 2, directory_files, 0)
EndPredDefs
void
initGlob(void)
{
PL_register_extensions(PL_predicates_from_glob);
}

309
packages/PLStream/pl-incl.h
View File

@ -14,6 +14,37 @@
#include <SWI-Stream.h>
#include <SWI-Prolog.h>
typedef int bool;
typedef int Char; /* char that can pass EOF */
typedef uintptr_t word; /* Anonymous 4 byte object */
#if SIZE_DOUBLE==SIZEOF_INT_P
#define WORDS_PER_DOUBLE 1
#else
#define WORDS_PER_DOUBLE 2
#endif
// numbers
typedef enum
{ V_INTEGER, /* integer (64-bit) value */
#ifdef O_GMP
V_MPZ, /* mpz_t */
V_MPQ, /* mpq_t */
#endif
V_FLOAT /* Floating point number (double) */
} numtype;
typedef struct
{ numtype type; /* type of number */
union { double f; /* value as real */
int64_t i; /* value as integer */
word w[WORDS_PER_DOUBLE]; /* for packing/unpacking the double */
#ifdef O_GMP
mpz_t mpz; /* GMP integer */
mpq_t mpq; /* GMP rational */
#endif
} value;
} number, *Number;
#define Arg(N) (PL__t0+((n)-1))
#define A1 (PL__t0)
@ -58,6 +89,7 @@ typedef int pthread_t;
#include <pthread.h>
#endif
#endif
typedef uintptr_t PL_atomic_t; /* same a word */
#define MAXSIGNAL 64
@ -85,20 +117,106 @@ typedef int pthread_t;
*********************************/
#include "pl-table.h"
/********************************
* OS *
*********************************/
#include "pl-os.h"
/********************************
* Error *
*********************************/
#include "pl-error.h"
/********************************
* Files *
*********************************/
#include "pl-files.h"
/********************************
* BUFFERS *
*********************************/
#define BUFFER_RING_SIZE 16 /* foreign buffer ring (pl-fli.c) */
#include "pl-buffer.h"
/*******************************
* OPTION LISTS *
*******************************/
#include "pl-opts.h"
#include "pl-option.h"
/*******************************
* TEXT PROCESSING *
*******************************/
typedef enum
{ CVT_ok = 0, /* Conversion ok */
CVT_wide, /* Conversion needs wide characters */
CVT_partial, /* Input list is partial */
CVT_nolist, /* Input list is not a list */
CVT_nocode, /* List contains a non-code */
CVT_nochar /* List contains a non-char */
} CVT_status;
typedef struct
{ CVT_status status;
word culprit; /* for CVT_nocode/CVT_nochar */
} CVT_result;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Operator types. NOTE: if you change OP_*, check operatorTypeToAtom()!
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define OP_MAXPRIORITY 1200 /* maximum operator priority */
#define OP_PREFIX 0
#define OP_INFIX 1
#define OP_POSTFIX 2
#define OP_MASK 0xf
#define OP_FX (0x10|OP_PREFIX)
#define OP_FY (0x20|OP_PREFIX)
#define OP_XF (0x30|OP_POSTFIX)
#define OP_YF (0x40|OP_POSTFIX)
#define OP_XFX (0x50|OP_INFIX)
#define OP_XFY (0x60|OP_INFIX)
#define OP_YFX (0x70|OP_INFIX)
#define CHARESCAPE (0x0004) /* module */
/*******************************
* COMPARE *
*******************************/
/* Results from comparison operations. Mostly used by compareStandard() */
#define CMP_ERROR -2 /* Error (out of memory) */
#define CMP_LESS -1 /* < */
#define CMP_EQUAL 0 /* == */
#define CMP_GREATER 1 /* > */
#define CMP_NOTEQ 2 /* \== */
/*******************************
* NUMBERVARS *
*******************************/
typedef enum
{ AV_BIND,
AV_SKIP,
AV_ERROR
} av_action;
typedef struct
{ functor_t functor; /* Functor to use ($VAR/1) */
av_action on_attvar; /* How to handle attvars */
int singletons; /* Write singletons as $VAR('_') */
} nv_options;
/*******************************
* LIST BUILDING *
@ -119,29 +237,6 @@ typedef struct counting_mutex
struct counting_mutex *next; /* next of allocated chain */
} counting_mutex;
// numbers
typedef enum
{ V_INTEGER, /* integer (64-bit) value */
#ifdef O_GMP
V_MPZ, /* mpz_t */
V_MPQ, /* mpq_t */
#endif
V_REAL /* Floating point number (double) */
} numtype;
typedef struct
{ numtype type; /* type of number */
union { double f; /* value as real */
int64_t i; /* value as integer */
word w[WORDS_PER_DOUBLE]; /* for packing/unpacking the double */
#ifdef O_GMP
mpz_t mpz; /* GMP integer */
mpq_t mpq; /* GMP rational */
#endif
} value;
} number, *Number;
typedef enum
{ CLN_NORMAL = 0, /* Normal mode */
CLN_ACTIVE, /* Started cleanup */
@ -253,6 +348,7 @@ typedef struct {
int threads_finished; /* # finished threads */
double thread_cputime; /* Total CPU time of threads */
#endif
double start_time; /* When Prolog was started */
} statistics;
struct
@ -290,6 +386,46 @@ typedef struct {
} thread;
#endif /*O_PLMT*/
struct /* pl-format.c */
{ Table predicates;
} format;
struct
{/* Procedure dgarbage_collect1; */
/* Procedure catch3; */
/* Procedure true0; */
/* Procedure fail0; */
/* Procedure equals2; /\* =/2 *\/ */
/* Procedure is2; /\* is/2 *\/ */
/* Procedure strict_equal2; /\* ==/2 *\/ */
/* Procedure event_hook1; */
/* Procedure exception_hook4; */
/* Procedure print_message2; */
/* Procedure foreign_registered2; /\* $foreign_registered/2 *\/ */
/* Procedure prolog_trace_interception4; */
predicate_t portray; /* portray/1 */
/* Procedure dcall1; /\* $call/1 *\/ */
/* Procedure setup_call_catcher_cleanup4; /\* setup_call_catcher_cleanup/4 *\/ */
/* Procedure undefinterc4; /\* $undefined_procedure/4 *\/ */
/* Procedure dthread_init0; /\* $thread_init/0 *\/ */
/* Procedure dc_call_prolog0; /\* $c_call_prolog/0 *\/ */
/* #ifdef O_ATTVAR */
/* Procedure dwakeup1; /\* system:$wakeup/1 *\/ */
predicate_t portray_attvar1; /* $attvar:portray_attvar/1 */
/* #endif */
/* #ifdef O_CALL_RESIDUE */
/* Procedure call_residue_vars2; /\* $attvar:call_residue_vars/2 *\/ */
/* #endif */
/* SourceFile reloading; /\* source file we are re-loading *\/ */
/* int active_marked; /\* #prodedures marked active *\/ */
/* int static_dirty; /\* #static dirty procedures *\/ */
/* #ifdef O_CLAUSEGC */
/* DefinitionChain dirty; /\* List of dirty static procedures *\/ */
/* #endif */
} procedures;
} gds_t;
extern gds_t gds;
@ -385,8 +521,8 @@ it mean anything?
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* vsc: needs defining */
#define startCritical
#define endCritical
#define startCritical TRUE
#define endCritical TRUE
/* The LD macro layer */
typedef struct PL_local_data {
@ -461,9 +597,11 @@ typedef struct PL_local_data {
} exception;
const char *float_format; /* floating point format */
buffer discardable_buffer; /* PL_*() character buffers */
buffer buffer_ring[BUFFER_RING_SIZE];
int current_buffer_id;
struct {
buffer _discardable_buffer; /* PL_*() character buffers */
buffer _buffer_ring[BUFFER_RING_SIZE];
int _current_buffer_id;
} fli;
} PL_local_data_t;
@ -603,6 +741,20 @@ int defFeature(const char *c, int f, ...);
int trueFeature(int f);
/*******************************
* WAKEUP *
*******************************/
#define WAKEUP_STATE_WAKEUP 0x1
#define WAKEUP_STATE_EXCEPTION 0x2
#define WAKEUP_STATE_SKIP_EXCEPTION 0x4
typedef struct wakeup_state
{ fid_t fid; /* foreign frame reference */
int flags;
} wakeup_state;
/*******************************
* STREAM I/O *
*******************************/
@ -716,7 +868,7 @@ extern IOSTREAM ** /* provide access to Suser_input, */
#define getInputStream__LD getInputStream
extern int get_atom_text(atom_t atom, PL_chars_t *text);
extern int get_string_text(word w, PL_chars_t *text);
extern char *format_float(double f, char *buf, const char *format);
extern char *format_float(double f, char *buf);
/**** stuff from pl-ctype.c ****/
extern IOENC initEncoding(void);
@ -737,11 +889,11 @@ extern int PL_unify_list_ex(term_t l, term_t h, term_t t);
extern int PL_unify_nil_ex(term_t l);
extern int PL_get_list_ex(term_t l, term_t h, term_t t);
extern int PL_get_nil_ex(term_t l);
extern int PL_get_module_ex(term_t name, module_t *m);
extern int PL_unify_bool_ex(term_t t, bool val);
extern int PL_unify_bool_ex(term_t t, bool val);
extern int PL_get_bool_ex(term_t t, int *i);
extern int PL_get_integer_ex(term_t t, int *i);
extern int PL_get_module_ex(term_t t, module_t *m);
/**** stuff from pl-file.c ****/
extern void initIO(void);
@ -780,16 +932,38 @@ PL_EXPORT(int) PL_get_stream_handle(term_t t, IOSTREAM **s);
PL_EXPORT(void) PL_write_prompt(int);
PL_EXPORT(int) PL_release_stream(IOSTREAM *s);
COMMON(atom_t) fileNameStream(IOSTREAM *s);
COMMON(int) streamStatus(IOSTREAM *s);
COMMON(int) getOutputStream(term_t t, IOSTREAM **s);
COMMON(int) getInputStream__LD(term_t t, IOSTREAM **s ARG_LD);
#define getInputStream(t, s) getInputStream__LD(t, s PASS_LD)
COMMON(void) pushOutputContext(void);
COMMON(void) popOutputContext(void);
COMMON(int) getSingleChar(IOSTREAM *s, int signals);
COMMON(void) prompt1(atom_t prompt);
COMMON(atom_t) encoding_to_atom(IOENC enc);
COMMON(int) pl_see(term_t f);
COMMON(int) pl_seen(void);
/**** stuff from pl-error.c ****/
extern void outOfCore(void);
extern void fatalError(const char *fm, ...);
extern void printMessage(int type, ...);
extern int callProlog(void * module, term_t goal, int flags, term_t *ex);
extern word notImplemented(char *name, int arity);
/**** stuff from pl-ctype.c ****/
extern void initCharTypes(void);
/**** stuff from pl-fmt.c ****/
COMMON(word) pl_current_format_predicate(term_t chr, term_t descr,
control_t h);
COMMON(intptr_t) lengthList(term_t list, int errors);
COMMON(word) pl_format_predicate(term_t chr, term_t descr);
COMMON(word) pl_format(term_t fmt, term_t args);
COMMON(word) pl_format3(term_t s, term_t fmt, term_t args);
/**** stuff from pl-glob.c ****/
extern void initGlob(void);
@ -815,9 +989,6 @@ int Unsetenv(char *name);
int System(char *cmd);
bool expandVars(const char *pattern, char *expanded, int maxlen);
/**** stuff from pl-utils.c ****/
bool stripostfix(char *s, char *e);
/**** SWI stuff (emulated in pl-yap.c) ****/
extern int writeAtomToStream(IOSTREAM *so, atom_t at);
extern int valueExpression(term_t t, Number r ARG_LD);
@ -831,14 +1002,46 @@ extern int warning(const char *fm, ...);
void initFiles(void);
int RemoveFile(const char *path);
int PL_get_file_name(term_t n, char **namep, int flags);
PL_EXPORT(int) PL_get_file_nameW(term_t n, wchar_t **name, int flags);
COMMON(int) unifyTime(term_t t, time_t time);
/**** stuff from pl-utf8.c ****/
size_t utf8_strlen(const char *s, size_t len);
/**** stuff from pl-write.c ****/
COMMON(char *) varName(term_t var, char *buf);
COMMON(int) writeUCSAtom(IOSTREAM *fd, atom_t atom, int flags);
COMMON(word) pl_nl1(term_t stream);
COMMON(word) pl_nl(void);
COMMON(int) writeAttributeMask(atom_t name);
COMMON(word) pl_write_term(term_t term, term_t options);
COMMON(word) pl_write_term3(term_t stream,
term_t term, term_t options);
COMMON(word) pl_print(term_t term);
COMMON(word) pl_write2(term_t stream, term_t term);
COMMON(word) pl_writeq2(term_t stream, term_t term);
COMMON(word) pl_print2(term_t stream, term_t term);
COMMON(word) pl_writeln(term_t term);
COMMON(word) pl_write_canonical2(term_t stream, term_t term);
/* empty stub */
void setPrologFlag(const char *name, int flags, ...);
void PL_set_prolog_flag(const char *name, int flags, ...);
COMMON(int) saveWakeup(wakeup_state *state, int forceframe ARG_LD);
COMMON(void) restoreWakeup(wakeup_state *state ARG_LD);
COMMON(intptr_t) skip_list(Word l, Word *tailp ARG_LD);
COMMON(int) priorityOperator(Module m, atom_t atom);
COMMON(int) currentOperator(Module m, atom_t name, int kind,
int *type, int *priority);
COMMON(int) numberVars(term_t t, nv_options *opts, int n ARG_LD);
COMMON(Buffer) codes_or_chars_to_buffer(term_t l, unsigned int flags,
int wide, CVT_result *status);
static inline word
setBoolean(int *flag, term_t old, term_t new)
{ if ( !PL_unify_bool_ex(old, *flag) ||
@ -857,39 +1060,3 @@ setInteger(int *flag, term_t old, term_t new)
succeed;
}
#if defined(__SWI_PROLOG__)
static inline word
INIT_SEQ_CODES(size_t n)
{
return allocGlobal(1+(n)*3); /* TBD: shift */
}
static inline word
EXTEND_SEQ_CODES(word gstore, int c) {
*gstore = consPtr(&gstore[1], TAG_COMPOUND|STG_GLOBAL);
gstore++;
*gstore++ = FUNCTOR_dot2;
*gstore++ = consInt(c);
return gstore;
}
static inline int
CLOSE_SEQ_OF_CODES(word gstore, word lp, word A2, word A3)) {
setVar(*gstore);
gTop = gstore+1;
a = valTermRef(A2);
deRef(a);
if ( !unify_ptrs(a, lp PASS_LD) )
return FALSE;
a = valTermRef(A3);
deRef(a);
if ( !unify_ptrs(a, gstore PASS_LD) )
return FALSE;
return TRUE;
}
#else
#endif

180
packages/PLStream/pl-option.c Normal file
View File

@ -0,0 +1,180 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2008, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include "pl-incl.h"
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Variable argument list:
atom_t name
int type OPT_ATOM, OPT_STRING, OPT_BOOL, OPT_INT, OPT_LONG
pointer value
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define MAXOPTIONS 32
typedef union
{ bool *b; /* boolean value */
long *l; /* long value */
int *i; /* integer value */
uintptr_t *sz; /* size_t value */
char **s; /* string value */
word *a; /* atom value */
term_t *t; /* term-reference */
void *ptr; /* anonymous pointer */
} optvalue;
bool
scan_options(term_t options, int flags, atom_t optype,
const opt_spec *specs, ...)
{ GET_LD
va_list args;
const opt_spec *s;
optvalue values[MAXOPTIONS];
term_t list = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t tmp = PL_new_term_ref();
term_t val = PL_new_term_ref();
int n;
if ( truePrologFlag(PLFLAG_ISO) )
flags |= OPT_ALL;
va_start(args, specs);
for( n=0, s = specs; s->name; s++, n++ )
values[n].ptr = va_arg(args, void *);
va_end(args);
while ( PL_get_list(list, head, list) )
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( name == ATOM_equals && arity == 2 )
{ _PL_get_arg(1, head, tmp);
if ( !PL_get_atom(tmp, &name) )
goto itemerror;
_PL_get_arg(2, head, val);
} else if ( arity == 1 )
{ _PL_get_arg(1, head, val);
} else if ( arity == 0 )
PL_put_atom(val, ATOM_true);
} else if ( PL_is_variable(head) )
{ return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
} else
{ itemerror:
return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head);
}
for( n=0, s = specs; s->name; n++, s++ )
{ if ( s->name == name )
{ switch((s->type & OPT_TYPE_MASK))
{ case OPT_BOOL:
{ atom_t aval;
if ( !PL_get_atom(val, &aval) )
fail;
if ( aval == ATOM_true || aval == ATOM_on )
*values[n].b = TRUE;
else if ( aval == ATOM_false || aval == ATOM_off )
*values[n].b = FALSE;
else
goto itemerror;
break;
}
case OPT_INT:
{ if ( !PL_get_integer(val, values[n].i) )
goto itemerror;
break;
}
case OPT_LONG:
{ if ( !PL_get_long(val, values[n].l) )
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].l = LONG_MAX;
else
goto itemerror;
}
break;
}
case OPT_NATLONG:
{ if ( !PL_get_long(val, values[n].l) )
goto itemerror;
if ( *(values[n].l) <= 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_not_less_than_one, val);
break;
}
case OPT_SIZE:
{ if ( !PL_get_uintptr(val, values[n].sz) )
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].sz = (size_t)-1;
else
goto itemerror;
}
break;
}
case OPT_STRING:
{ char *str;
if ( !PL_get_chars(val, &str, CVT_ALL) ) /* copy? */
goto itemerror;
*values[n].s = str;
break;
}
case OPT_ATOM:
{ atom_t a;
if ( !PL_get_atom(val, &a) )
goto itemerror;
*values[n].a = a;
break;
}
case OPT_TERM:
{ *values[n].t = val;
val = PL_new_term_ref(); /* can't reuse anymore */
break;
}
default:
assert(0);
fail;
}
break;
}
}
if ( !s->name && (flags & OPT_ALL) )
goto itemerror;
}
if ( !PL_get_nil(list) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
succeed;
}

49
packages/PLStream/pl-option.h Normal file
View File

@ -0,0 +1,49 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2008, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifndef OPTION_H_INCLUDED
#define OPTION_H_INCLUDED
#define OPT_BOOL (0) /* types */
#define OPT_INT (1)
#define OPT_STRING (2)
#define OPT_ATOM (3)
#define OPT_TERM (4) /* arbitrary term */
#define OPT_LONG (5)
#define OPT_NATLONG (6) /* > 0 */
#define OPT_SIZE (7) /* size_t */
#define OPT_TYPE_MASK 0xff
#define OPT_INF 0x100 /* allow 'inf' */
#define OPT_ALL 0x1 /* flags */
typedef struct
{ atom_t name; /* Name of option */
int type; /* Type of option */
} opt_spec, *OptSpec;
COMMON(int) scan_options(term_t list, int flags, atom_t name,
const opt_spec *specs, ...);
#endif /*OPTION_H_INCLUDED*/

226
packages/PLStream/pl-os.c
View File

@ -37,10 +37,24 @@
#include <math.h> /* avoid abs() problem with msvc++ */
#include <stdio.h> /* rename() and remove() prototypes */
#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
# if HAVE_SYS_TIME_H
# include <sys/time.h>
# else
# include <time.h>
# endif
#endif
#if HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
#if !O_XOS
#ifdef O_XOS
#define statstruct struct _stati64
#else
#define statstruct struct stat
#define statfunc stat
#endif
#if HAVE_PWD_H
@ -99,13 +113,9 @@ long clock_wait_ticks;
This module is a contraction of functions that used to be all over the
place. together with pl-os.h (included by pl-incl.h) this file
should define a basic layer around the OS, on which the rest of
SWI-Prolog is based. SWI-Prolog has been developed on SUN, running
SunOs 3.4 and later 4.0.
SWI-Prolog is based.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
Unfortunately some OS's simply do not offer an equivalent to SUN os
features. In most cases part of the functionality of the system will
have to be dropped. See the header of pl-incl.h for details.
- - - - - - - - - - - - - - - - */
/********************************
* INITIALISATION *
@ -120,6 +130,9 @@ have to be dropped. See the header of pl-incl.h for details.
bool
initOs(void)
{ GET_LD
GD->statistics.start_time = WallTime();
DEBUG(1, Sdprintf("OS:initExpand() ...\n"));
initExpand();
DEBUG(1, Sdprintf("OS:initEnviron() ...\n"));
@ -432,11 +445,10 @@ UsedMemory(void)
uintptr_t
FreeMemory(void)
{
#if defined(HAVE_GETRLIMIT) && defined(RLIMIT_DATA)
uintptr_t used = UsedMemory();
{ uintptr_t used = UsedMemory();
struct rlimit limit;
#if defined(HAVE_GETRLIMIT) && defined(RLIMIT_DATA)
struct rlimit limit;
if ( getrlimit(RLIMIT_DATA, &limit) == 0 )
return limit.rlim_cur - used;
@ -467,9 +479,6 @@ FreeMemory(void)
Depreciated according to Linux manpage, suggested by Solaris
manpage.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifdef __MINGW32__
__stdcall unsigned long GetTickCount(void);
#endif
void
setRandom(unsigned int *seedp)
@ -712,34 +721,6 @@ RemoveTemporaryFiles(void)
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Size of a VM page of memory. Most BSD machines have this function. If not,
here are several alternatives ...
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifndef HAVE_GETPAGESIZE
#ifdef _SC_PAGESIZE
int
getpagesize()
{ return sysconf(_SC_PAGESIZE);
}
#else /*_SC_PAGESIZE*/
#if hpux
#include <a.out.h>
int
getpagesize()
{
#ifdef EXEC_PAGESIZE
return EXEC_PAGESIZE;
#else
return 4096; /* not that important */
#endif
}
#endif /*hpux*/
#endif /*_SC_PAGESIZE*/
#endif /*HAVE_GETPAGESIZE*/
#if O_HPFS
/* Conversion rules Prolog <-> OS/2 (using HPFS)
@ -791,7 +772,7 @@ OsPath(const char *plpath, char *path)
}
#endif /* O_HPFS */
#if defined(__unix__) || defined(__APPLE__)
#ifdef __unix__
char *
PrologPath(const char *p, char *buf, size_t len)
{ strncpy(buf, p, len);
@ -929,7 +910,7 @@ registerParentDirs(const char *path)
{ char dirname[MAXPATHLEN];
char tmp[MAXPATHLEN];
CanonicalDir d;
struct stat buf;
statstruct buf;
for(e--; *e != '/' && e > path + 1; e-- )
;
@ -967,7 +948,7 @@ not it updates the cache and returns FALSE.
static int
verify_entry(CanonicalDir d)
{ char tmp[MAXPATHLEN];
struct stat buf;
statstruct buf;
if ( statfunc(OsPath(d->canonical, tmp), &buf) == 0 )
{ if ( d->inode == buf.st_ino &&
@ -1008,7 +989,7 @@ verify_entry(CanonicalDir d)
static char *
canoniseDir(char *path)
{ CanonicalDir d, next;
struct stat buf;
statstruct buf;
char tmp[MAXPATHLEN];
DEBUG(1, Sdprintf("canoniseDir(%s) --> ", path));
@ -1728,6 +1709,40 @@ LocalTime(long *t, struct tm *r)
}
/*******************************
* TERMINAL *
*******************************/
#ifdef HAVE_TCSETATTR
#include <termios.h>
#include <unistd.h>
#define O_HAVE_TERMIO 1
#else /*HAVE_TCSETATTR*/
#ifdef HAVE_SYS_TERMIO_H
#include <sys/termio.h>
#define termios termio
#define O_HAVE_TERMIO 1
#else
#ifdef HAVE_SYS_TERMIOS_H
#include <sys/termios.h>
#define O_HAVE_TERMIO 1
#endif
#endif
#endif /*HAVE_TCSETATTR*/
typedef struct tty_state
{
#if defined(O_HAVE_TERMIO)
struct termios tab;
#elif defined(HAVE_SGTTYB)
struct sgttyb tab;
#else
int tab; /* empty is not allowed */
#endif
} tty_state;
#define TTY_STATE(buf) (((tty_state*)(buf->state))->tab)
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
TERMINAL IO MANIPULATION
@ -1744,7 +1759,7 @@ PopTty(IOSTREAM *s, ttybuf *buf)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void
ResetStdin(void)
ResetStdin()
{ Sinput->limitp = Sinput->bufp = Sinput->buffer;
if ( !GD->os.org_terminal.read )
GD->os.org_terminal = *Sinput->functions;
@ -1757,10 +1772,12 @@ Sread_terminal(void *handle, char *buf, size_t size)
int fd = (int)h;
source_location oldsrc = LD->read_source;
if ( LD->prompt.next && ttymode != TTY_RAW )
PL_write_prompt(TRUE);
else
Sflush(Suser_output);
if ( Soutput && true(Soutput, SIO_ISATTY) )
{ if ( LD->prompt.next && ttymode != TTY_RAW )
PL_write_prompt(TRUE);
else
Sflush(Suser_output);
}
PL_dispatch(fd, PL_DISPATCH_WAIT);
size = (*GD->os.org_terminal.read)(handle, buf, size);
@ -1779,7 +1796,7 @@ Sread_terminal(void *handle, char *buf, size_t size)
}
void
ResetTty()
ResetTty(void)
{ GET_LD
startCritical;
ResetStdin();
@ -1813,29 +1830,32 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
struct termios tio;
int fd;
buf->mode = ttymode;
ttymode = mode;
buf->mode = ttymode;
buf->state = NULL;
ttymode = mode;
if ( (fd = Sfileno(s)) < 0 || !isatty(fd) )
succeed; /* not a terminal */
if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
succeed;
buf->state = allocHeap(sizeof(tty_state));
#ifdef HAVE_TCSETATTR
if ( tcgetattr(fd, &buf->tab) ) /* save the old one */
if ( tcgetattr(fd, &TTY_STATE(buf)) ) /* save the old one */
fail;
#else
if ( ioctl(fd, TIOCGETA, &buf->tab) ) /* save the old one */
if ( ioctl(fd, TIOCGETA, &TTY_STATE(buf)) ) /* save the old one */
fail;
#endif
tio = buf->tab;
tio = TTY_STATE(buf);
switch( mode )
{ case TTY_RAW:
#if defined(HAVE_TCSETATTR) && defined(HAVE_CFMAKERAW)
cfmakeraw(&tio);
tio.c_oflag = buf->tab.c_oflag; /* donot change output modes */
tio.c_oflag = TTY_STATE(buf).c_oflag; /* donot change output modes */
tio.c_lflag |= ISIG;
#else
tio.c_lflag &= ~(ECHO|ICANON);
@ -1876,26 +1896,33 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
bool
PopTty(IOSTREAM *s, ttybuf *buf)
PopTty(IOSTREAM *s, ttybuf *buf, int do_free)
{ GET_LD
int fd;
ttymode = buf->mode;
if ( (fd = Sfileno(s)) < 0 || !isatty(fd) )
succeed; /* not a terminal */
if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
succeed;
if ( buf->state )
{ int fd = Sfileno(s);
if ( fd >= 0 )
{
#ifdef HAVE_TCSETATTR
tcsetattr(fd, TCSANOW, &buf->tab);
tcsetattr(fd, TCSANOW, &TTY_STATE(buf));
#else
#ifdef TIOCSETA
ioctl(fd, TIOCSETA, &buf->tab);
ioctl(fd, TIOCSETA, &TTY_STATE(buf));
#else
ioctl(fd, TCSETA, &buf->tab);
ioctl(fd, TCXONC, (void *)1);
ioctl(fd, TCSETA, &TTY_STATE(buf));
ioctl(fd, TCXONC, (void *)1);
#endif
#endif
}
if ( do_free )
{ freeHeap(buf->state, sizeof(tty_state));
buf->state = NULL;
}
}
succeed;
}
@ -1910,6 +1937,7 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
int fd;
buf->mode = ttymode;
buf->state = NULL;
ttymode = mode;
if ( (fd = Sfileno(s)) < 0 || !isatty(fd) )
@ -1917,25 +1945,26 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
succeed;
if ( ioctl(fd, TIOCGETP, &buf->tab) ) /* save the old one */
buf->state = allocHeap(sizeof(tty_state));
if ( ioctl(fd, TIOCGETP, &TTY_STATE(buf)) ) /* save the old one */
fail;
tio = buf->tab;
tio = TTY_STATE(buf);
switch( mode )
{ case TTY_RAW:
tio.sg_flags |= CBREAK;
tio.sg_flags &= ~ECHO;
break;
case TTY_OUTPUT:
tio.sg_flags |= (CRMOD);
break;
case TTY_SAVE:
succeed;
default:
sysError("Unknown PushTty() mode: %d", mode);
/*NOTREACHED*/
}
{ case TTY_RAW:
tio.sg_flags |= CBREAK;
tio.sg_flags &= ~ECHO;
break;
case TTY_OUTPUT:
tio.sg_flags |= (CRMOD);
break;
case TTY_SAVE:
succeed;
default:
sysError("Unknown PushTty() mode: %d", mode);
/*NOTREACHED*/
}
ioctl(fd, TIOCSETP, &tio);
ioctl(fd, TIOCSTART, NULL);
@ -1945,17 +1974,22 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
bool
PopTty(IOSTREAM *s, ttybuf *buf)
PopTty(IOSTREAM *s, ttybuf *buf, int do_free)
{ ttymode = buf->mode;
int fd;
if ( (fd = Sfileno(s)) < 0 || !isatty(fd) )
succeed; /* not a terminal */
if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
succeed;
if ( buf->state )
{ int fd = Sfileno(s);
ioctl(fd, TIOCSETP, &buf->tab);
ioctl(fd, TIOCSTART, NULL);
if ( fd >= 0 )
{ ioctl(fd, TIOCSETP, &buf->tab);
ioctl(fd, TIOCSTART, NULL);
}
if ( do_free )
{ freeHeap(buf->state, sizeof(tty_state));
buf->state = NULL;
}
}
succeed;
}
@ -1972,7 +2006,7 @@ PushTty(IOSTREAM *s, ttybuf *buf, int mode)
bool
PopTty(IOSTREAM *s, ttybuf *buf)
PopTty(IOSTREAM *s, ttybuf *buf, int do_free)
{ GET_LD
ttymode = buf->mode;
if ( ttymode != TTY_RAW )
@ -2448,7 +2482,7 @@ findExecutable(const char *av0, char *buffer)
return NULL;
file = Which(buf, tmp);
#if __unix__ || __APPLE__ /* argv[0] can be an #! script! */
#if __unix__ /* argv[0] can be an #! script! */
if ( file )
{ int n, fd;
char buf[MAXPATHLEN];
@ -2483,10 +2517,10 @@ findExecutable(const char *av0, char *buffer)
#endif /*__WINDOWS__*/
#if __unix__ || __APPLE__
#ifdef __unix__
static char *
okToExec(const char *s)
{ struct stat stbuff;
{ statstruct stbuff;
if (statfunc(s, &stbuff) == 0 && /* stat it */
S_ISREG(stbuff.st_mode) && /* check for file */

133
packages/PLStream/pl-os.h
View File

@ -22,30 +22,10 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
# if HAVE_SYS_TIME_H
# include <sys/time.h>
# else
# include <time.h>
# endif
#endif
#ifdef HAVE_SYS_PARAM_H /* get MAXPATHLEN */
#include <sys/param.h>
#endif
#ifdef __MINGW32__
__stdcall unsigned long GetTickCount(void);
#endif
/********************************
* MEMORY MANAGEMENT *
*********************************/
extern void *Allocate(intptr_t);
/********************************
* MISCELLANEOUS *
@ -83,52 +63,7 @@ extern bool initOs(void);
#endif
#endif
#define Fflush(fd) Sflush(fd)
#define Fclose(fd) Sclose(fd)
#define Open(path, how, mode) open(OsPath(path), how, mode)
#define Read(fd, buf, size) read(fd, buf, size)
#define Write(fd, buf, size) write(fd, buf, size)
#define Getc(fd) Sgetc(fd)
#define Putw(w, fd) Sputw((intptr_t)(w), fd)
#define Getw(fd) Sgetw(fd)
/*******************************
* PAGE AND TABLE-SIZE *
*******************************/
#ifdef HAVE_SYSCONF
#if defined(_SC_OPEN_MAX) && !defined(HAVE_GETPAGESIZE)
#undef getdtablesize
#define getdtablesize() sysconf(_SC_OPEN_MAX)
#ifndef HAVE_GETDTABLESIZE
#define HAVE_GETDTABLESIZE 1
#endif
#endif
#if defined(_SC_PAGESIZE) && !defined(HAVE_GETPAGESIZE)
#undef getpagesize
#define getpagesize() sysconf(_SC_PAGESIZE)
#ifndef HAVE_GETPAGESIZE
#define HAVE_GETPAGESIZE 1
#endif
#endif
#endif /*HAVE_SYSCONF*/
#ifndef HAVE_GETDTABLESIZE
extern int getdtablesize(void);
#endif
#ifndef HAVE_GETPAGESIZE
extern int getpagesize(void);
#endif
/*******************************
* FILE ACCESS *
*******************************/
#define ACCESS_EXIST 0
#define ACCESS_EXECUTE 1
#define ACCESS_READ 2
#define ACCESS_WRITE 4
COMMON(char*) canoniseFileName(char *path);
/********************************
@ -175,55 +110,18 @@ extern uintptr_t FreeMemory(void);
#define TTY_OUTPUT 3 /* enable post-processing */
#define TTY_SAVE 4 /* just save status */
#ifdef HAVE_TCSETATTR
#include <termios.h>
#include <unistd.h>
#define O_HAVE_TERMIO 1
#else /*HAVE_TCSETATTR*/
#ifdef HAVE_SYS_TERMIO_H
#include <sys/termio.h>
#define termios termio
#define O_HAVE_TERMIO 1
#else
#ifdef HAVE_SYS_TERMIOS_H
#include <sys/termios.h>
#define O_HAVE_TERMIO 1
#endif
#endif
#endif /*HAVE_TCSETATTR*/
#ifdef O_HAVE_TERMIO
typedef struct
{ struct termios tab; /* saved tty status */
int mode; /* Prolog;'s view on mode */
{ void *state; /* Saved state */
int mode; /* Prolog;'s view on mode */
} ttybuf;
#else /* !O_HAVE_TERMIO */
#ifdef HAVE_SGTTYB
#include <sys/ioctl.h>
typedef struct
{ struct sgttyb tab; /* saved tty status */
int mode; /* Prolog;'s view on mode */
} ttybuf;
#else
typedef struct
{ int mode; /* Prolog;'s view on mode */
} ttybuf;
#endif /*HAVE_SGTTYB*/
#endif /*O_HAVE_TERMIO*/
extern ttybuf ttytab; /* saved tty status */
extern int ttymode; /* Current tty mode */
#define IsaTty(fd) isatty(fd)
extern bool PushTty(IOSTREAM *s, ttybuf *, int mode);
extern bool PopTty(IOSTREAM *s, ttybuf *);
extern bool PushTty(IOSTREAM *s, ttybuf *buf, int mode);
extern bool PopTty(IOSTREAM *s, ttybuf *buf, int do_free);
extern void ResetTty(void);
@ -232,24 +130,3 @@ extern void ResetTty(void);
*********************************/
extern int System(char *command);
extern char *ExpandOneFile(const char *spec, char *file);
extern char *AbsoluteFile(const char *spec, char *path);
extern int IsAbsolutePath(const char *spec);
extern char *DeRefLink(const char *link, char *buf);
extern bool ExistsDirectory(const char *path);
extern bool AccessFile(const char *path, int mode);
extern bool AccessFile(const char *path, int mode);
extern char *OsPath(const char *plpath, char *path);
extern char *Getenv(const char *, char *buf, size_t buflen);
extern char *BaseName(const char *f);
extern time_t LastModifiedFile(const char *f);
extern bool ExistsFile(const char *path);
extern atom_t TemporaryFile(const char *id, int *fdp);
extern atom_t TemporaryFile(const char *id, int *fdp);
extern int DeleteTemporaryFile(atom_t name);
extern bool ChDir(const char *path);
extern char *PrologPath(const char *ospath, char *path, size_t len);

967
packages/PLStream/pl-prologflag.c Normal file
View File

@ -0,0 +1,967 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2008, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
/*#define O_DEBUG 1*/
#include "pl-incl.h"
#include "pl-ctype.h"
#include <ctype.h>
#ifdef __WINDOWS__
#include <process.h> /* getpid() */
#endif
#define LOCK() PL_LOCK(PLFLAG_L)
#define UNLOCK() PL_UNLOCK(PLFLAG_L)
/*******************************
* PROLOG FLAG HANDLING *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ISO Prolog flags are properties of the running Prolog system. Some of
these flags can be set by the user, such as whether read/1 honours
character-escapes, whether garbage-collection is enabled, etc. Some are
global and read-only, such as whether the operating system is unix.
In the multi-threading version, Prolog flags have to be changed
thread-local. Therefore two flag-tables have been defined: a global one
which is used as long as there is only one thread, and a local one that
is used to write changes to after multiple threads exist. On thread
creation this table is copied from the parent and on destruction the
local table is destroyed. Note that the flag-mask for fast access
(truePrologFlag(*PLFLAG_)) is always copied to the local thread-data.
Altogether this module is a bit too complex, but I see little
alternative. I considered creating copy-on-write hash-tables, but in
combination to the table-enumator objects this proves very hard to
implement safely. Using plain Prolog is not a good option too: they are
used before we can use any Prolog at startup, predicates are not
thread-local and some of the prolog flags require very fast access from
C (the booleans in the mask).
Just using a local table and copy it on thread-creation would be an
option, but 90% of the prolog flags are read-only or never changed and
we want to be able to have a lot of flags and don't harm thread_create/3
too much.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void setArgvPrologFlag();
static void setTZPrologFlag();
static void setVersionPrologFlag(void);
typedef struct _prolog_flag
{ short flags; /* Type | Flags */
short index; /* index in PLFLAG_ mask */
union
{ atom_t a; /* value as atom */
int64_t i; /* value as integer */
record_t t; /* value as term */
} value;
} prolog_flag;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C-interface for defining Prolog flags. Depending on the type, the
following arguments are to be provided:
FT_BOOL TRUE/FALSE, *PLFLAG_
FT_INTEGER intptr_t
FT_ATOM const char *
FT_TERM a term
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int
indexOfBoolMask(uintptr_t mask)
{ int i=1;
if ( !mask )
return -1;
while(!(mask & 0x1L))
{ i++;
mask >>= 1;
}
return i;
}
void
setPrologFlag(const char *name, int flags, ...)
{ atom_t an = PL_new_atom(name);
prolog_flag *f;
Symbol s;
va_list args;
int type = (flags & FT_MASK);
initPrologFlagTable();
if ( type == FT_INT64 )
flags = (flags & ~FT_MASK)|FT_INTEGER;
if ( (s = lookupHTable(GD->prolog_flag.table, (void *)an)) )
{ f = s->value;
assert((f->flags & FT_MASK) == (flags & FT_MASK));
if ( flags & FF_KEEP )
return;
} else
{ f = allocHeap(sizeof(*f));
f->index = -1;
f->flags = flags;
addHTable(GD->prolog_flag.table, (void *)an, f);
}
va_start(args, flags);
switch(type)
{ case FT_BOOL:
{ int val = va_arg(args, int);
uintptr_t mask = va_arg(args, uintptr_t);
if ( s && mask && f->index < 0 ) /* type definition */
{ f->index = indexOfBoolMask(mask);
val = (f->value.a == ATOM_true);
} else if ( !s ) /* 1st definition */
{ f->index = indexOfBoolMask(mask);
DEBUG(2, Sdprintf("Prolog flag %s at 0x%08lx\n", name, mask));
}
f->value.a = (val ? ATOM_true : ATOM_false);
if ( f->index >= 0 )
{ mask = 1L << (f->index-1);
if ( val )
setPrologFlagMask(mask);
else
clearPrologFlagMask(mask);
}
break;
}
case FT_INTEGER:
{ intptr_t val = va_arg(args, intptr_t);
f->value.i = val;
break;
}
case FT_INT64:
{ int64_t val = va_arg(args, int64_t);
f->value.i = val;
break;
}
case FT_ATOM:
{ PL_chars_t text;
text.text.t = va_arg(args, char *);
text.encoding = ENC_UTF8;
text.storage = PL_CHARS_HEAP;
text.length = strlen(text.text.t);
text.canonical = FALSE;
f->value.a = textToAtom(&text); /* registered: ok */
PL_free_text(&text);
break;
}
case FT_TERM:
{ term_t t = va_arg(args, term_t);
f->value.t = PL_record(t);
break;
}
default:
assert(0);
}
va_end(args);
}
#ifdef O_PLMT
static void
copySymbolPrologFlagTable(Symbol s)
{ prolog_flag *f = s->value;
prolog_flag *copy = allocHeap(sizeof(*copy));
*copy = *f;
if ( (f->flags & FT_MASK) == FT_TERM )
copy->value.t = PL_duplicate_record(f->value.t);
s->value = copy;
}
static void
freeSymbolPrologFlagTable(Symbol s)
{ prolog_flag *f = s->value;
if ( (f->flags & FT_MASK) == FT_TERM )
PL_erase(f->value.t);
freeHeap(f, sizeof(*f));
}
#endif
int
setDoubleQuotes(atom_t a, unsigned int *flagp)
{ unsigned int flags;
if ( a == ATOM_chars )
flags = DBLQ_CHARS;
else if ( a == ATOM_codes )
flags = 0;
else if ( a == ATOM_atom )
flags = DBLQ_ATOM;
else if ( a == ATOM_string )
flags = DBLQ_STRING;
else
{ term_t value = PL_new_term_ref();
PL_put_atom(value, a);
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_double_quotes, value);
}
*flagp &= ~DBLQ_MASK;
*flagp |= flags;
succeed;
}
static int
setUnknown(atom_t a, unsigned int *flagp)
{ unsigned int flags;
if ( a == ATOM_error )
flags = UNKNOWN_ERROR;
else if ( a == ATOM_warning )
flags = UNKNOWN_WARNING;
else if ( a == ATOM_fail )
flags = 0;
else
{ term_t value = PL_new_term_ref();
PL_put_atom(value, a);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_unknown, value);
}
*flagp &= ~(UNKNOWN_ERROR|UNKNOWN_WARNING);
*flagp |= flags;
succeed;
}
static int
setWriteAttributes(atom_t a)
{ int mask = writeAttributeMask(a);
if ( mask )
{ LD->prolog_flag.write_attributes = mask;
succeed;
} else
{ term_t value = PL_new_term_ref();
PL_put_atom(value, a);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_attributes, value);
}
}
static int
getOccursCheckMask(atom_t a, occurs_check_t *val)
{ if ( a == ATOM_false )
{ *val = OCCURS_CHECK_FALSE;
} else if ( a == ATOM_true )
{ *val = OCCURS_CHECK_TRUE;
} else if ( a == ATOM_error )
{ *val = OCCURS_CHECK_ERROR;
} else
fail;
succeed;
}
static int
setOccursCheck(atom_t a)
{ if ( getOccursCheckMask(a, &LD->prolog_flag.occurs_check) )
{ succeed;
} else
{ term_t value = PL_new_term_ref();
PL_put_atom(value, a);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_occurs_check, value);
}
}
static int
setEncoding(atom_t a)
{ IOENC enc = atom_to_encoding(a);
if ( enc == ENC_UNKNOWN )
{ term_t value = PL_new_term_ref();
PL_put_atom(value, a);
return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_encoding, value);
}
LD->encoding = enc;
succeed;
}
static word
set_prolog_flag_unlocked(term_t key, term_t value)
{ atom_t k;
Symbol s;
prolog_flag *f;
Module m = MODULE_parse;
int rval = TRUE;
PL_strip_module(key, &m, key);
if ( !PL_get_atom(key, &k) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, key);
/* set existing Prolog flag */
#ifdef O_PLMT
if ( LD->prolog_flag.table &&
(s = lookupHTable(LD->prolog_flag.table, (void *)k)) )
{ f = s->value; /* already local Prolog flag */
} else
#endif
if ( (s = lookupHTable(GD->prolog_flag.table, (void *)k)) )
{ f = s->value;
if ( f->flags & FF_READONLY )
return PL_error(NULL, 0, NULL, ERR_PERMISSION,
ATOM_modify, ATOM_flag, key);
#ifdef O_PLMT
if ( GD->statistics.threads_created > 1 )
{ prolog_flag *f2 = allocHeap(sizeof(*f2));
*f2 = *f;
if ( (f2->flags & FT_MASK) == FT_TERM )
f2->value.t = PL_duplicate_record(f2->value.t);
if ( !LD->prolog_flag.table )
{ LD->prolog_flag.table = newHTable(4);
LD->prolog_flag.table->copy_symbol = copySymbolPrologFlagTable;
LD->prolog_flag.table->free_symbol = freeSymbolPrologFlagTable;
}
addHTable(LD->prolog_flag.table, (void *)k, f2);
DEBUG(1, Sdprintf("Localised Prolog flag %s\n", PL_atom_chars(k)));
f = f2;
}
#endif
} else /* define new Prolog flag */
{ prolog_flag *f = allocHeap(sizeof(*f));
atom_t a;
int64_t i;
f->index = -1;
if ( PL_get_atom(value, &a) )
{ if ( a == ATOM_true || a == ATOM_false || a == ATOM_on || a == ATOM_off )
f->flags = FT_BOOL;
else
f->flags = FT_ATOM;
f->value.a = a;
PL_register_atom(a);
} else if ( PL_get_int64(value, &i) )
{ f->flags = FT_INTEGER;
f->value.i = i;
} else
{ f->flags = FT_TERM;
f->value.t = PL_record(value);
}
#ifdef O_PLMT
if ( GD->statistics.threads_created > 1 )
{ if ( !LD->prolog_flag.table )
{ LD->prolog_flag.table = newHTable(4);
LD->prolog_flag.table->copy_symbol = copySymbolPrologFlagTable;
LD->prolog_flag.table->free_symbol = freeSymbolPrologFlagTable;
}
addHTable(LD->prolog_flag.table, (void *)k, f);
} else
#endif
addHTable(GD->prolog_flag.table, (void *)k, f);
succeed;
}
switch(f->flags & FT_MASK)
{ case FT_BOOL:
{ int val;
if ( !PL_get_bool(value, &val) )
{ return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, value);
}
if ( f->index > 0 )
{ uintptr_t mask = 1L << (f->index-1);
if ( val )
setPrologFlagMask(mask);
else
clearPrologFlagMask(mask);
}
if ( k == ATOM_character_escapes )
{ if ( val )
set(m, CHARESCAPE);
else
clear(m, CHARESCAPE);
} else if ( k == ATOM_debug )
{ if ( val )
{ debugmode(DBG_ALL, NULL);
} else
{ tracemode(FALSE, NULL);
debugmode(DBG_OFF, NULL);
}
} else if ( k == ATOM_debugger_show_context )
{ debugstatus.showContext = val;
#ifdef O_PLMT
} else if ( k == ATOM_threads )
{ if ( !(rval = enableThreads(val)) )
break; /* don't change value */
#endif
}
/* set the flag value */
f->value.a = (val ? ATOM_true : ATOM_false);
break;
}
case FT_ATOM:
{ atom_t a;
if ( !PL_get_atom(value, &a) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, value);
if ( k == ATOM_double_quotes )
{ rval = setDoubleQuotes(a, &m->flags);
} else if ( k == ATOM_unknown )
{ rval = setUnknown(a, &m->flags);
} else if ( k == ATOM_write_attributes )
{ rval = setWriteAttributes(a);
} else if ( k == ATOM_occurs_check )
{ rval = setOccursCheck(a);
} else if ( k == ATOM_encoding )
{ rval = setEncoding(a);
}
if ( !rval )
fail;
PL_unregister_atom(f->value.a);
f->value.a = a;
PL_register_atom(a);
if ( k == ATOM_float_format )
{ PL_register_atom(a); /* so it will never be lost! */
LD->float_format = PL_atom_chars(a);
}
break;
}
case FT_INTEGER:
{ int64_t i;
if ( !PL_get_int64(value, &i) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, value);
f->value.i = i;
#ifdef O_ATOMGC
if ( k == ATOM_agc_margin )
GD->atoms.margin = (size_t)i;
#endif
break;
}
case FT_TERM:
{ if ( f->value.t )
PL_erase(f->value.t);
f->value.t = PL_record(value);
break;
}
default:
assert(0);
}
return rval;
}
word
pl_set_prolog_flag(term_t key, term_t value)
{ word rc;
LOCK();
rc = set_prolog_flag_unlocked(key, value);
UNLOCK();
return rc;
}
static int
unify_prolog_flag_value(Module m, atom_t key, prolog_flag *f, term_t val)
{ if ( key == ATOM_character_escapes )
{ atom_t v = (true(m, CHARESCAPE) ? ATOM_true : ATOM_false);
return PL_unify_atom(val, v);
} else if ( key == ATOM_double_quotes )
{ atom_t v;
if ( true(m, DBLQ_CHARS) )
v = ATOM_chars;
else if ( true(m, DBLQ_ATOM) )
v = ATOM_atom;
else if ( true(m, DBLQ_STRING) )
v = ATOM_string;
else
v = ATOM_codes;
return PL_unify_atom(val, v);
} else if ( key == ATOM_unknown )
{ atom_t v;
if ( true(m, UNKNOWN_ERROR) )
v = ATOM_error;
else if ( true(m, UNKNOWN_WARNING) )
v = ATOM_warning;
else
v = ATOM_fail;
return PL_unify_atom(val, v);
#ifdef O_PLMT
} else if ( key == ATOM_system_thread_id )
{ return PL_unify_integer(val, system_thread_id(NULL));
#endif
} else if ( key == ATOM_debug )
{ return PL_unify_bool_ex(val, debugstatus.debugging);
} else if ( key == ATOM_debugger_show_context )
{ return PL_unify_bool_ex(val, debugstatus.showContext);
}
switch(f->flags & FT_MASK)
{ case FT_BOOL:
if ( f->index >= 0 )
{ uintptr_t mask = 1L << (f->index-1);
return PL_unify_bool_ex(val, truePrologFlag(mask) != FALSE);
}
/*FALLTHROUGH*/
case FT_ATOM:
return PL_unify_atom(val, f->value.a);
case FT_INTEGER:
return PL_unify_int64(val, f->value.i);
case FT_TERM:
{ term_t tmp = PL_new_term_ref();
PL_recorded(f->value.t, tmp);
return PL_unify(val, tmp);
}
default:
assert(0);
fail;
}
}
static int
unify_prolog_flag_access(prolog_flag *f, term_t access)
{ if ( f->flags & FF_READONLY )
return PL_unify_atom(access, ATOM_read);
else
return PL_unify_atom(access, ATOM_write);
}
static int
unify_prolog_flag_type(prolog_flag *f, term_t type)
{ atom_t a;
switch(f->flags & FT_MASK)
{ case FT_BOOL:
a = ATOM_bool;
break;
case FT_ATOM:
a = ATOM_atom;
break;
case FT_INTEGER:
a = ATOM_integer;
break;
case FT_TERM:
a = ATOM_term;
break;
default:
assert(0);
fail;
}
return PL_unify_atom(type, a);
}
typedef struct
{ TableEnum table_enum;
atom_t scope;
int explicit_scope;
Module module;
} prolog_flag_enum;
word
pl_prolog_flag5(term_t key, term_t value,
word scope, word access, word type,
control_t h)
{ prolog_flag_enum *e;
Symbol s;
fid_t fid;
Module module;
switch( ForeignControl(h) )
{ case FRG_FIRST_CALL:
{ atom_t k;
module = MODULE_parse;
PL_strip_module(key, &module, key);
if ( PL_get_atom(key, &k) )
{ Symbol s;
#ifdef O_PLMT
if ( LD->prolog_flag.table &&
(s = lookupHTable(LD->prolog_flag.table, (void *)k)) )
return unify_prolog_flag_value(module, k, s->value, value);
#endif
if ( (s = lookupHTable(GD->prolog_flag.table, (void *)k)) )
{ if ( unify_prolog_flag_value(module, k, s->value, value) &&
(!access || unify_prolog_flag_access(s->value, access)) &&
(!type || unify_prolog_flag_type(s->value, type)) )
succeed;
}
fail;
} else if ( PL_is_variable(key) )
{ e = allocHeap(sizeof(*e));
e->module = module;
if ( scope && PL_get_atom(scope, &e->scope) )
{ e->explicit_scope = TRUE;
if ( !(e->scope == ATOM_local || e->scope == ATOM_global) )
{ freeHeap(e, sizeof(*e));
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
PL_new_atom("scope"), scope);
}
} else
{ e->explicit_scope = FALSE;
if ( LD->prolog_flag.table )
e->scope = ATOM_local;
else
e->scope = ATOM_global;
}
if ( e->scope == ATOM_local )
e->table_enum = newTableEnum(LD->prolog_flag.table);
else
e->table_enum = newTableEnum(GD->prolog_flag.table);
break;
} else
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, key);
}
case FRG_REDO:
e = ForeignContextPtr(h);
break;
case FRG_CUTTED:
e = ForeignContextPtr(h);
if ( e )
{ freeTableEnum(e->table_enum);
freeHeap(e, sizeof(*e));
}
default:
succeed;
}
fid = PL_open_foreign_frame();
LOCK();
for(;;)
{ while( (s=advanceTableEnum(e->table_enum)) )
{ atom_t fn = (atom_t) s->name;
if ( e->explicit_scope == FALSE &&
e->scope == ATOM_global &&
LD->prolog_flag.table &&
lookupHTable(LD->prolog_flag.table, (void *)fn) )
continue;
if ( PL_unify_atom(key, fn) &&
unify_prolog_flag_value(e->module, fn, s->value, value) &&
(!scope || PL_unify_atom(scope, e->scope)) &&
(!access || unify_prolog_flag_access(s->value, access)) &&
(!type || unify_prolog_flag_type(s->value, type)) )
{ UNLOCK();
ForeignRedoPtr(e);
}
if ( exception_term )
{ exception_term = 0;
setVar(*valTermRef(exception_bin));
}
PL_rewind_foreign_frame(fid);
}
if ( e->scope == ATOM_local )
{ e->scope = ATOM_global;
freeTableEnum(e->table_enum);
e->table_enum = newTableEnum(GD->prolog_flag.table);
} else
break;
}
UNLOCK();
freeTableEnum(e->table_enum);
freeHeap(e, sizeof(*e));
fail;
}
foreign_t
pl_prolog_flag(term_t name, term_t value, control_t h)
{ return pl_prolog_flag5(name, value, 0, 0, 0, h);
}
/*******************************
* INITIALISE FEATURES *
*******************************/
#ifndef SO_EXT
#define SO_EXT "so"
#endif
#ifndef SO_PATH
#define SO_PATH "LD_LIBRARY_PATH"
#endif
void
initPrologFlagTable()
{ if ( !GD->prolog_flag.table )
{ initPrologThreads(); /* may be called before PL_initialise() */
GD->prolog_flag.table = newHTable(32);
}
}
void
initPrologFlags()
{ setPrologFlag("iso", FT_BOOL, FALSE, PLFLAG_ISO);
setPrologFlag("arch", FT_ATOM|FF_READONLY, ARCH);
#if __WINDOWS__
setPrologFlag("windows", FT_BOOL|FF_READONLY, TRUE, 0);
#endif
setPrologFlag("version", FT_INTEGER|FF_READONLY, PLVERSION);
setPrologFlag("dialect", FT_ATOM|FF_READONLY, "swi");
if ( systemDefaults.home )
setPrologFlag("home", FT_ATOM|FF_READONLY, systemDefaults.home);
if ( GD->paths.executable )
setPrologFlag("executable", FT_ATOM|FF_READONLY, GD->paths.executable);
#if defined(HAVE_GETPID) || defined(EMULATE_GETPID)
setPrologFlag("pid", FT_INTEGER|FF_READONLY, getpid());
#endif
setPrologFlag("optimise", FT_BOOL, GD->cmdline.optimise, PLFLAG_OPTIMISE);
setPrologFlag("generate_debug_info", FT_BOOL,
truePrologFlag(PLFLAG_DEBUGINFO), PLFLAG_DEBUGINFO);
setPrologFlag("last_call_optimisation", FT_BOOL, TRUE, PLFLAG_LASTCALL);
#ifdef O_PLMT
setPrologFlag("abort_with_exception", FT_BOOL|FF_READONLY,
TRUE, PLFLAG_EX_ABORT);
#else
setPrologFlag("abort_with_exception", FT_BOOL,
FALSE, PLFLAG_EX_ABORT);
#endif
setPrologFlag("c_libs", FT_ATOM|FF_READONLY, C_LIBS);
setPrologFlag("c_cc", FT_ATOM|FF_READONLY, C_CC);
setPrologFlag("c_ldflags", FT_ATOM|FF_READONLY, C_LDFLAGS);
#if defined(O_LARGEFILES) || SIZEOF_LONG == 8
setPrologFlag("large_files", FT_BOOL|FF_READONLY, TRUE, 0);
#endif
setPrologFlag("gc", FT_BOOL, TRUE, PLFLAG_GC);
setPrologFlag("trace_gc", FT_BOOL, FALSE, PLFLAG_TRACE_GC);
#ifdef O_ATOMGC
setPrologFlag("agc_margin",FT_INTEGER, GD->atoms.margin);
#endif
#if defined(HAVE_DLOPEN) || defined(HAVE_SHL_LOAD) || defined(EMULATE_DLOPEN)
setPrologFlag("open_shared_object", FT_BOOL|FF_READONLY, TRUE, 0);
setPrologFlag("shared_object_extension", FT_ATOM|FF_READONLY, SO_EXT);
setPrologFlag("shared_object_search_path", FT_ATOM|FF_READONLY, SO_PATH);
#endif
#if O_DYNAMIC_STACKS
setPrologFlag("dynamic_stacks", FT_BOOL|FF_READONLY, TRUE, 0);
#endif
setPrologFlag("address_bits", FT_INTEGER|FF_READONLY, sizeof(void*)*8);
#ifdef HAVE_POPEN
setPrologFlag("pipe", FT_BOOL, TRUE, 0);
#endif
#ifdef O_PLMT
setPrologFlag("threads", FT_BOOL|FF_READONLY, TRUE, 0);
setPrologFlag("system_thread_id", FT_INTEGER|FF_READONLY, 0, 0);
#ifdef MAX_THREADS
setPrologFlag("max_threads", FT_INTEGER|FF_READONLY, MAX_THREADS);
#endif
#else
setPrologFlag("threads", FT_BOOL|FF_READONLY, FALSE, 0);
#endif
#ifdef ASSOCIATE_SRC
setPrologFlag("associate", FT_ATOM, ASSOCIATE_SRC);
#endif
#ifdef O_DDE
setPrologFlag("dde", FT_BOOL|FF_READONLY, TRUE, 0);
#endif
#ifdef O_RUNTIME
setPrologFlag("runtime", FT_BOOL|FF_READONLY, TRUE, 0);
setPrologFlag("debug_on_error", FT_BOOL|FF_READONLY, FALSE,
PLFLAG_DEBUG_ON_ERROR);
setPrologFlag("report_error", FT_BOOL|FF_READONLY, FALSE,
PLFLAG_REPORT_ERROR);
#else
setPrologFlag("debug_on_error", FT_BOOL, TRUE, PLFLAG_DEBUG_ON_ERROR);
setPrologFlag("report_error", FT_BOOL, TRUE, PLFLAG_REPORT_ERROR);
#endif
setPrologFlag("editor", FT_ATOM, "default");
setPrologFlag("debugger_show_context", FT_BOOL, FALSE, 0);
setPrologFlag("autoload", FT_BOOL, TRUE, PLFLAG_AUTOLOAD);
#ifndef O_GMP
setPrologFlag("max_integer", FT_INT64|FF_READONLY, PLMAXINT);
setPrologFlag("min_integer", FT_INT64|FF_READONLY, PLMININT);
#endif
setPrologFlag("max_tagged_integer", FT_INTEGER|FF_READONLY, PLMAXTAGGEDINT);
setPrologFlag("min_tagged_integer", FT_INTEGER|FF_READONLY, PLMINTAGGEDINT);
#ifdef O_GMP
setPrologFlag("bounded", FT_BOOL|FF_READONLY, FALSE, 0);
#ifdef __GNU_MP__
setPrologFlag("gmp_version", FT_INTEGER|FF_READONLY, __GNU_MP__);
#endif
#else
setPrologFlag("bounded", FT_BOOL|FF_READONLY, TRUE, 0);
#endif
if ( (-3 / 2) == -2 )
setPrologFlag("integer_rounding_function", FT_ATOM|FF_READONLY, "down");
else
setPrologFlag("integer_rounding_function", FT_ATOM|FF_READONLY, "toward_zero");
setPrologFlag("max_arity", FT_ATOM|FF_READONLY, "unbounded");
setPrologFlag("float_format", FT_ATOM, "%g");
setPrologFlag("answer_format", FT_ATOM, "~p");
setPrologFlag("character_escapes", FT_BOOL, TRUE, PLFLAG_CHARESCAPE);
setPrologFlag("char_conversion", FT_BOOL, FALSE, PLFLAG_CHARCONVERSION);
setPrologFlag("backquoted_string", FT_BOOL, FALSE, PLFLAG_BACKQUOTED_STRING);
setPrologFlag("write_attributes", FT_ATOM, "ignore");
setPrologFlag("occurs_check", FT_ATOM, "false");
setPrologFlag("double_quotes", FT_ATOM, "codes");
setPrologFlag("unknown", FT_ATOM, "error");
setPrologFlag("debug", FT_BOOL, FALSE, 0);
setPrologFlag("verbose", FT_ATOM|FF_KEEP, GD->options.silent ? "silent" : "normal");
setPrologFlag("verbose_load", FT_BOOL, TRUE, 0);
setPrologFlag("allow_variable_name_as_functor", FT_BOOL, FALSE,
ALLOW_VARNAME_FUNCTOR);
setPrologFlag("toplevel_var_size", FT_INTEGER, 1000);
setPrologFlag("toplevel_print_anon", FT_BOOL, TRUE, 0);
setPrologFlag("file_name_variables", FT_BOOL, FALSE, PLFLAG_FILEVARS);
setPrologFlag("fileerrors", FT_BOOL, TRUE, PLFLAG_FILEERRORS);
#ifdef __unix__
setPrologFlag("unix", FT_BOOL|FF_READONLY, TRUE, 0);
#endif
setPrologFlag("encoding", FT_ATOM, stringAtom(encoding_to_atom(LD->encoding)));
setPrologFlag("tty_control", FT_BOOL|FF_READONLY,
truePrologFlag(PLFLAG_TTY_CONTROL), PLFLAG_TTY_CONTROL);
setPrologFlag("signals", FT_BOOL|FF_READONLY,
truePrologFlag(PLFLAG_SIGNALS), PLFLAG_SIGNALS);
setPrologFlag("readline", FT_BOOL/*|FF_READONLY*/, FALSE, 0);
#if defined(__WINDOWS__) && defined(_DEBUG)
setPrologFlag("kernel_compile_mode", FT_ATOM|FF_READONLY, "debug");
#endif
#if defined(__DATE__) && defined(__TIME__)
{ char buf[100];
Ssprintf(buf, "%s, %s", __DATE__, __TIME__);
setPrologFlag("compiled_at", FT_ATOM|FF_READONLY, buf);
}
#endif
setArgvPrologFlag();
setTZPrologFlag();
setOSPrologFlags();
setVersionPrologFlag();
}
static void
setArgvPrologFlag()
{ fid_t fid = PL_open_foreign_frame();
term_t e = PL_new_term_ref();
term_t l = PL_new_term_ref();
int argc = GD->cmdline.argc;
char **argv = GD->cmdline.argv;
int n;
PL_put_nil(l);
for(n=argc-1; n>= 0; n--)
{ PL_put_variable(e);
PL_unify_chars(e, PL_ATOM|REP_FN, -1, argv[n]);
PL_cons_list(l, e, l);
}
setPrologFlag("argv", FT_TERM, l);
PL_discard_foreign_frame(fid);
}
static void
setTZPrologFlag()
{ tzset();
setPrologFlag("timezone", FT_INTEGER|FF_READONLY, timezone);
}
static void
setVersionPrologFlag(void)
{ fid_t fid = PL_open_foreign_frame();
term_t t = PL_new_term_ref();
int major = PLVERSION/10000;
int minor = (PLVERSION/100)%100;
int patch = (PLVERSION%100);
PL_unify_term(t, PL_FUNCTOR_CHARS, "swi", 4,
PL_INT, major,
PL_INT, minor,
PL_INT, patch,
PL_ATOM, ATOM_nil);
setPrologFlag("version_data", FF_READONLY|FT_TERM, t);
PL_discard_foreign_frame(fid);
setGITVersion();
}

378
packages/PLStream/pl-stream.c
View File

@ -22,24 +22,15 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifdef __MINGW32__
#define __WINDOWS__ 1
#endif
#ifdef __WINDOWS__
#include <uxnt/uxnt.h>
#ifdef __MINGW32__
#include "config.h"
#include <windows.h>
#else
#include <uxnt.h>
#ifdef WIN64
#define MD "config/win64.h"
#else
#define MD "config/win32.h"
#endif
#endif
#include <winsock2.h>
#include "pl-mswchar.h"
#include "windows/mswchar.h"
#define CRLF_MAPPING 1
#endif
@ -148,14 +139,14 @@ STRYLOCK(IOSTREAM *s)
#define STRYLOCK(s) (TRUE)
#endif
#include "pl-error.h"
typedef void *record_t;
typedef void *Module;
typedef intptr_t term_t;
typedef intptr_t atom_t;
#include "pl-error.h"
extern int fatalError(const char *fm, ...);
extern int PL_error(const char *pred, int arity,
const char *msg, int id, ...);
extern int PL_handle_signals(void);
extern int PL_handle_signals();
extern IOENC initEncoding(void);
extern int reportStreamError(IOSTREAM *s);
extern record_t PL_record(term_t t);
@ -310,6 +301,11 @@ int
Slock(IOSTREAM *s)
{ SLOCK(s);
if ( s->erased )
{ SUNLOCK(s);
return -1;
}
#ifdef DEBUG_IO_LOCKS
if ( s->locks > 2 )
{ printf(" Lock [%d]: %s: %d locks", PL_thread_self(), Sname(s), s->locks+1);
@ -331,6 +327,11 @@ StryLock(IOSTREAM *s)
{ if ( !STRYLOCK(s) )
return -1;
if ( s->erased )
{ SUNLOCK(s);
return -1;
}
if ( !s->locks++ )
{ if ( (s->flags & (SIO_NBUF|SIO_OUTPUT)) == (SIO_NBUF|SIO_OUTPUT) )
return S__setbuf(s, NULL, TMPBUFSIZE) == (size_t)-1 ? -1 : 0;
@ -370,7 +371,7 @@ Sunlock(IOSTREAM *s)
*******************************/
/* return values: -1: error, else #bytes written */
static ssize_t
S__flushbuf(IOSTREAM *s)
{ char *from, *to;
@ -439,6 +440,52 @@ S__flushbufc(int c, IOSTREAM *s)
}
static int
Swait_for_data(IOSTREAM *s)
{ int fd = Sfileno(s);
fd_set wait;
struct timeval time;
int rc;
if ( fd < 0 )
{ errno = EPERM; /* no permission to select */
s->flags |= SIO_FERR;
return -1;
}
time.tv_sec = s->timeout / 1000;
time.tv_usec = (s->timeout % 1000) * 1000;
FD_ZERO(&wait);
#ifdef __WINDOWS__
FD_SET((SOCKET)fd, &wait);
#else
FD_SET(fd, &wait);
#endif
for(;;)
{ rc = select(fd+1, &wait, NULL, NULL, &time);
if ( rc < 0 && errno == EINTR )
{ if ( PL_handle_signals() < 0 )
{ errno = EPLEXCEPTION;
return -1;
}
continue;
}
break;
}
if ( rc == 0 )
{ s->flags |= (SIO_TIMEOUT|SIO_FERR);
return -1;
}
return 0; /* ok, data available */
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S__fillbuf() fills the read-buffer, returning the first character of it.
It also realises the SWI-Prolog timeout facility.
@ -456,51 +503,14 @@ S__fillbuf(IOSTREAM *s)
#ifdef HAVE_SELECT
s->flags &= ~SIO_TIMEOUT;
if ( s->timeout >= 0 )
{ int fd = Sfileno(s);
if ( s->timeout >= 0 && !s->downstream )
{ int rc;
if ( fd >= 0 )
{ fd_set wait;
struct timeval time;
int rc;
time.tv_sec = s->timeout / 1000;
time.tv_usec = (s->timeout % 1000) * 1000;
FD_ZERO(&wait);
#ifdef __WINDOWS__
FD_SET((SOCKET)fd, &wait);
#else
FD_SET(fd, &wait);
#endif
for(;;)
{ rc = select(fd+1, &wait, NULL, NULL, &time);
if ( rc < 0 && errno == EINTR )
{ if ( PL_handle_signals() < 0 )
{ errno = EPLEXCEPTION;
return -1;
}
continue;
}
break;
}
if ( rc == 0 )
{ s->flags |= (SIO_TIMEOUT|SIO_FERR);
return -1;
}
} else
{ errno = EPERM; /* no permission to select */
s->flags |= SIO_FERR;
return -1;
}
if ( (rc=Swait_for_data(s)) < 0 )
return rc;
}
#endif
if ( s->flags & SIO_NBUF )
{ char chr;
ssize_t n;
@ -1053,124 +1063,60 @@ out:
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(*) For ENC_ANSI there is a problem as this deals with multi-modal
streams, streams that may hold escape sequences to move from one
character set to another: ascii ... <esc1> japanese <esc2> ascii ...
Suppose now we have two characters [ascii, japanese]. When reading the
japanese character the first time, the system will translate the
<esc><japanese> and the mode will be japanese. When pushing back, only
the japanese character will be put back, not the escape sequence. What
to do?
peek needs to keep track of the actual bytes processed because not doing
so might lead to an incorrect byte-count in the position term. The
simplest example is that when looking at \r\n in Windows, get_code/1
returns \n, but it returns the same for a single \n.
Often, we could keep track of bufp and reset this, but we must deal with
the case where we fetch a new buffer. In this case, we must copy the few
remaining bytes to the `unbuffer' area.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
int
Sungetcode(int c, IOSTREAM *s)
{ switch(s->encoding)
{ case ENC_OCTET:
case ENC_ISO_LATIN_1:
if ( c >= 256 )
return -1; /* illegal */
simple:
if ( s->bufp > s->unbuffer )
{ unget_byte(c, s);
return c;
}
return -1; /* no room */
case ENC_ASCII:
if ( c >= 128 )
return -1; /* illegal */
goto simple;
case ENC_ANSI: /* (*) See above */
{ char b[MB_LEN_MAX];
size_t n;
if ( !s->mbstate ) /* do we need a seperate state? */
{ if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) )
return EOF; /* out of memory */
memset(s->mbstate, 0, sizeof(*s->mbstate));
}
if ( (n = wcrtomb(b, (wchar_t)c, s->mbstate)) != (size_t)-1 &&
s->bufp >= n + s->unbuffer )
{ size_t i;
for(i=n; i-- > 0; )
{ unget_byte(b[i], s);
}
return c;
}
Speekcode(IOSTREAM *s)
{ int c;
char *start;
IOPOS *psave = s->position;
size_t safe = (size_t)-1;
if ( !s->buffer )
{ if ( (s->flags & SIO_NBUF) )
{ errno = EINVAL;
return -1;
}
case ENC_UTF8:
{ if ( (unsigned)c >= 0x8000000 )
return -1;
if ( c < 0x80 )
{ goto simple;
} else
{ char buf[6];
char *p, *end;
end = utf8_put_char(buf, c);
if ( s->bufp - s->unbuffer >= end-buf )
{ for(p=end-1; p>=buf; p--)
{ unget_byte(*p, s);
}
return c;
}
return -1;
}
}
case ENC_UNICODE_BE:
{ if ( c >= 0x10000 )
return -1;
if ( s->bufp-1 > s->unbuffer )
{ unget_byte(c&0xff, s);
unget_byte((c>>8)&0xff, s);
return c;
}
return -1;
}
case ENC_UNICODE_LE:
{ if ( c >= 0x10000 )
return -1;
if ( s->bufp-1 > s->unbuffer )
{ unget_byte((c>>8)&0xff, s);
unget_byte(c&0xff, s);
return c;
}
return -1;
}
case ENC_WCHAR:
{ pl_wchar_t chr = c;
if ( s->bufp-sizeof(chr) >= s->unbuffer )
{ char *p = (char*)&chr;
int n;
for(n=sizeof(chr); --n>=0; )
unget_byte(p[n], s);
return c;
}
return -1;
}
case ENC_UNKNOWN:
if ( S__setbuf(s, NULL, 0) == (size_t)-1 )
return -1;
}
assert(0);
return -1;
if ( (s->flags & SIO_FEOF) )
return -1;
if ( s->bufp + UNDO_SIZE > s->limitp )
{ safe = s->limitp - s->bufp;
memcpy(s->buffer-safe, s->bufp, safe);
}
start = s->bufp;
s->position = NULL;
c = Sgetcode(s);
s->position = psave;
if ( Sferror(s) )
return -1;
s->flags &= ~(SIO_FEOF|SIO_FEOF2);
if ( s->bufp > start )
{ s->bufp = start;
} else
{ assert(safe != (size_t)-1);
s->bufp = s->buffer-safe;
}
return c;
}
/*******************************
* PUTW/GETW *
*******************************/
@ -1393,6 +1339,10 @@ Sfeof(IOSTREAM *s)
return -1;
}
if ( s->downstream != NULL &&
Sfeof(s->downstream))
return TRUE;
if ( S__fillbuf(s) == -1 )
return TRUE;
@ -1709,6 +1659,22 @@ Stell(IOSTREAM *s)
* CLOSE *
*******************************/
void
unallocStream(IOSTREAM *s)
{
#ifdef O_PLMT
if ( s->mutex )
{ recursiveMutexDelete(s->mutex);
free(s->mutex);
s->mutex = NULL;
}
#endif
if ( !(s->flags & SIO_STATIC) )
free(s);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(*) Sclose() can be called recursively. For example if an XPCE object is
only referenced from an open stream, the close-function will delete the
@ -1766,19 +1732,13 @@ Sclose(IOSTREAM *s)
run_close_hooks(s); /* deletes Prolog registration */
SUNLOCK(s);
#ifdef O_PLMT
if ( s->mutex )
{ recursiveMutexDelete(s->mutex);
free(s->mutex);
s->mutex = NULL;
}
#endif
s->magic = SIO_CMAGIC;
if ( s->message )
free(s->message);
if ( !(s->flags & SIO_STATIC) )
free(s);
if ( s->references == 0 )
unallocStream(s);
else
s->erased = TRUE;
return rval;
}
@ -1896,11 +1856,34 @@ Svprintf(const char *fm, va_list args)
#define A_LEFT 0 /* left-aligned field */
#define A_RIGHT 1 /* right-aligned field */
#define SNPRINTF3(fm, a1) \
{ size_t __r; \
assert(fs == fbuf); \
__r = snprintf(fs, sizeof(fbuf), fm, a1); \
if ( __r >= sizeof(fbuf) ) \
{ if ( (fs_malloced = fs = malloc(__r+1)) == NULL ) goto error; \
__r = snprintf(fs, __r+1, fm, a1); \
} \
fe = fs+__r; \
}
#define SNPRINTF4(fm, a1, a2) \
{ size_t __r; \
assert(fs == fbuf); \
__r = snprintf(fs, sizeof(fbuf), fm, a1, a2); \
if ( __r >= sizeof(fbuf) ) \
{ if ( (fs_malloced = fs = malloc(__r+1)) == NULL ) goto error; \
__r = snprintf(fs, __r+1, fm, a1, a2); \
} \
fe = fs+__r; \
}
int
Svfprintf(IOSTREAM *s, const char *fm, va_list args)
{ intptr_t printed = 0;
{ int printed = 0;
char buf[TMPBUFSIZE];
int tmpbuf;
char *fs_malloced = NULL;
SLOCK(s);
@ -1988,8 +1971,7 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
*fp++ = '#';
*fp++ = 'p';
*fp = '\0';
sprintf(fs, fmbuf, ptr);
fe = &fs[strlen(fs)];
SNPRINTF3(fmbuf, ptr);
break;
}
@ -2022,7 +2004,7 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
if ( islong < 2 )
{ *fp++ = *fm;
*fp = '\0';
sprintf(fs, fmbuf, v);
SNPRINTF3(fmbuf, v);
} else
{
#ifdef __WINDOWS__
@ -2033,9 +2015,8 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
#endif
*fp++ = *fm;
*fp = '\0';
sprintf(fs, fmbuf, vl);
SNPRINTF3(fmbuf, vl);
}
fe = &fs[strlen(fs)];
break;
}
@ -2050,16 +2031,16 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
*fp++ = '%';
if ( modified )
*fp++ = '#';
if ( has_arg2 ) /* specified percission */
if ( has_arg2 ) /* specified precission */
{ *fp++ = '.';
*fp++ = '*';
*fp++ = *fm;
*fp = '\0';
sprintf(fs, fmbuf, arg2, v);
SNPRINTF4(fmbuf, arg2, v);
} else
{ *fp++ = *fm;
*fp = '\0';
sprintf(fs, fmbuf, v);
SNPRINTF3(fmbuf, v);
}
fe = &fs[strlen(fs)];
@ -2125,6 +2106,10 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
}
}
fm++;
if ( fs_malloced )
{ fs_malloced = NULL;
free(fs_malloced);
}
}
} else if ( *fm == '\\' && fm[1] )
{ OUTCHR(s, fm[1]);
@ -2144,6 +2129,9 @@ Svfprintf(IOSTREAM *s, const char *fm, va_list args)
return (int)printed;
error:
if ( fs_malloced )
free(fs_malloced);
SUNLOCK(s);
return -1;
}
@ -2184,7 +2172,7 @@ Svsprintf(char *buf, const char *fm, va_list args)
int
Svdprintf(const char *fm, va_list args)
{ int rval;
IOSTREAM *s = Soutput;
IOSTREAM *s = Serror;
Slock(s);
rval = Svfprintf(s, fm, args);
@ -2677,7 +2665,6 @@ is of no value.
IOSTREAM *
Snew(void *handle, int flags, IOFUNCTIONS *functions)
{ IOSTREAM *s;
int fd;
if ( !(s = malloc(sizeof(IOSTREAM))) )
{ errno = ENOMEM;
@ -2708,6 +2695,7 @@ Snew(void *handle, int flags, IOFUNCTIONS *functions)
#endif
#ifndef __WINDOWS__ /* (*) */
{ int fd;
if ( (fd = Sfileno(s)) >= 0 )
{ if ( isatty(fd) )
s->flags |= SIO_ISATTY;
@ -2715,6 +2703,7 @@ Snew(void *handle, int flags, IOFUNCTIONS *functions)
fcntl(fd, F_SETFD, FD_CLOEXEC);
#endif
}
}
#endif
return s;
@ -2746,6 +2735,7 @@ Sopen_file(const char *path, const char *how)
enum {lnone=0,lread,lwrite} lock = lnone;
IOSTREAM *s;
IOENC enc = ENC_UNKNOWN;
int wait = TRUE;
for( ; *how; how++)
{ switch(*how)
@ -2756,6 +2746,9 @@ Sopen_file(const char *path, const char *how)
case 'r': /* no record */
flags &= ~SIO_RECORDPOS;
break;
case 'L': /* lock r: read, w: write */
wait = FALSE;
/*FALLTHROUGH*/
case 'l': /* lock r: read, w: write */
if ( *++how == 'r' )
lock = lread;
@ -2811,7 +2804,7 @@ Sopen_file(const char *path, const char *how)
memset(&buf, 0, sizeof(buf));
buf.l_type = (lock == lread ? F_RDLCK : F_WRLCK);
if ( fcntl(fd, F_SETLKW, &buf) < 0 )
if ( fcntl(fd, wait ? F_SETLKW : F_SETLK, &buf) < 0 )
{ int save = errno;
close(fd);
errno = save;
@ -2821,14 +2814,20 @@ Sopen_file(const char *path, const char *how)
#if __WINDOWS__
HANDLE h = (HANDLE)_get_osfhandle(fd);
OVERLAPPED ov;
int flags = 0;
if ( lock == lwrite )
flags |= LOCKFILE_EXCLUSIVE_LOCK;
if ( !wait )
flags |= LOCKFILE_FAIL_IMMEDIATELY;
memset(&ov, 0, sizeof(ov));
if ( !LockFileEx(h, (lock == lread ? 0 : LOCKFILE_EXCLUSIVE_LOCK),
if ( !LockFileEx(h, flags,
0,
0, 0xfffffff,
&ov) )
{ close(fd);
errno = EACCES; /* TBD: proper error */
errno = (wait ? EACCES : EAGAIN); /* TBD: proper error */
return NULL;
}
#else
@ -2912,7 +2911,7 @@ Sfileno(IOSTREAM *s)
#ifdef HAVE_POPEN
#ifdef __WINDOWS__
#include "popen.c"
#include "windows/popen.c"
#define popen(cmd, how) pt_popen(cmd, how)
#define pclose(fd) pt_pclose(fd)
@ -3458,4 +3457,3 @@ Scleanup(void)
*s = S__iob0[i]; /* re-initialise */
}
}

237
packages/PLStream/pl-string.c
View File

@ -1,11 +1,38 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2011, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include "pl-incl.h"
#include "pl-string.h"
#include "pl-ctype.h"
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
String operations that are needed for the shared IO library.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/********************************
* STRINGS *
*********************************/
/*******************************
* ALLOCATION *
*******************************/
#ifdef O_DEBUG
#define CHAR_INUSE 0x42
@ -32,7 +59,7 @@ remove_string(char *s)
{ if ( s )
{ GET_LD
assert(s[-1] == CHAR_INUSE);
s[-1] = CHAR_FREED;
freeHeap(s-1, strlen(s)+2);
}
@ -44,9 +71,9 @@ char *
store_string(const char *s)
{ if ( s )
{ GET_LD
char *copy = (char *)allocHeap(strlen(s)+1);
strcpy(copy, s);
return copy;
} else
@ -65,3 +92,199 @@ remove_string(char *s)
#endif /*O_DEBUG*/
/*******************************
* NUMBERS *
*******************************/
/* Return the character representing some digit.
** Fri Jun 10 10:45:40 1988 jan@swivax.UUCP (Jan Wielemaker) */
char
digitName(int n, int small)
{ if (n <= 9)
return n + '0';
return n + (small ? 'a' : 'A') - 10;
}
/* Return the value of a digit when transforming a number of base 'b'.
Return '-1' if it is an illegal digit.
** Fri Jun 10 10:46:40 1988 jan@swivax.UUCP (Jan Wielemaker) */
int
digitValue(int b, int c)
{ int v;
if ( b == 0 )
return c; /* 0'c */
if ( b == 1 )
return -1;
if ( b <= 10 )
{ v = c - '0';
if ( v < b )
return v;
return -1;
}
if ( c <= '9' )
return c - '0';
if (isUpper(c))
c = toLower(c);
c = c - 'a' + 10;
if ( c < b && c >= 10 )
return c;
return -1;
}
/********************************
* LESS COMMON BASIC FUNCTIONS *
*********************************/
bool
strprefix(const char *string, const char *prefix)
{ while(*prefix && *string == *prefix)
prefix++, string++;
if (*prefix == EOS )
succeed;
fail;
}
bool
strpostfix(const char *string, const char *postfix)
{ intptr_t offset = strlen(string) - strlen(postfix);
if ( offset < 0 )
fail;
return streq(&string[offset], postfix);
}
#ifndef HAVE_STRCASECMP
int
strcasecmp(const char *s1, const char *s2)
{
#ifdef HAVE_STRICMP
return stricmp(s1, s2);
#else
while(*s1 && makeLower(*s1) == makeLower(*s2))
s1++, s2++;
return makeLower(*s1) - makeLower(*s2);
#endif
}
#endif
#ifndef HAVE_STRLWR
char *
strlwr(char *s)
{ char *q;
for(q=s; *q; q++)
*q = makeLower(*q);
return s;
}
#endif
bool
stripostfix(const char *s, const char *e)
{ size_t ls = strlen(s);
size_t le = strlen(e);
if ( ls >= le )
return strcasecmp(&s[ls-le], e) == 0;
return FALSE;
}
/*******************************
* MULTIBYTE STRINGS *
*******************************/
typedef struct
{ wchar_t *wcp;
int len;
int malloced;
} wbuf;
#if !defined(HAVE_MBSCOLL) || !defined(HAVE_MBCASESCOLL)
static void
wstolower(wchar_t *w, size_t len)
{ wchar_t *e = &w[len];
for( ; w<e; w++ )
*w = towlower(*w);
}
static int
int_mbscoll(const char *s1, const char *s2, int icase)
{ size_t l1 = strlen(s1);
size_t l2 = strlen(s2);
wchar_t *w1;
wchar_t *w2;
int ml1, ml2;
mbstate_t mbs;
int rc;
if ( l1 < 1024 && (w1 = alloca(sizeof(wchar_t)*(l1+1))) )
{ ml1 = FALSE;
} else
{ w1 = PL_malloc(sizeof(wchar_t)*(l1+1));
ml1 = TRUE;
}
if ( l2 < 1024 && (w2 = alloca(sizeof(wchar_t)*(l2+1))) )
{ ml2 = FALSE;
} else
{ w2 = PL_malloc(sizeof(wchar_t)*(l2+1));
ml2 = TRUE;
}
memset(&mbs, 0, sizeof(mbs));
if ( mbsrtowcs(w1, &s1, l1+1, &mbs) == (size_t)-1 )
{ rc = -2;
goto out;
}
if ( mbsrtowcs(w2, &s2, l2+1, &mbs) == (size_t)-1 )
{ rc = 2;
goto out;
}
if ( icase )
{ wstolower(w1, l1);
wstolower(w2, l2);
}
rc = wcscoll(w1, w2);
out:
if ( ml1 ) PL_free(w1);
if ( ml2 ) PL_free(w2);
return rc;
}
#endif
#ifndef HAVE_MBSCOLL
int
mbscoll(const char *s1, const char *s2)
{ return int_mbscoll(s1, s2, FALSE);
}
#endif
#ifndef HAVE_MBSCASECOLL
int
mbscasecoll(const char *s1, const char *s2)
{ return int_mbscoll(s1, s2, TRUE);
}
#endif

48
packages/PLStream/pl-string.h Normal file
View File

@ -0,0 +1,48 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2011, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifndef PL_STRING_H_INCLUDED
#define PL_STRING_H_INCLUDED
COMMON(char *) store_string(const char *s);
COMMON(void) remove_string(char *s);
COMMON(char) digitName(int n, int small);
COMMON(int) digitValue(int b, int c);
COMMON(bool) strprefix(const char *string, const char *prefix);
COMMON(bool) strpostfix(const char *string, const char *postfix);
COMMON(bool) stripostfix(const char *string, const char *postfix);
#ifndef HAVE_STRCASECMP
COMMON(int) strcasecmp(const char *s1, const char *s2);
#endif
#ifndef HAVE_STRLWR
COMMON(char *) strlwr(char *s);
#endif
#ifndef HAVE_MBSCOLL
COMMON(int) mbscoll(const char *s1, const char *s2);
#endif
#ifndef HAVE_MBSCASECOLL
COMMON(int) mbscasecoll(const char *s1, const char *s2);
#endif
#endif /*PL_STRING_H_INCLUDED*/

36
packages/PLStream/pl-table.c
View File

@ -53,7 +53,8 @@ thread-local, as thread_exit/1 should do the same.
static void
allocHTableEntries(Table ht)
{ int n;
{ GET_LD
int n;
Symbol *p;
ht->entries = allocHeap(ht->buckets * sizeof(Symbol));
@ -65,7 +66,8 @@ allocHTableEntries(Table ht)
Table
newHTable(int buckets)
{ Table ht;
{ GET_LD
Table ht;
ht = allocHeap(sizeof(struct table));
ht->buckets = (buckets & ~TABLE_MASK);
@ -89,7 +91,8 @@ newHTable(int buckets)
void
destroyHTable(Table ht)
{
{ GET_LD
#ifdef O_PLMT
if ( ht->mutex )
{ simpleMutexDelete(ht->mutex);
@ -125,7 +128,7 @@ initTables()
if ( !done )
{ done = TRUE;
HASHSTAT(PL_on_halt(exitTables, NULL));
}
}
@ -169,7 +172,8 @@ checkHTable(Table ht)
static void
rehashHTable(Table ht)
{ Symbol *oldtab;
{ GET_LD
Symbol *oldtab;
int oldbucks;
int i;
@ -199,7 +203,8 @@ rehashHTable(Table ht)
Symbol
addHTable(Table ht, void *name, void *value)
{ Symbol s;
{ GET_LD
Symbol s;
int v;
LOCK_TABLE(ht);
@ -223,7 +228,7 @@ addHTable(Table ht, void *name, void *value)
DEBUG(1, checkHTable(ht));
return s;
}
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@ -232,7 +237,8 @@ Note: s must be in the table!
void
deleteSymbolHTable(Table ht, Symbol s)
{ int v;
{ GET_LD
int v;
Symbol *h;
TableEnum e;
@ -262,7 +268,8 @@ deleteSymbolHTable(Table ht, Symbol s)
void
clearHTable(Table ht)
{ int n;
{ GET_LD
int n;
TableEnum e;
LOCK_TABLE(ht);
@ -302,7 +309,8 @@ Table copyHTable(Table org)
Table
copyHTable(Table org)
{ Table ht;
{ GET_LD
Table ht;
int n;
ht = allocHeap(sizeof(struct table));
@ -330,7 +338,7 @@ copyHTable(Table org)
}
*q = NULL;
}
#ifdef O_PLMT
#ifdef O_PLMT
if ( org->mutex )
{ ht->mutex = allocHeap(sizeof(simpleMutex));
simpleMutexInit(ht->mutex);
@ -348,7 +356,8 @@ copyHTable(Table org)
TableEnum
newTableEnum(Table ht)
{ TableEnum e = allocHeap(sizeof(struct table_enum));
{ GET_LD
TableEnum e = allocHeap(sizeof(struct table_enum));
Symbol n;
LOCK_TABLE(ht);
@ -369,7 +378,8 @@ newTableEnum(Table ht)
void
freeTableEnum(TableEnum e)
{ TableEnum *ep;
{ GET_LD
TableEnum *ep;
Table ht;
if ( !e )

96
packages/PLStream/pl-table.h
View File

@ -1,24 +1,33 @@
/*****
Hash Tables pl-table.h
****/
/* $Id$
#define LMASK_BITS 7 /* total # mask bits */
Part of SWI-Prolog
#define TABLE_MASK 0xf0000000UL
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2008, University of Amsterdam
#define pointerHashValue(p, size) ((((intptr_t)(p) >> LMASK_BITS) ^ \
((intptr_t)(p) >> (LMASK_BITS+5)) ^ \
((intptr_t)(p))) & \
((size)-1))
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifndef TABLE_H_INCLUDED
#define TABLE_H_INCLUDED
typedef struct table * Table; /* (numeric) hash table */
typedef struct symbol * Symbol; /* symbol of hash table */
/* hash Table + lock + scaling + enumerator */
typedef struct table *Table;
typedef struct table_enum* TableEnum;
/* symbol table hash package */
typedef struct table_enum * TableEnum; /* Enumerate table entries */
struct table
{ int buckets; /* size of hash table */
@ -45,14 +54,47 @@ struct table_enum
TableEnum next; /* More choice points */
};
extern void initTables(void);
extern Table newHTable(int size);
extern void destroyHTable(Table ht);
extern Symbol lookupHTable(Table ht, void *name);
extern Symbol addHTable(Table ht, void *name, void *value);
extern void deleteSymbolHTable(Table ht, Symbol s);
extern void clearHTable(Table ht);
extern Table copyHTable(Table org);
extern TableEnum newTableEnum(Table ht);
extern void freeTableEnum(TableEnum e);
extern Symbol advanceTableEnum(TableEnum e);
COMMON(void) initTables();
COMMON(Table) newHTable(int size);
COMMON(void) destroyHTable(Table ht);
COMMON(Symbol) lookupHTable(Table ht, void *name);
COMMON(Symbol) addHTable(Table ht, void *name, void *value);
COMMON(void) deleteSymbolHTable(Table ht, Symbol s);
COMMON(void) clearHTable(Table ht);
COMMON(Table) copyHTable(Table org);
COMMON(TableEnum) newTableEnum(Table ht);
COMMON(void) freeTableEnum(TableEnum e);
COMMON(Symbol) advanceTableEnum(TableEnum e);
#define TABLE_UNLOCKED 0x10000000L /* do not create mutex for table */
#define TABLE_MASK 0xf0000000UL
#define pointerHashValue(p, size) ((((intptr_t)(p) >> LMASK_BITS) ^ \
((intptr_t)(p) >> (LMASK_BITS+5)) ^ \
((intptr_t)(p))) & \
((size)-1))
#define for_table(ht, s, code) \
{ int _k; \
PL_LOCK(L_TABLE); \
for(_k = 0; _k < (ht)->buckets; _k++) \
{ Symbol _n, s; \
for(s=(ht)->entries[_k]; s; s = _n) \
{ _n = s->next; \
code; \
} \
} \
PL_UNLOCK(L_TABLE); \
}
#define for_unlocked_table(ht, s, code) \
{ int _k; \
for(_k = 0; _k < (ht)->buckets; _k++) \
{ Symbol _n, s; \
for(s=(ht)->entries[_k]; s; s = _n) \
{ _n = s->next; \
code; \
} \
} \
}
#endif /*TABLE_H_INCLUDED*/

159
packages/PLStream/pl-text.c
View File

@ -25,6 +25,7 @@
#include "pl-incl.h"
#include "pl-ctype.h"
#include "pl-utf8.h"
#include "pl-codelist.h"
#include <errno.h>
#include <stdio.h>
#ifdef __WINDOWS__
@ -37,19 +38,6 @@
#undef LD
#define LD LOCAL_LD
#ifdef __SWI_PROLOG__
static inline word
valHandle__LD(term_t r ARG_LD)
{ Word p = valTermRef(r);
deRef(p);
return *p;
}
#define valHandle(r) valHandle__LD(r PASS_LD)
#define setHandle(h, w) (*valTermRef(h) = (w))
#endif
/*******************************
* UNIFIED TEXT STUFF *
@ -94,6 +82,15 @@ PL_save_text(PL_chars_t *text, int flags)
addMultipleBuffer(b, text->text.t, bl, char);
text->text.t = baseBuffer(b, char);
text->storage = PL_CHARS_RING;
} else if ( text->storage == PL_CHARS_MALLOC )
{ Buffer b = findBuffer(BUF_RING);
size_t bl = bufsize_text(text, text->length+1);
addMultipleBuffer(b, text->text.t, bl, char);
PL_free_text(text);
text->text.t = baseBuffer(b, char);
text->storage = PL_CHARS_RING;
}
}
@ -167,28 +164,58 @@ PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD)
text->encoding = ENC_ISO_LATIN_1;
text->canonical = TRUE;
} else if ( (flags & CVT_FLOAT) && isFloat(w) )
{ format_float(valFloat(w), text->buf, LD->float_format);
{ format_float(valFloat(w), text->buf);
text->text.t = text->buf;
text->length = strlen(text->text.t);
text->encoding = ENC_ISO_LATIN_1;
text->storage = PL_CHARS_LOCAL;
text->canonical = TRUE;
} else if ( (flags & CVT_LIST) &&
(isList(w) || isNil(w)) )
} else if ( (flags & CVT_LIST) )
{ Buffer b;
CVT_result result;
if ( (b = codes_or_chars_to_buffer(l, BUF_RING, FALSE)) )
if ( (b = codes_or_chars_to_buffer(l, BUF_RING, FALSE, &result)) )
{ text->length = entriesBuffer(b, char);
addBuffer(b, EOS, char);
text->text.t = baseBuffer(b, char);
text->encoding = ENC_ISO_LATIN_1;
} else if ( (b = codes_or_chars_to_buffer(l, BUF_RING, TRUE)) )
} else if ( result.status == CVT_wide &&
(b = codes_or_chars_to_buffer(l, BUF_RING, TRUE, &result)) )
{ text->length = entriesBuffer(b, pl_wchar_t);
addBuffer(b, EOS, pl_wchar_t);
text->text.w = baseBuffer(b, pl_wchar_t);
text->encoding = ENC_WCHAR;
} else if ( (flags & (CVT_WRITE|CVT_WRITE_CANONICAL)) )
{ goto case_write;
} else
goto maybe_write;
{ if ( (flags & CVT_VARNOFAIL) && result.status == CVT_partial )
return 2;
if ( (flags & CVT_EXCEPTION) )
{ switch(result.status)
{ case CVT_partial:
return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
case CVT_nolist:
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, l);
case CVT_nocode:
case CVT_nochar:
{ term_t culprit = PL_new_term_ref();
atom_t type;
*valTermRef(culprit) = result.culprit;
if ( result.status == CVT_nocode )
type = ATOM_character_code;
else
type = ATOM_character;
return PL_error(NULL, 0, NULL, ERR_TYPE, type, culprit);
}
default:
break;
}
}
goto error;
}
text->storage = PL_CHARS_RING;
text->canonical = TRUE;
@ -198,16 +225,21 @@ PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD)
text->encoding = ENC_ISO_LATIN_1;
text->storage = PL_CHARS_LOCAL;
text->canonical = TRUE;
} else if ( (flags & CVT_WRITE) )
} else if ( (flags & (CVT_WRITE|CVT_WRITE_CANONICAL)) )
{ IOENC encodings[3];
IOENC *enc;
char *r;
int wflags;
case_write:
encodings[0] = ENC_ISO_LATIN_1;
encodings[1] = ENC_WCHAR;
encodings[2] = ENC_UNKNOWN;
wflags = ((flags&CVT_WRITE_CANONICAL)
? PL_WRT_QUOTED|PL_WRT_IGNOREOPS|PL_WRT_NUMBERVARS
: PL_WRT_NUMBERVARS);
for(enc = encodings; *enc != ENC_UNKNOWN; enc++)
{ size_t size;
IOSTREAM *fd;
@ -216,7 +248,7 @@ PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD)
size = sizeof(text->buf);
fd = Sopenmem(&r, &size, "w");
fd->encoding = *enc;
if ( PL_write_term(fd, l, 1200, 0) &&
if ( PL_write_term(fd, l, 1200, wflags) &&
Sputcode(EOS, fd) >= 0 &&
Sflush(fd) >= 0 )
{ text->encoding = *enc;
@ -249,7 +281,7 @@ PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD)
succeed;
maybe_write:
if ( (flags & CVT_WRITE) )
if ( (flags & (CVT_WRITE|CVT_WRITE_CANONICAL)) )
goto case_write;
error:
@ -275,7 +307,8 @@ error:
atom_t
textToAtom(PL_chars_t *text)
{ PL_canonise_text(text);
{ if ( !PL_canonise_text(text) )
return 0;
if ( text->encoding == ENC_ISO_LATIN_1 )
{ return lookupAtom(text->text.t, text->length);
@ -287,7 +320,8 @@ textToAtom(PL_chars_t *text)
word
textToString(PL_chars_t *text)
{ PL_canonise_text(text);
{ if ( !PL_canonise_text(text) )
return 0;
if ( text->encoding == ENC_ISO_LATIN_1 )
{ return globalString(text->length, text->text.t);
@ -302,10 +336,14 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
{ switch(type)
{ case PL_ATOM:
{ atom_t a = textToAtom(text);
int rval = _PL_unify_atomic(term, a);
PL_unregister_atom(a);
return rval;
if ( a )
{ int rval = _PL_unify_atomic(term, a);
PL_unregister_atom(a);
return rval;
}
return FALSE;
}
case PL_STRING:
{ word w = textToString(text);
@ -335,7 +373,7 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
{ const unsigned char *s = (const unsigned char *)text->text.t;
const unsigned char *e = &s[text->length];
if ( !(p0 = p = INIT_SEQ_CODES(text->length)) )
if ( !(p0 = p = INIT_SEQ_STRING(text->length)) )
return FALSE;
if ( type == PL_CODE_LIST ) {
@ -343,7 +381,7 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
p = EXTEND_SEQ_CODES(p, *s);
} else {
for( ; s < e; s++)
p = EXTEND_SEQ_ATOMS(p, *s);
p = EXTEND_SEQ_CHARS(p, *s);
}
break;
}
@ -351,7 +389,7 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
{ const pl_wchar_t *s = (const pl_wchar_t *)text->text.t;
const pl_wchar_t *e = &s[text->length];
if ( !(p0 = p = INIT_SEQ_CODES(text->length)) )
if ( !(p0 = p = INIT_SEQ_STRING(text->length)) )
return FALSE;
if ( type == PL_CODE_LIST ) {
@ -359,7 +397,7 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
p = EXTEND_SEQ_CODES(p, *s);
} else {
for( ; s < e; s++)
p = EXTEND_SEQ_ATOMS(p, *s);
p = EXTEND_SEQ_CHARS(p, *s);
}
break;
}
@ -368,22 +406,22 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
const char *e = &s[text->length];
size_t len = utf8_strlen(s, text->length);
if ( !(p0 = p = INIT_SEQ_CODES(len)) )
if ( !(p0 = p = INIT_SEQ_STRING(len)) )
return FALSE;
if ( type == PL_CODE_LIST ) {
while (s < e) {
int chr;
s = utf8_get_char(s, &chr);
p = EXTEND_SEQ_CODES(p, chr);
}
} else {
while (s < e) {
int chr;
s = utf8_get_char(s, &chr);
p = EXTEND_SEQ_ATOMS(p, chr);
p = EXTEND_SEQ_CHARS(p, chr);
}
}
break;
@ -396,25 +434,29 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
wchar_t wc;
memset(&mbs, 0, sizeof(mbs));
while( n > 0 && (rc=mbrtowc(&wc, s, n, &mbs)) != (size_t)-1 )
{ len++;
while( n > 0 )
{ if ( (rc=mbrtowc(&wc, s, n, &mbs)) == (size_t)-1 || rc == 0 )
return PL_error(NULL, 0, "cannot represent text in current locale",
ERR_REPRESENTATION, ATOM_encoding);
len++;
n -= rc;
s += rc;
}
if ( !(p0 = p = INIT_SEQ_CODES(len)) )
if ( !(p0 = p = INIT_SEQ_STRING(len)) )
return FALSE;
memset(&mbs, 0, sizeof(mbs));
n = text->length;
s = text->text.t;
memset(&mbs, 0, sizeof(mbs));
while(n > 0)
{ rc = mbrtowc(&wc, s, n, &mbs);
if ( type == PL_CODE_LIST )
p = EXTEND_SEQ_CODES(p, wc);
else
p = EXTEND_SEQ_ATOMS(p, wc);
p = EXTEND_SEQ_CHARS(p, wc);
s += rc;
n -= rc;
@ -428,7 +470,7 @@ PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type)
}
}
return CLOSE_SEQ_OF_CODES(p, p0, tail, term, l );
return CLOSE_SEQ_STRING(p, p0, tail, term, l );
}
}
default:
@ -751,7 +793,7 @@ PL_canonise_text(PL_chars_t *text)
for(; w<e; w++)
{ if ( *w > 0xff )
return FALSE;
return TRUE;
}
return PL_demote_text(text);
@ -820,8 +862,11 @@ PL_canonise_text(PL_chars_t *text)
wchar_t wc;
memset(&mbs, 0, sizeof(mbs));
while( n > 0 && (rc=mbrtowc(&wc, s, n, &mbs)) != (size_t)-1 )
{ if ( wc > 0xff )
while( n > 0 )
{ if ( (rc=mbrtowc(&wc, s, n, &mbs)) == (size_t)-1 || rc == 0)
return FALSE; /* encoding error */
if ( wc > 0xff )
iso = FALSE;
len++;
n -= rc;
@ -853,8 +898,10 @@ PL_canonise_text(PL_chars_t *text)
}
to = text->text.t;
while( n > 0 && (rc=mbrtowc(&wc, from, n, &mbs)) != (size_t)-1 )
{ *to++ = (char)wc;
while( n > 0 )
{ rc = mbrtowc(&wc, from, n, &mbs);
*to++ = (char)wc;
n -= rc;
from += rc;
}
@ -876,8 +923,10 @@ PL_canonise_text(PL_chars_t *text)
}
to = text->text.w;
while( n > 0 && (rc=mbrtowc(&wc, from, n, &mbs)) != (size_t)-1 )
{ *to++ = wc;
while( n > 0 )
{ rc = mbrtowc(&wc, from, n, &mbs);
*to++ = wc;
n -= rc;
from += rc;
}
@ -999,12 +1048,12 @@ PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
if ( l > (ssize_t)(t1->length - o1) )
{ l = t1->length - o1;
ifeq = -1; /* first is short */
ifeq = CMP_LESS; /* first is short */
}
if ( l > (ssize_t)(t2->length - o2) )
{ l = t2->length - o2;
if ( ifeq == 0 )
ifeq = 1;
ifeq = CMP_GREATER;
}
if ( l == 0 ) /* too long offsets */
@ -1019,7 +1068,7 @@ PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
if ( l < 0 )
return ifeq;
else
return *s > *q ? 1 : -1;
return *s > *q ? CMP_GREATER : CMP_LESS;
} else if ( t1->encoding == ENC_WCHAR && t2->encoding == ENC_WCHAR )
{ const pl_wchar_t *s = t1->text.w+o1;
const pl_wchar_t *q = t2->text.w+o2;
@ -1029,7 +1078,7 @@ PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
if ( l < 0 )
return ifeq;
else
return *s > *q ? 1 : -1;
return *s > *q ? CMP_GREATER : CMP_LESS;
} else if ( t1->encoding == ENC_ISO_LATIN_1 && t2->encoding == ENC_WCHAR )
{ const unsigned char *s = (const unsigned char *)t1->text.t+o1;
const pl_wchar_t *q = t2->text.w+o2;
@ -1039,7 +1088,7 @@ PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
if ( l < 0 )
return ifeq;
else
return *s > *q ? 1 : -1;
return *s > *q ? CMP_GREATER : CMP_LESS;
} else
{ const pl_wchar_t *s = t1->text.w+o1;
const unsigned char *q = (const unsigned char *)t2->text.t+o2;
@ -1049,7 +1098,7 @@ PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
if ( l < 0 )
return ifeq;
else
return *s > *q ? 1 : -1;
return *s > *q ? CMP_GREATER : CMP_LESS;
}
}

33
packages/PLStream/pl-text.h
View File

@ -54,28 +54,31 @@ typedef struct
(txt)->canonical = FALSE; \
}
extern int PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type);
extern int PL_unify_text_range(term_t term, PL_chars_t *text,
int PL_unify_text(term_t term, term_t tail, PL_chars_t *text, int type);
int PL_unify_text_range(term_t term, PL_chars_t *text,
size_t from, size_t len, int type);
extern int PL_promote_text(PL_chars_t *text);
extern int PL_demote_text(PL_chars_t *text);
extern int PL_mb_text(PL_chars_t *text, int flags);
extern int PL_canonise_text(PL_chars_t *text);
int PL_promote_text(PL_chars_t *text);
int PL_demote_text(PL_chars_t *text);
int PL_mb_text(PL_chars_t *text, int flags);
int PL_canonise_text(PL_chars_t *text);
extern int PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
int PL_cmp_text(PL_chars_t *t1, size_t o1, PL_chars_t *t2, size_t o2,
size_t len);
extern int PL_concat_text(int n, PL_chars_t **text, PL_chars_t *result);
int PL_concat_text(int n, PL_chars_t **text, PL_chars_t *result);
extern void PL_free_text(PL_chars_t *text);
extern void PL_save_text(PL_chars_t *text, int flags);
void PL_free_text(PL_chars_t *text);
void PL_save_text(PL_chars_t *text, int flags);
extern int PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD);
extern atom_t textToAtom(PL_chars_t *text);
extern word textToString(PL_chars_t *text);
COMMON(int) PL_get_text__LD(term_t l, PL_chars_t *text, int flags ARG_LD);
COMMON(atom_t) textToAtom(PL_chars_t *text);
extern IOSTREAM * Sopen_text(PL_chars_t *text, const char *mode);
extern void PL_text_recode(PL_chars_t *text, IOENC encoding);
COMMON(IOSTREAM *) Sopen_text(PL_chars_t *text, const char *mode);
COMMON(void) PL_text_recode(PL_chars_t *text, IOENC encoding);
/* pl-fli.c */
COMMON(int) get_atom_ptr_text(Atom atom, PL_chars_t *text);
COMMON(int) get_atom_text(atom_t atom, PL_chars_t *text);
COMMON(int) get_string_text(atom_t atom, PL_chars_t *text ARG_LD);
#endif /*PL_TEXT_H_INCLUDED*/

2
packages/PLStream/pl-utf8.c
View File

@ -61,7 +61,7 @@ _PL__utf8_get_char(const char *in, int *chr)
}
*chr = *in;
return (char *)in+1;
}

1
packages/PLStream/pl-utf8.h
View File

@ -57,5 +57,4 @@ extern char *_PL__utf8_put_char(char *out, int chr);
extern size_t utf8_strlen(const char *s, size_t len);
#endif /*UTF8_H_INCLUDED*/

24
packages/PLStream/pl-util.c
View File

@ -12,17 +12,6 @@ stricmp(const char *s1, const char *s2)
}
#endif
bool
stripostfix(char *s, char *e)
{ int ls = strlen(s);
int le = strlen(e);
if ( ls >= le )
return stricmp(&s[ls-le], e) == 0;
return FALSE;
}
#if !defined(HAVE_MBSCOLL) || !defined(HAVE_MBCASESCOLL)
static void
wstolower(wchar_t *w, size_t len)
@ -80,17 +69,4 @@ out:
#endif
#ifndef HAVE_MBSCOLL
int
mbscoll(const char *s1, const char *s2)
{ return int_mbscoll(s1, s2, FALSE);
}
#endif
#ifndef HAVE_MBSCASECOLL
int
mbscasecoll(const char *s1, const char *s2)
{ return int_mbscoll(s1, s2, TRUE);
}
#endif

1488
packages/PLStream/pl-write.c Normal file
View File

File diff suppressed because it is too large Load Diff

372
packages/PLStream/pl-yap.c
View File

@ -94,6 +94,16 @@ PL_rethrow(void)
fail;
}
int
saveWakeup(wakeup_state *state, int forceframe ARG_LD)
{
return 0;
}
void
restoreWakeup(wakeup_state *state ARG_LD)
{
}
int
callProlog(module_t module, term_t goal, int flags, term_t *ex)
@ -133,33 +143,6 @@ callProlog(module_t module, term_t goal, int flags, term_t *ex)
}
}
extern X_API int PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags);
X_API int
PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags)
{
int nflags = 0;
if (flags & PL_WRT_QUOTED)
nflags |= Quote_illegal_f;
if (flags & PL_WRT_IGNOREOPS)
nflags |= Ignore_ops_f;
if (flags & PL_WRT_NUMBERVARS)
nflags |= Handle_vars_f;
if (flags & PL_WRT_PORTRAY)
nflags |= Use_portray_f;
/* ignore other flags for now */
YAP_Write(YAP_GetFromSlot(term), (void (*)(int))Sputc, flags);
return TRUE;
}
int
writeAtomToStream(IOSTREAM *so, atom_t at)
{
YAP_Write(YAP_MkAtomTerm((YAP_Atom)at), (void (*)(int))Sputc, 0);
return TRUE;
}
int
valueExpression(term_t t, Number r ARG_LD)
{ //return YAP__expression(t, r, 0 PASS_LD);
@ -295,129 +278,6 @@ typedef union
} optvalue;
bool
scan_options(term_t options, int flags, atom_t optype,
const opt_spec *specs, ...)
{ va_list args;
const opt_spec *s;
optvalue values[MAXOPTIONS];
term_t list = PL_copy_term_ref(options);
term_t head = PL_new_term_ref();
term_t tmp = PL_new_term_ref();
term_t val = PL_new_term_ref();
int n;
if ( truePrologFlag(PLFLAG_ISO) )
flags |= OPT_ALL;
va_start(args, specs);
for( n=0, s = specs; s->name; s++, n++ )
values[n].ptr = va_arg(args, void *);
va_end(args);
while ( PL_get_list(list, head, list) )
{ atom_t name;
int arity;
if ( PL_get_name_arity(head, &name, &arity) )
{ if ( name == ATOM_equals && arity == 2 )
{ PL_get_arg(1, head, tmp);
if ( !PL_get_atom(tmp, &name) )
goto itemerror;
PL_get_arg(2, head, val);
} else if ( arity == 1 )
{ PL_get_arg(1, head, val);
} else if ( arity == 0 )
PL_put_atom(val, ATOM_true);
} else if ( PL_is_variable(head) )
{ return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
} else
{ itemerror:
return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head);
}
for( n=0, s = specs; s->name; n++, s++ )
{ if ( s->name == name )
{ switch((s->type & OPT_TYPE_MASK))
{ case OPT_BOOL:
{ atom_t aval;
if ( !PL_get_atom(val, &aval) )
fail;
if ( aval == ATOM_true || aval == ATOM_on )
*values[n].b = TRUE;
else if ( aval == ATOM_false || aval == ATOM_off )
*values[n].b = FALSE;
else
goto itemerror;
break;
}
case OPT_INT:
{ if ( !PL_get_integer(val, values[n].i) )
goto itemerror;
break;
}
case OPT_LONG:
{ if ( !PL_get_long(val, values[n].l) )
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
*values[n].l = LONG_MAX;
else
goto itemerror;
}
break;
}
case OPT_NATLONG:
{ if ( !PL_get_long(val, values[n].l) )
goto itemerror;
if ( *(values[n].l) <= 0 )
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
ATOM_not_less_than_one, val);
break;
}
case OPT_STRING:
{ char *str;
if ( !PL_get_chars(val, &str, CVT_ALL) ) /* copy? */
goto itemerror;
*values[n].s = str;
break;
}
case OPT_ATOM:
{ atom_t a;
if ( !PL_get_atom(val, &a) )
goto itemerror;
*values[n].a = a;
break;
}
case OPT_TERM:
{ *values[n].t = val;
val = PL_new_term_ref(); /* can't reuse anymore */
break;
}
default:
assert(0);
fail;
}
break;
}
}
if ( !s->name && (flags & OPT_ALL) )
goto itemerror;
}
if ( !PL_get_nil(list) )
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
succeed;
}
int
get_atom_ptr_text(Atom a, PL_chars_t *text)
{ if (YAP_IsWideAtom(a))
@ -484,126 +344,24 @@ that is not a digit nor [eE], as this must be the decimal point.
#define isDigit(c) ((c) >= '0' && (c) <= '9')
char *
format_float(double f, char *buf, const char *format)
{ char *q;
sprintf(buf, format, f);
q = buf;
if ( *q == '-' ) /* skip -?[0-9]* */
q++;
while(*q && (isDigit(*q) || *q <= ' '))
q++;
switch( *q )
{ case '\0':
*q++ = '.';
*q++ = '0';
*q = EOS;
break;
case 'e':
case 'E':
break;
default:
*q = '.';
}
return buf;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
codes_or_chars_to_buffer(term_t l, unsigned flags, int wide)
If l represents a list of codes or characters, return a buffer holding
the characters. If wide == TRUE the buffer contains objects of type
pl_wchar_t. Otherwise it contains traditional characters.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int
charCode(YAP_Term w)
{ if ( YAP_IsAtomTerm(w) )
{
Atom a = atomValue(w);
if ( YAP_AtomNameLength(a) == 1) {
if (YAP_IsWideAtom(a)) {
return YAP_WideAtomName(a)[0];
}
return YAP_AtomName(a)[0];
}
}
return -1;
}
Buffer
codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide)
intptr_t
lengthList(term_t list, int errors)
{ GET_LD
Buffer b;
YAP_Term list = YAP_GetFromSlot(l);
YAP_Term arg;
enum { CHARS, CODES } type;
intptr_t length = 0;
Word l = YAP_AddressFromSlot(list);
Word tail;
if ( YAP_IsPairTerm(list) )
{ arg = YAP_HeadOfTerm(list);
if ( YAP_IsIntTerm(arg) )
{ long int i = YAP_IntOfTerm(arg);
if ( i >= 0 && (wide || i < 256) )
{ type = CODES;
goto ok;
}
} else if ( charCode(arg) >= 0 )
{ type = CHARS;
goto ok;
}
} else if ( list != YAP_TermNil() )
{ return findBuffer(flags);
}
length = skip_list(l, &tail PASS_LD);
fail;
if ( isNil(*tail) )
return length;
ok:
b = findBuffer(flags);
if ( errors )
PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, wordToTermRef(l));
while( YAP_IsPairTerm(list) )
{ intptr_t c = -1;
arg = YAP_HeadOfTerm(list);
switch(type)
{ case CODES:
if ( YAP_IsIntTerm(arg) )
{ c = YAP_IntOfTerm(arg);
}
break;
case CHARS:
c = charCode(arg);
break;
}
if ( c < 0 || (!wide && c > 0xff) )
{ unfindBuffer(flags); /* TBD: check unicode range */
return NULL;
}
if ( wide )
addBuffer(b, (pl_wchar_t)c, pl_wchar_t);
else
addBuffer(b, (unsigned char)c, unsigned char);
list = YAP_TailOfTerm(list);
}
if ( list != YAP_TermNil() )
{ unfindBuffer(flags);
return NULL;
}
return b;
return isVar(*tail) ? -2 : -1;
}
void
setPrologFlag(const char *name, int flags, ...)
{
@ -653,6 +411,94 @@ X_API int PL_handle_signals(void)
return 0;
}
void
outOfCore()
{ fprintf(stderr,"Could not allocate memory: %s", OsError());
exit(1);
}
int
priorityOperator(Module m, atom_t atom)
{
return 0;
}
int
currentOperator(Module m, atom_t name, int kind, int *type, int *priority)
{
return 0;
}
int
numberVars(term_t t, nv_options *opts, int n ARG_LD) {
return 0;
}
/*******************************
* PROMOTION *
*******************************/
#ifdef O_GMP
void
clearGMPNumber(Number n)
{ switch(n->type)
{ case V_MPZ:
if ( n->value.mpz->_mp_alloc )
mpz_clear(n->value.mpz);
break;
case V_MPQ:
if ( mpq_numref(n->value.mpq)->_mp_alloc )
mpz_clear(mpq_numref(n->value.mpq));
if ( mpq_denref(n->value.mpq)->_mp_alloc )
mpz_clear(mpq_denref(n->value.mpq));
break;
default:
break;
}
}
#endif
int
promoteToFloatNumber(Number n)
{ switch(n->type)
{ case V_INTEGER:
n->value.f = (double)n->value.i;
n->type = V_FLOAT;
break;
#ifdef O_GMP
case V_MPZ:
{ double val = mpz_get_d(n->value.mpz);
if ( !check_float(val) )
return FALSE;
clearNumber(n);
n->value.f = val;
n->type = V_FLOAT;
break;
}
case V_MPQ:
{ double val = mpq_get_d(n->value.mpq);
if ( !check_float(val) )
return FALSE;
clearNumber(n);
n->value.f = val;
n->type = V_FLOAT;
break;
}
#endif
case V_FLOAT:
break;
}
return TRUE;
}
X_API int
PL_ttymode(IOSTREAM *s)
{ GET_LD

181
packages/PLStream/pl-yap.h
View File

@ -3,32 +3,53 @@
#ifdef __YAP_PROLOG__
/* depends on tag schema, but 4 should always do */
#define LMASK_BITS 4 /* total # mask bits */
#if HAVE_CTYPE_H
#include <ctype.h>
#endif
#if HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
#define SIZE_VOIDP SIZEOF_INT_P
#if SIZE_DOUBLE==SIZEOF_INT_P
#define WORDS_PER_DOUBLE 1
#else
#define WORDS_PER_DOUBLE 2
#endif
#if SIZEOF_LONG_INT==4
#define INT64_FORMAT "%lld"
#define INTBITSIZE 32
#else
#define INT64_FORMAT "%ld"
#define INTBITSIZE 64
#endif
#define INTBITSIZE (sizeof(int)*8)
typedef uintptr_t word; /* Anonymous 4 byte object */
typedef YAP_Term Word; /* Anonymous 4 byte object */
typedef YAP_Term Module;
typedef YAP_Term *Word; /* Anonymous 4 byte object */
typedef YAP_Atom Atom;
typedef YAP_Term (*Func)(); /* foreign functions */
extern atom_t codeToAtom(int chrcode);
#define valTermRef(t) ((Word)YAP_AddressFromSlot(t))
#include "pl-codelist.h"
//move this to SWI
typedef uintptr_t PL_atomic_t; /* same a word */
#define GP_CREATE 2 /* create (in this module) */
#ifndef HAVE_MBSCOLL
COMMON(int) mbscoll(const char *s1, const char *s2);
#endif
#ifndef HAVE_MBSCASECOLL
COMMON(int) mbscasecoll(const char *s1, const char *s2);
#endif
COMMON(atom_t) TemporaryFile(const char *id, int *fdp);
COMMON(char *) Getenv(const char *, char *buf, size_t buflen);
/*** memory allocation stuff: SWI wraps around malloc */
@ -36,51 +57,54 @@ typedef uintptr_t PL_atomic_t; /* same a word */
#define freeHeap(X,Size) YAP_FreeSpaceFromYap(X)
#define stopItimer()
/* TBD */
COMMON(word) pl_print(term_t term);
COMMON(word) pl_write(term_t term);
COMMON(word) pl_write_canonical(term_t term);
COMMON(word) pl_write_term(term_t term, term_t options);
COMMON(word) pl_writeq(term_t term);
extern atom_t codeToAtom(int chrcode);
static inline int
get_procedure(term_t descr, predicate_t *proc, term_t he, int f) {
YAP_Term t = YAP_GetFromSlot(descr);
if (YAP_IsVarTerm(t)) return 0;
if (YAP_IsAtomTerm(t))
*proc = YAP_Predicate(YAP_AtomOfTerm(t),0,YAP_CurrentModule());
else if (YAP_IsApplTerm(t)) {
YAP_Functor f = YAP_FunctorOfTerm(t);
*proc = YAP_Predicate(YAP_NameOfFunctor(f),YAP_ArityOfFunctor(f),YAP_CurrentModule());
}
return 1;
}
COMMON(intptr_t) lengthList(term_t list, int errors);
COMMON(int) promoteToFloatNumber(Number n);
COMMON(char *) PrologPath(const char *ospath, char *plpath, size_t len);
COMMON(char *) ExpandOneFile(const char *spec, char *file);
COMMON(char *) AbsoluteFile(const char *spec, char *path);
COMMON(char *) BaseName(const char *f);
COMMON(bool) ChDir(const char *path);
COMMON(char *) OsPath(const char *plpath, char *ospath);
COMMON(bool) ChDir(const char *path);
COMMON(int) DeleteTemporaryFile(atom_t name);
COMMON(int) IsAbsolutePath(const char *spec);
/* TBD */
extern word globalString(size_t size, char *s);
extern word globalWString(size_t size, wchar_t *s);
static inline word
INIT_SEQ_CODES(size_t n)
{
return (word)YAP_OpenList(n);
}
static inline word
EXTEND_SEQ_CODES(word gstore, int c) {
return (word)YAP_ExtendList((YAP_Term)gstore, YAP_MkIntTerm(c));
}
static inline word
EXTEND_SEQ_ATOMS(word gstore, int c) {
return (word)YAP_ExtendList((YAP_Term)gstore, codeToAtom(c));
}
static inline int
CLOSE_SEQ_OF_CODES(word gstore, word lp, word arg2, word arg3, term_t l) {
if (arg2 == 0) {
if (!YAP_CloseList((YAP_Term)gstore, YAP_TermNil()))
return FALSE;
} else {
if (!YAP_CloseList((YAP_Term)gstore, YAP_GetFromSlot(arg2)))
return FALSE;
}
return YAP_Unify(YAP_GetFromSlot(arg3), lp);
}
static inline Word
valHandle(term_t tt)
{
return (word)YAP_GetFromSlot(tt);
}
YAP_Int YAP_PLArityOfSWIFunctor(functor_t f);
PL_blob_t* YAP_find_blob_type(YAP_Atom at);
#define arityFunctor(f) YAP_PLArityOfSWIFunctor(f)
@ -93,17 +117,47 @@ YAP_Int YAP_PLArityOfSWIFunctor(functor_t f);
#define isReal(A) YAP_IsFloatTerm((A))
#define isFloat(A) YAP_IsFloatTerm((A))
#define isVar(A) YAP_IsVarTerm((A))
#define varName(l, buf) buf
#define valReal(w) YAP_FloatOfTerm((w))
#define valFloat(w) YAP_FloatOfTerm((w))
#define AtomLength(w) YAP_AtomNameLength(w)
#define atomValue(atom) YAP_AtomOfTerm(atom)
#define atomName(atom) ((char *)YAP_AtomName(atom))
#define nameOfAtom(atom) ((char *)YAP_AtomName(atom))
#define atomLength(atom) YAP_AtomNameLength(atom)
#define atomBlobType(at) YAP_find_blob_type(at)
#define argTermP(w,i) ((Word)((YAP_ArgsOfTerm(w)+(i))))
#define deRef(t) (t = YAP_Deref(t))
#define canBind(t) FALSE
#define deRef(t)
#define canBind(t) FALSE // VSC: to implement
#define MODULE_user YAP_ModuleUser()
#define _PL_predicate(A,B,C,D) PL_predicate(A,B,C)
#define predicateHasClauses(A) (YAP_NumberOfClausesForPredicate((YAP_PredEntryPtr)A) != 0)
#define lookupModule(A) ((module_t)PL_new_module(A))
#define charEscapeWriteOption(A) FALSE // VSC: to implement
#define skip_list(A,B) YAP_SkipList(A,B)
#define wordToTermRef(A) YAP_InitSlot(*(A))
#define isTaggedInt(A) YAP_IsIntTerm(A)
#define valInt(A) YAP_IntOfTerm(A)
#define clearNumber(n)
inline static int
charCode(YAP_Term w)
{ if ( YAP_IsAtomTerm(w) )
{
Atom a = atomValue(w);
if ( YAP_AtomNameLength(a) == 1) {
if (YAP_IsWideAtom(a)) {
return YAP_WideAtomName(a)[0];
}
return YAP_AtomName(a)[0];
}
}
return -1;
}
#endif /* __YAP_PROLOG__ */
#if IN_PL_OS_C
@ -119,44 +173,5 @@ stripostfix(const char *s, const char *e)
}
#endif
#define ERR_NO_ERROR 0
#define ERR_INSTANTIATION 1 /* void */
#define ERR_TYPE 2 /* atom_t expected, term_t value */
#define ERR_DOMAIN 3 /* atom_t domain, term_t value */
#define ERR_REPRESENTATION 4 /* atom_t what */
#define ERR_MODIFY_STATIC_PROC 5 /* predicate_t proc */
#define ERR_EVALUATION 6 /* atom_t what */
#define ERR_AR_TYPE 7 /* atom_t expected, Number value */
#define ERR_NOT_EVALUABLE 8 /* functor_t func */
#define ERR_DIV_BY_ZERO 9 /* void */
#define ERR_FAILED 10 /* predicate_t proc */
#define ERR_FILE_OPERATION 11 /* atom_t action, atom_t type, term_t */
#define ERR_PERMISSION 12 /* atom_t type, atom_t op, term_t obj*/
#define ERR_NOT_IMPLEMENTED 13 /* const char *what */
#define ERR_EXISTENCE 14 /* atom_t type, term_t obj */
#define ERR_STREAM_OP 15 /* atom_t action, term_t obj */
#define ERR_RESOURCE 16 /* atom_t resource */
#define ERR_NOMEM 17 /* void */
#define ERR_SYSCALL 18 /* void */
#define ERR_SHELL_FAILED 19 /* term_t command */
#define ERR_SHELL_SIGNALLED 20 /* term_t command, int signal */
#define ERR_AR_UNDEF 21 /* void */
#define ERR_AR_OVERFLOW 22 /* void */
#define ERR_AR_UNDERFLOW 23 /* void */
#define ERR_UNDEFINED_PROC 24 /* Definition def */
#define ERR_SIGNALLED 25 /* int sig, char *name */
#define ERR_CLOSED_STREAM 26 /* IOSTREAM * */
#define ERR_BUSY 27 /* mutexes */
#define ERR_PERMISSION_PROC 28 /* op, type, Definition */
#define ERR_DDE_OP 29 /* op, error */
#define ERR_SYNTAX 30 /* what */
#define ERR_SHARED_OBJECT_OP 31 /* op, error */
#define ERR_TIMEOUT 32 /* op, object */
#define ERR_NOT_IMPLEMENTED_PROC 33 /* name, arity */
#define ERR_FORMAT 34 /* message */
#define ERR_FORMAT_ARG 35 /* seq, term */
#define ERR_OCCURS_CHECK 36 /* Word, Word */
#define ERR_CHARS_TYPE 37 /* char *, term */
#define ERR_MUST_BE_VAR 38 /* int argn, term_t term */
#endif /* PL_YAP_H */

2
packages/chr

@ -1 +1 @@
Subproject commit 2dad0025b6c016ac1eb77670d6cd165856897c20
Subproject commit bf6525f85cfcf3c08fff8cf91fb189fe71dc34fd

2
packages/clpqr

@ -1 +1 @@
Subproject commit 5d263188330d4c66b88d25247dfdbd482a39b75a
Subproject commit f71221999d3f30f748c71750c5b77aa769613087

2
packages/jpl

@ -1 +1 @@
Subproject commit 29151b2fe68f2dc727cdc07040e1fa1ad4fcca20
Subproject commit 4f82114d41f8eba34afaae50a0d98936b7f19122