/* yap2swi.c */ /* * Project: jpl for Yap Prolog * Author: Steve Moyle and Vitor Santos Costa * Email: steve.moyle@comlab.ox.ac.uk * Date: 21 January 2002 * Copyright (c) 2002 Steve Moyle. All rights reserved. */ //=== includes =============================================================== #include #include #include #include #include #include #include #ifdef USE_GMP #include #endif #ifdef __WIN32__ /* Windows */ #include #endif #define BUF_SIZE 256 #define TMP_BUF_SIZE 2*BUF_SIZE #define BUF_RINGS 16 char buffers[TMP_BUF_SIZE+BUF_SIZE*BUF_RINGS]; static int buf_index = 0; static char * alloc_ring_buf(void) { int ret = buf_index; buf_index++; if (buf_index == BUF_RINGS) buf_index = 0; return buffers+(TMP_BUF_SIZE+ret*BUF_SIZE); } /* SWI: void PL_agc_hook(void) */ X_API PL_agc_hook_t PL_agc_hook(PL_agc_hook_t entry) { return (PL_agc_hook_t)YAP_AGCRegisterHook((YAP_agc_hook)entry); } /* SWI: char* PL_atom_chars(atom_t atom) YAP: char* AtomName(Atom) */ X_API char* PL_atom_chars(atom_t a) /* SAM check type */ { return (char *)YAP_AtomName((YAP_Atom)a); } /* SWI: term_t PL_copy_term_ref(term_t from) YAP: NO EQUIVALENT */ /* SAM TO DO */ X_API term_t PL_copy_term_ref(term_t from) { return YAP_InitSlot(YAP_GetFromSlot(from)); } X_API term_t PL_new_term_ref(void) { term_t to = YAP_NewSlots(1); return to; } X_API term_t PL_new_term_refs(int n) { term_t to = YAP_NewSlots(n); return to; } X_API void PL_reset_term_refs(term_t after) { term_t new = YAP_NewSlots(1); YAP_RecoverSlots(after-new); } /* begin PL_get_* functions =============================*/ /* SWI: int PL_get_arg(int index, term_t t, term_t a) YAP: YAP_Term YAP_ArgOfTerm(int argno, YAP_Term t)*/ X_API int PL_get_arg(int index, term_t ts, term_t a) { YAP_Term t = YAP_GetFromSlot(ts); if ( !YAP_IsApplTerm(t) ) { if (YAP_IsPairTerm(t)) { if (index == 1){ YAP_PutInSlot(a,YAP_HeadOfTerm(t)); return 1; } else if (index == 2) { YAP_PutInSlot(a,YAP_TailOfTerm(t)); return 1; } } return 0; } YAP_PutInSlot(a,YAP_ArgOfTerm(index, t)); return 1; } /* SWI: int PL_get_atom(term_t t, YAP_Atom *a) YAP: YAP_Atom YAP_AtomOfTerm(Term) */ X_API int PL_get_atom(term_t ts, atom_t *a) { YAP_Term t = YAP_GetFromSlot(ts); if ( !YAP_IsAtomTerm(t)) return 0; *a = (atom_t)YAP_AtomOfTerm(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 */ { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsAtomTerm(t)) return 0; *a = (char *)YAP_AtomName(YAP_AtomOfTerm(t)); return 1; } /* int PL_get_chars(term_t +t, char **s, unsigned flags) Convert the argument term t to a 0-terminated C-string. flags is a bitwise disjunction from two groups of constants. The first specifies which term-types should converted and the second how the argument is stored. Below is a specification of these constants. BUF_RING implies, if the data is not static (as from an atom), the data is copied to the next buffer from a ring of sixteen (16) buffers. This is a convenient way of converting multiple arguments passed to a foreign predicate to C-strings. If BUF_MALLOC is used, the data must be freed using free() when not needed any longer. CVT_ATOM Convert if term is an atom CVT_STRING Convert if term is a string CVT_LIST Convert if term is a list of integers between 1 and 255 CVT_INTEGER Convert if term is an integer (using %d) CVT_FLOAT Convert if term is a float (using %f) CVT_NUMBER Convert if term is a integer or float CVT_ATOMIC Convert if term is atomic CVT_VARIABLE Convert variable to print-name CVT_ALL Convert if term is any of the above, except for variables BUF_DISCARDABLE Data must copied immediately BUF_RING Data is stored in a ring of buffers BUF_MALLOC Data is copied to a new buffer returned by malloc(3) */ static int CvtToStringTerm(YAP_Term t, char *buf, char *buf_max) { *buf++ = '\"'; while (YAP_IsPairTerm(t)) { YAP_Term hd = YAP_HeadOfTerm(t); long int i; if (!YAP_IsIntTerm(hd)) return 0; i = YAP_IntOfTerm(hd); if (i <= 0 || i >= 255) return 0; if (!YAP_IsIntTerm(hd)) return 0; *buf++ = i; if (buf == buf_max) return 0; t = YAP_TailOfTerm(t); } if (t != YAP_MkAtomTerm(YAP_LookupAtom("[]"))) return 0; if (buf+1 == buf_max) return 0; buf[0] = '\"'; buf[1] = '\0'; return 1; } char *bf, *bf_lim; static void buf_writer(int c) { if (bf == bf_lim) { return; } *bf++ = c; } #if !HAVE_SNPRINTF #define snprintf(X,Y,Z,A) sprintf(X,Z,A) #endif X_API int PL_get_chars(term_t l, char **sp, unsigned flags) { YAP_Term t = YAP_GetFromSlot(l); char *tmp; if (!(flags & BUF_RING)) { tmp = alloc_ring_buf(); } else { tmp = buffers; } *sp = tmp; if (YAP_IsAtomTerm(t)) { YAP_Atom at = YAP_AtomOfTerm(t); if (!(flags & (CVT_ATOM|CVT_ATOMIC|CVT_ALL))) return 0; if (YAP_IsWideAtom(at)) /* will this always work? */ snprintf(*sp,BUF_SIZE,"%ls",YAP_WideAtomName(at)); else *sp = (char *)YAP_AtomName(YAP_AtomOfTerm(t)); return 1; } else if (YAP_IsIntTerm(t)) { if (!(flags & (CVT_INTEGER|CVT_NUMBER|CVT_ATOMIC|CVT_ALL))) return 0; snprintf(tmp,BUF_SIZE,"%ld",YAP_IntOfTerm(t)); } else if (YAP_IsFloatTerm(t)) { if (!(flags & (CVT_FLOAT|CVT_ATOMIC|CVT_NUMBER|CVT_ALL))) return 0; snprintf(tmp,BUF_SIZE,"%f",YAP_FloatOfTerm(t)); } else if (flags & CVT_STRING) { if (CvtToStringTerm(t,tmp,tmp+BUF_SIZE) == 0) return 0; } else { bf = tmp; bf_lim = tmp+(BUF_SIZE-1); YAP_Write(t,buf_writer,0); if (bf == bf_lim) return 0; *bf = '\0'; } if (flags & BUF_MALLOC) { char *nbf = YAP_AllocSpaceFromYap(strlen(tmp)+1); if (nbf == NULL) return 0; strncpy(nbf,tmp,BUF_SIZE); *sp = nbf; } return 1; } X_API int PL_get_nchars(term_t l, size_t *len, char **sp, unsigned flags) { int out = PL_get_chars(l, sp, flags); if (!out) return out; *len = strlen(*sp); return out; } /* same as get_chars, but works on buffers of wide chars */ X_API int PL_get_wchars(term_t l, size_t *len, wchar_t **wsp, unsigned flags) { if (YAP_IsAtomTerm(l)) { YAP_Atom at = YAP_AtomOfTerm(l); if (!(flags & (CVT_ATOM|CVT_ATOMIC|CVT_ALL))) return 0; if (YAP_IsWideAtom(at)) /* will this always work? */ *wsp = (wchar_t *)YAP_WideAtomName(at); } else { char *sp; int res = PL_get_chars(l, &sp, ((flags & ~(BUF_MALLOC|BUF_DISCARDABLE))|BUF_RING)); size_t sz; if (!res) { if (flags & CVT_EXCEPTION) YAP_Error(0, 0L, "PL_get_wchars"); return 0; } sz = wcstombs(sp,NULL,BUF_SIZE); if (flags & BUF_MALLOC) { wchar_t *nbf = (wchar_t *)YAP_AllocSpaceFromYap(sz+1); if (nbf == NULL) { if (flags & CVT_EXCEPTION) YAP_Error(0, 0L, "PL_get_wchars: lack of memory"); return 0; } *wsp = nbf; } else if (flags & BUF_DISCARDABLE) { wchar_t *buf = (wchar_t *)buffers; if (wcstombs(sp,buf,BUF_SIZE) == -1) { if (flags & CVT_EXCEPTION) YAP_Error(0, 0L, "PL_get_wchars: wcstombs"); return 0; } *wsp = buf; } else { wchar_t *tmp = (wchar_t *)alloc_ring_buf(); if (wcstombs(sp, tmp, BUF_SIZE) == -1) { if (flags & CVT_EXCEPTION) YAP_Error(0, 0L, "PL_get_wchars: wcstombs"); return 0; } *wsp = tmp; } return res; } if (flags & CVT_EXCEPTION) YAP_Error(0, 0L, "PL_get_wchars"); return 0; } /* SWI: int PL_get_functor(term_t t, functor_t *f) YAP: YAP_Functor YAP_FunctorOfTerm(Term) */ X_API int PL_get_functor(term_t ts, functor_t *f) { YAP_Term t = YAP_GetFromSlot(ts); if ( YAP_IsAtomTerm(t)) { *f = t; } else { *f = (functor_t)YAP_FunctorOfTerm(t); } return 1; } /* SWI: int PL_get_float(term_t t, double *f) YAP: double YAP_FloatOfTerm(Term) */ X_API int PL_get_float(term_t ts, double *f) /* SAM type check*/ { YAP_Term t = YAP_GetFromSlot(ts); if ( !YAP_IsFloatTerm(t)) return 0; *f = YAP_FloatOfTerm(t); return 1; } X_API int PL_get_head(term_t ts, term_t h) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsPairTerm(t) ) { return 0; } YAP_PutInSlot(h,YAP_HeadOfTerm(t)); return 1; } /* SWI: int PL_get_integer(term_t t, int *i) YAP: long int YAP_IntOfTerm(Term) */ X_API int PL_get_integer(term_t ts, int *i) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsIntTerm(t) ) return 0; *i = YAP_IntOfTerm(t); return 1; } /* SWI: int PL_get_bool(term_t t, int *i) YAP: long int YAP_AtomOfTerm(Term) */ X_API int PL_get_bool(term_t ts, int *i) { YAP_Term t = YAP_GetFromSlot(ts); char *sp; if (!YAP_IsAtomTerm(t) ) return 0; sp = (char *)YAP_AtomName(YAP_AtomOfTerm(t)); if (!strcmp(sp,"true")) { *sp = TRUE; return 1; } if (!strcmp(sp,"false")) { *sp = FALSE; return 1; } return 0; } X_API int PL_get_long(term_t ts, long *i) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsIntTerm(t) ) { if (YAP_IsFloatTerm(t)) { double dbl = YAP_FloatOfTerm(t); if (dbl - (long)dbl == 0.0) { *i = (long)dbl; return 1; } } return 0; } *i = YAP_IntOfTerm(t); return 1; } X_API int PL_get_int64(term_t ts, int64_t *i) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsIntTerm(t) ) { if (YAP_IsFloatTerm(t)) { double dbl = YAP_FloatOfTerm(t); if (dbl - (int64_t)dbl == 0.0) { *i = (int64_t)dbl; return 1; } #if USE_GMP } else if (YAP_IsBigNumTerm(t)) { MP_INT g; char s[64]; YAP_BigNumOfTerm(t, (void *)&g); if (mpz_sizeinbase(&g,2) > 64) { return 0; } mpz_get_str (s, 10, &g); sscanf(s, "%lld", (long long int *)i); return 1; #endif } return 0; } *i = YAP_IntOfTerm(t); return 1; } X_API int PL_get_list(term_t ts, term_t h, term_t tl) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsPairTerm(t) ) { return 0; } YAP_PutInSlot(h,YAP_HeadOfTerm(t)); YAP_PutInSlot(tl,YAP_TailOfTerm(t)); return 1; } X_API int PL_get_list_chars(term_t l, char **sp, unsigned flags) { if (flags & (CVT_ATOM|CVT_STRING|CVT_INTEGER|CVT_FLOAT|CVT_NUMBER|CVT_ATOMIC|CVT_VARIABLE|CVT_ALL)) return 0; return PL_get_chars(l, sp, CVT_LIST|flags); } /* SWI: int PL_get_module(term_t t, module_t *m) */ X_API int PL_get_module(term_t ts, module_t *m) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsAtomTerm(t) ) return 0; *m = (module_t)YAP_LookupModule(t); return 1; } /* SWI: int PL_new_module(term_t t, module_t *m) */ X_API module_t PL_new_module(atom_t at) { return (module_t)YAP_CreateModule((YAP_Atom)at); } /* SWI: int PL_get_atom(term_t t, YAP_Atom *a) YAP: YAP_Atom YAP_AtomOfTerm(Term) */ X_API int PL_get_name_arity(term_t ts, atom_t *name, int *arity) { YAP_Term t = YAP_GetFromSlot(ts); if (YAP_IsAtomTerm(t)) { *name = (atom_t)YAP_AtomOfTerm(t); *arity = 0; return 1; } if (YAP_IsApplTerm(t)) { YAP_Functor f = YAP_FunctorOfTerm(t); *name = (atom_t)YAP_NameOfFunctor(f); *arity = YAP_ArityOfFunctor(f); return 1; } if (YAP_IsPairTerm(t)) { *name = (atom_t)YAP_LookupAtom("."); *arity = 2; return 1; } return 0; } /* SWI: int PL_get_atom(term_t t, YAP_Atom *a) YAP: YAP_Atom YAP_AtomOfTerm(Term) */ X_API int PL_get_nil(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); return ( t == YAP_MkAtomTerm(YAP_LookupAtom("[]"))); } /* SWI: int PL_get_pointer(term_t t, int *i) YAP: NO EQUIVALENT */ /* SAM TO DO */ X_API int PL_get_pointer(term_t ts, void **i) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsIntTerm(t) ) return 0; *i = (void *)YAP_IntOfTerm(t); return 1; } /* SWI: int PL_get_atom_chars(term_t t, char **s) YAP: char* AtomName(Atom) */ X_API int PL_get_string(term_t ts, char **sp, int *lenp) /* SAM check type */ { YAP_Term t = YAP_GetFromSlot(ts); char *to; int len; if (!YAP_IsPairTerm(t)) return 0; if (!YAP_StringToBuffer(t, buffers, TMP_BUF_SIZE)) return(FALSE); len = strlen(buffers); to = (char *)YAP_NewSlots((len/sizeof(YAP_Term))+1); strncpy(to, buffers, TMP_BUF_SIZE); *sp = to; return 1; } X_API int PL_get_tail(term_t ts, term_t tl) { YAP_Term t = YAP_GetFromSlot(ts); if (!YAP_IsPairTerm(t) ) { return 0; } YAP_PutInSlot(tl,YAP_TailOfTerm(t)); return 1; } /* end PL_get_* functions =============================*/ /* begin PL_new_* functions =============================*/ /* SWI: atom_t PL_new_atom(const char *) YAP: YAP_Atom LookupAtom(char *) */ /* SAM should the following be used instead? YAP_Atom FullLookupAtom(char *) */ X_API atom_t PL_new_atom(const char *c) { return (atom_t)YAP_LookupAtom((char *)c); } X_API atom_t PL_new_atom_wchars(int len, const wchar_t *c) { atom_t at; int i; for (i=0;i 255) break; } if (i!=len) { wchar_t *nbf = (wchar_t *)YAP_AllocSpaceFromYap((len+1)*sizeof(wchar_t)); for (i=0;i TMP_BUF_SIZE/sizeof(YAP_CELL)) { fprintf(stderr,"PL_cons_functor: arity too large (%d)\n", arity); return; } va_start (ap, f); for (i = 0; i < arity; i++) { tmp[i] = YAP_GetFromSlot(va_arg(ap, term_t)); } va_end (ap); if (arity == 2 && (YAP_Functor)f == YAP_MkFunctor(YAP_LookupAtom("."),2)) YAP_PutInSlot(d,YAP_MkPairTerm(tmp[0],tmp[1])); else YAP_PutInSlot(d,YAP_MkApplTerm((YAP_Functor)f,arity,tmp)); } X_API void PL_cons_functor_v(term_t d, functor_t f,term_t a0) { int arity; if (YAP_IsAtomTerm(f)) { YAP_PutInSlot(d,(YAP_Term)f); return; } arity = YAP_ArityOfFunctor((YAP_Functor)f); if (arity == 2 && (YAP_Functor)f == YAP_MkFunctor(YAP_LookupAtom("."),2)) YAP_PutInSlot(d,YAP_MkPairTerm(YAP_GetFromSlot(a0),YAP_GetFromSlot(a0+1))); else YAP_PutInSlot(d,YAP_MkApplTerm((YAP_Functor)f,arity,YAP_AddressFromSlot(a0))); } X_API void PL_cons_list(term_t d, term_t h, term_t t) { YAP_PutInSlot(d,YAP_MkPairTerm(YAP_GetFromSlot(h),YAP_GetFromSlot(t))); } X_API void PL_put_atom(term_t t, atom_t a) { YAP_PutInSlot(t,YAP_MkAtomTerm((YAP_Atom)a)); } X_API void PL_put_atom_chars(term_t t, const char *s) { YAP_PutInSlot(t,YAP_MkAtomTerm(YAP_LookupAtom((char *)s))); } X_API void PL_put_float(term_t t, double fl) { YAP_PutInSlot(t,YAP_MkFloatTerm(fl)); } X_API void PL_put_functor(term_t t, functor_t f) { long int arity; if (YAP_IsAtomTerm(f)) { YAP_PutInSlot(t,f); } else { arity = YAP_ArityOfFunctor((YAP_Functor)f); if (arity == 2 && (YAP_Functor)f == YAP_MkFunctor(YAP_LookupAtom("."),2)) YAP_PutInSlot(t,YAP_MkNewPairTerm()); else YAP_PutInSlot(t,YAP_MkNewApplTerm((YAP_Functor)f,arity)); } } X_API void PL_put_integer(term_t t, long n) { YAP_PutInSlot(t,YAP_MkIntTerm(n)); } X_API void PL_put_int64(term_t t, int64_t n) { #if USE_GMP char s[64]; MP_INT rop; sprintf(s, "%lld", (long long int)n); mpz_init_set_str (&rop, s, 10); YAP_PutInSlot(t,YAP_MkBigNumTerm((void *)&rop)); #endif } X_API void PL_put_list(term_t t) { YAP_PutInSlot(t,YAP_MkNewPairTerm()); } X_API void PL_put_list_chars(term_t t, const char *s) { YAP_PutInSlot(t,YAP_BufferToString((char *)s)); } X_API void PL_put_nil(term_t t) { YAP_PutInSlot(t,YAP_MkAtomTerm(YAP_LookupAtom("[]"))); } /* SWI: void PL_put_pointer(term_t -t, void *ptr) YAP: NO EQUIVALENT */ /* SAM TO DO */ X_API void PL_put_pointer(term_t t, void *ptr) { YAP_Term tptr = YAP_MkIntTerm((long int)ptr); YAP_PutInSlot(t,tptr); } X_API void PL_put_string_chars(term_t t, const char *s) { YAP_PutInSlot(t,YAP_BufferToString((char *)s)); } X_API void PL_put_term(term_t d, term_t s) { YAP_PutInSlot(d,YAP_GetFromSlot(s)); } X_API void PL_put_variable(term_t t) { YAP_PutInSlot(t,YAP_MkVarTerm()); } /* end PL_put_* functions =============================*/ /* SWI: int PL_raise_exception(term_t exception) YAP: NO EQUIVALENT */ /* SAM TO DO */ X_API int PL_raise_exception(term_t exception) { YAP_Throw(YAP_GetFromSlot(exception)); return 0; } /* begin PL_unify_* functions =============================*/ X_API int PL_unify(term_t t1, term_t t2) { return YAP_Unify(YAP_GetFromSlot(t1),YAP_GetFromSlot(t2)); } /* SWI: int PL_unify_atom(term_t ?t, atom *at) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_atom(term_t t, atom_t at) { YAP_Term cterm = YAP_MkAtomTerm((YAP_Atom)at); return YAP_Unify(YAP_GetFromSlot(t),cterm); } /* SWI: int PL_unify_atom_chars(term_t ?t, const char *chars) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_atom_chars(term_t t, const char *s) { YAP_Atom catom = YAP_LookupAtom((char *)s); YAP_Term cterm = YAP_MkAtomTerm(catom); return YAP_Unify(YAP_GetFromSlot(t),cterm); } /* SWI: int PL_unify_atom_chars(term_t ?t, const char *chars) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_atom_nchars(term_t t, size_t len, const char *s) { YAP_Atom catom; YAP_Term cterm; char *buf = (char *)YAP_AllocSpaceFromYap(len+1); if (!buf) return FALSE; strncpy(buf, s, len); buf[len] = '\0'; catom = YAP_LookupAtom(buf); free(buf); cterm = YAP_MkAtomTerm(catom); return YAP_Unify(YAP_GetFromSlot(t),cterm); } /* SWI: int PL_unify_float(term_t ?t, double f) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_float(term_t t, double f) { YAP_Term fterm = YAP_MkFloatTerm(f); return YAP_Unify(YAP_GetFromSlot(t),fterm); } /* SWI: int PL_unify_integer(term_t ?t, long n) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_integer(term_t t, long n) { YAP_Term iterm = YAP_MkIntTerm(n); return YAP_Unify(YAP_GetFromSlot(t),iterm); } /* SWI: int PL_unify_integer(term_t ?t, long n) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_functor(term_t t, functor_t f) { YAP_Term tt = YAP_GetFromSlot(t); if (YAP_IsVarTerm(tt)) return YAP_Unify(tt, YAP_MkNewApplTerm((YAP_Functor)f,YAP_ArityOfFunctor((YAP_Functor)f))); if (!YAP_IsApplTerm(tt)) return FALSE; return f == (functor_t)YAP_FunctorOfTerm(tt); } /* SWI: int PL_unify_integer(term_t ?t, long n) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_int64(term_t t, int64_t n) { #if USE_GMP YAP_Term iterm; char s[64]; MP_INT rop; sprintf(s, "%lld", (long long int)n); mpz_init_set_str (&rop, s, 10); iterm = YAP_MkBigNumTerm((void *)&rop); return YAP_Unify(YAP_GetFromSlot(t),iterm); #else return FALSE; #endif } /* SWI: int PL_unify_list(term_t ?t, term_t +h, term_t -t) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_list(term_t t, term_t h, term_t tail) { YAP_Term pairterm = YAP_MkPairTerm(YAP_GetFromSlot(h),YAP_GetFromSlot(tail)); return YAP_Unify(YAP_GetFromSlot(t), pairterm); } /* SWI: int PL_unify_list(term_t ?t, term_t +h, term_t -t) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_list_chars(term_t t, const char *chars) { YAP_Term chterm = YAP_BufferToString((char *)chars); return YAP_Unify(YAP_GetFromSlot(t), chterm); } /* SWI: int PL_unify_nil(term_t ?l) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_nil(term_t l) { YAP_Term nilterm = YAP_MkAtomTerm(YAP_LookupAtom("[]")); return YAP_Unify(YAP_GetFromSlot(l), nilterm); } /* SWI: int PL_unify_pointer(term_t ?t, void *ptr) YAP: NO EQUIVALENT */ /* SAM TO DO */ X_API int PL_unify_pointer(term_t t, void *ptr) { YAP_Term ptrterm = YAP_MkIntTerm((long int)ptr); return YAP_Unify(YAP_GetFromSlot(t), ptrterm); } /* SWI: int PL_unify_list(term_t ?t, term_t +h, term_t -t) YAP long int unify(YAP_Term* a, Term* b) */ X_API int PL_unify_string_chars(term_t t, const char *chars) { YAP_Term chterm = YAP_BufferToString((char *)chars); return YAP_Unify(YAP_GetFromSlot(t), chterm); } /* SWI: int PL_unify_wchars(term_t ?t, int type, size_t len,, const pl_wchar_t *s) */ X_API int PL_unify_wchars(term_t t, int type, size_t len, const pl_wchar_t *chars) { YAP_Term chterm; if (len == (size_t)-1) len = wcslen(chars); switch (type) { case PL_ATOM: chterm = YAP_MkAtomTerm(YAP_LookupWideAtom(chars)); break; case PL_STRING: case PL_CODE_LIST: chterm = YAP_NWideBufferToString(chars, len); break; case PL_CHAR_LIST: chterm = YAP_NWideBufferToAtomList(chars, len); break; default: /* should give error?? */ return FALSE; } return YAP_Unify(YAP_GetFromSlot(t), chterm); } typedef struct { int type; union { functor_t f; term_t t; atom_t a; long l; int i; double dbl; char *s; struct { size_t n; char *s; } ns; struct { size_t n; wchar_t *w; } nw; void *p; wchar_t *w; } arg; } arg_types; static YAP_Atom LookupMaxAtom(size_t n, char *s) { YAP_Atom catom; char *buf = (char *)YAP_AllocSpaceFromYap(n+1); if (!buf) return FALSE; strncpy(buf, s, n); buf[n] = '\0'; catom = YAP_LookupAtom(buf); free(buf); return catom; } static YAP_Atom LookupMaxWideAtom(size_t n, wchar_t *s) { YAP_Atom catom; wchar_t *buf = (wchar_t *)YAP_AllocSpaceFromYap((n+1)*sizeof(wchar_t)); if (!buf) return FALSE; wcsncpy(buf, s, n); buf[n] = '\0'; catom = YAP_LookupWideAtom(buf); free(buf); return catom; } static YAP_Term MkBoolTerm(int b) { if (b) return YAP_MkAtomTerm(YAP_LookupAtom("true")); else return YAP_MkAtomTerm(YAP_LookupAtom("false")); } static YAP_Term get_term(arg_types **buf) { arg_types *ptr = *buf; int type = ptr->type; YAP_Term t; switch (type) { /* now build the error string */ case PL_VARIABLE: t = YAP_MkVarTerm(); ptr++; break; case PL_BOOL: t = MkBoolTerm(ptr->arg.i); ptr++; break; case PL_ATOM: t = YAP_MkAtomTerm((YAP_Atom)ptr->arg.a); ptr++; break; case PL_CHARS: t = YAP_MkAtomTerm(YAP_LookupAtom(ptr->arg.s)); break; case PL_NCHARS: t = YAP_MkAtomTerm(LookupMaxAtom(ptr->arg.ns.n, ptr->arg.ns.s)); break; case PL_NWCHARS: t = YAP_MkAtomTerm(LookupMaxWideAtom(ptr->arg.nw.n, ptr->arg.nw.w)); break; case PL_INTEGER: t = YAP_MkIntTerm(ptr->arg.l); ptr++; break; case PL_FLOAT: t = YAP_MkFloatTerm(ptr->arg.dbl); ptr++; break; case PL_POINTER: t = YAP_MkIntTerm((long int)(ptr->arg.p)); ptr++; break; case PL_STRING: t = YAP_BufferToString(ptr->arg.s); ptr++; break; case PL_TERM: t = YAP_GetFromSlot(ptr->arg.t); ptr++; break; case PL_FUNCTOR: { functor_t f = ptr->arg.f; long int arity, i; term_t loc; if (YAP_IsAtomTerm((YAP_Term)f)) { t = (YAP_Term)f; break; } arity = YAP_ArityOfFunctor((YAP_Functor)f); loc = YAP_NewSlots(arity); ptr++; for (i= 0; i < arity; i++) { YAP_PutInSlot(loc+i,get_term(&ptr)); } t = YAP_MkApplTerm((YAP_Functor)f,arity,YAP_AddressFromSlot(loc)); } break; case PL_LIST: { term_t loc; loc = YAP_NewSlots(2); ptr++; YAP_PutInSlot(loc,get_term(&ptr)); YAP_PutInSlot(loc+1,get_term(&ptr)); t = YAP_MkPairTerm(YAP_GetFromSlot(loc),YAP_GetFromSlot(loc+1)); } break; default: fprintf(stderr, "type %d not implemented yet\n", type); exit(1); } *buf = ptr; return t; } /* SWI: int PL_unify_term(term_t ?t1, term_t ?t2) YAP long int YAP_Unify(YAP_Term* a, Term* b) */ X_API int PL_unify_term(term_t l,...) { va_list ap; int type; int nels = 1; arg_types *ptr = (arg_types *)buffers; va_start (ap, l); while (nels > 0) { type = va_arg(ap, int); nels --; ptr->type = type; switch(type) { case PL_VARIABLE: break; case PL_BOOL: ptr->arg.i = va_arg(ap, int); break; case PL_ATOM: ptr->arg.a = va_arg(ap, atom_t); break; case PL_INTEGER: ptr->arg.l = va_arg(ap, long); break; case PL_FLOAT: ptr->arg.dbl = va_arg(ap, double); break; case PL_STRING: ptr->arg.s = va_arg(ap, char *); break; case PL_TERM: ptr->arg.t = va_arg(ap, term_t); break; case PL_POINTER: ptr->arg.p = va_arg(ap, void *); break; case PL_CHARS: ptr->arg.s = va_arg(ap, char *); break; case PL_NCHARS: ptr->arg.ns.n = va_arg(ap, size_t); ptr->arg.ns.s = va_arg(ap, char *); break; case PL_NWCHARS: ptr->arg.nw.n = va_arg(ap, size_t); ptr->arg.nw.w = va_arg(ap, wchar_t *); break; case PL_FUNCTOR: { functor_t f = va_arg(ap, functor_t); ptr->arg.f = f; if (!YAP_IsAtomTerm((YAP_Term)f)) { nels += YAP_ArityOfFunctor((YAP_Functor)f); } } break; case PL_LIST: nels += 2; break; default: fprintf(stderr, "%d not supported\n", type); exit(1); } ptr++; } va_end (ap); ptr = (arg_types *)buffers; return YAP_Unify(YAP_GetFromSlot(l),get_term(&ptr)); } /* end PL_unify_* functions =============================*/ /* SWI: void PL_register_atom(atom_t atom) */ /* SAM TO DO */ X_API void PL_register_atom(atom_t atom) { extern int Yap_AtomGetHold(atom_t atom); Yap_AtomGetHold(atom); } /* SWI: void PL_unregister_atom(atom_t atom) */ /* SAM TO DO */ X_API void PL_unregister_atom(atom_t atom) { extern int Yap_AtomReleaseHold(atom_t atom); Yap_AtomReleaseHold(atom); } X_API int PL_get_string_chars(term_t t, char **s, int *len) { /* there are no such objects in Prolog */ return FALSE; } X_API int PL_term_type(term_t t) { /* YAP_ does not support strings as different objects */ YAP_Term v = YAP_GetFromSlot(t); if (YAP_IsVarTerm(v)) { return PL_VARIABLE; } else if (YAP_IsAtomTerm(v)) { return PL_ATOM; } else if (YAP_IsIntTerm(v)) { return PL_INTEGER; } else if (YAP_IsFloatTerm(v)) { return PL_FLOAT; } else { return PL_TERM; } } X_API int PL_is_atom(term_t t) { return YAP_IsAtomTerm(YAP_GetFromSlot(t)); } X_API int PL_is_atomic(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); return !YAP_IsVarTerm(t) || !YAP_IsApplTerm(t) || !YAP_IsPairTerm(t); } X_API int PL_is_compound(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); return (YAP_IsApplTerm(t) || YAP_IsPairTerm(t)); } X_API int PL_is_functor(term_t ts, functor_t f) { YAP_Term t = YAP_GetFromSlot(ts); if (YAP_IsApplTerm(t)) { return YAP_FunctorOfTerm(t) == (YAP_Functor)f; } else if (YAP_IsPairTerm(t)) { return YAP_FunctorOfTerm(t) == YAP_MkFunctor(YAP_LookupAtom("."),2); } else return 0; } X_API int PL_is_float(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); return YAP_IsFloatTerm(t); } X_API int PL_is_integer(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); return YAP_IsIntTerm(t); } X_API int PL_is_list(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); if (YAP_IsPairTerm(t)) { return 1; } else if (YAP_IsAtomTerm(t)) { return t == YAP_MkAtomTerm(YAP_LookupAtom("[]")); } else return 0; } X_API int PL_is_number(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); return YAP_IsIntTerm(t) || YAP_IsFloatTerm(t); } X_API int PL_is_string(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); while (YAP_IsPairTerm(t)) { YAP_Term hd = YAP_HeadOfTerm(t); long int i; if (!YAP_IsIntTerm(hd)) return 0; i = YAP_IntOfTerm(hd); if (i <= 0 || i >= 255) return 0; if (!YAP_IsIntTerm(hd)) return 0; t = YAP_TailOfTerm(t); } if (t != YAP_MkAtomTerm(YAP_LookupAtom("[]"))) return 0; return FALSE; } X_API int PL_is_variable(term_t ts) { YAP_Term t = YAP_GetFromSlot(ts); return YAP_IsVarTerm(t); } X_API int PL_compare(term_t ts1, term_t ts2) { YAP_Term t1 = YAP_GetFromSlot(ts1); YAP_Term t2 = YAP_GetFromSlot(ts2); return YAP_CompareTerms(t1, t2); } X_API void PL_halt(int e) { YAP_Halt(e); } X_API int PL_action(int action,...) { va_list ap; va_start (ap, action); switch (action) { case PL_ACTION_TRACE: fprintf(stderr, "PL_ACTION_TRACE not supported\n"); break; case PL_ACTION_DEBUG: fprintf(stderr, "PL_ACTION_DEBUG not supported\n"); break; case PL_ACTION_BACKTRACE: fprintf(stderr, "PL_ACTION_BACKTRACE not supported\n"); break; case PL_ACTION_HALT: { int halt_arg = va_arg(ap, int); YAP_Halt(halt_arg); } break; case PL_ACTION_ABORT: { YAP_Throw(YAP_MkAtomTerm(YAP_LookupAtom("abort"))); } break; case PL_ACTION_BREAK: fprintf(stderr, "PL_ACTION_BREAK not supported\n"); break; case PL_ACTION_GUIAPP: fprintf(stderr, "PL_ACTION_GUIAPP not supported\n"); break; case PL_ACTION_WRITE: fprintf(stderr, "PL_ACTION_WRITE not supported\n"); break; case PL_ACTION_FLUSH: fprintf(stderr, "PL_ACTION_WRITE not supported\n"); break; case PL_ACTION_ATTACH_CONSOLE: fprintf(stderr, "PL_ACTION_WRITE not supported\n"); break; } va_end (ap); return 0; } X_API fid_t PL_open_foreign_frame(void) { return 0; } X_API void PL_close_foreign_frame(fid_t f) { } X_API void PL_discard_foreign_frame(fid_t f) { fprintf(stderr,"WARNING: PL_discard_foreign_frame not fully implemented!!"); /* Missing: undo Trail!! */ } X_API term_t PL_exception(qid_t q) { YAP_Term t; if (YAP_GoalHasException(&t)) { term_t to = YAP_NewSlots(1); YAP_PutInSlot(to,t); return to; } else { return 0L; } } X_API int PL_initialise(int myargc, char **myargv) { YAP_init_args init_args; init_args.Argv = myargv; init_args.Argc = myargc; init_args.SavedState = "startup"; init_args.HeapSize = 0; init_args.StackSize = 0; init_args.TrailSize = 0; init_args.YapLibDir = NULL; init_args.YapPrologBootFile = NULL; init_args.HaltAfterConsult = FALSE; init_args.FastBoot = FALSE; init_args.NumberWorkers = 1; init_args.SchedulerLoop = 10; init_args.DelayedReleaseLoad = 3; return YAP_Init(&init_args); } X_API int PL_is_initialised(int *argc, char ***argv) { return TRUE; } X_API module_t PL_context(void) { return (module_t)YAP_CurrentModule(); } X_API int PL_strip_module(term_t raw, module_t *m, term_t plain) { YAP_Term t = YAP_StripModule(YAP_GetFromSlot(raw),(YAP_Term *)m); if (!t) return FALSE; YAP_PutInSlot(plain, t); return TRUE; } X_API atom_t PL_module_name(module_t m) { YAP_Atom at = YAP_AtomOfTerm((YAP_Term)m); YAP_CreateModule(at); return (atom_t)at; } X_API predicate_t PL_pred(functor_t f, module_t m) { if (YAP_IsAtomTerm(f)) { return YAP_Predicate(YAP_AtomOfTerm(f),0,(YAP_Module)m); } else { YAP_Functor tf = (YAP_Functor)f; return YAP_Predicate(YAP_NameOfFunctor(tf),YAP_ArityOfFunctor(tf),(YAP_Module)m); } } X_API predicate_t PL_predicate(const char *name, int arity, const char *m) { int mod; if (m == NULL) mod = YAP_CurrentModule(); else mod = YAP_LookupModule(YAP_MkAtomTerm(YAP_LookupAtom((char *)m))); return YAP_Predicate(YAP_LookupAtom((char *)name), arity, mod); } X_API void PL_predicate_info(predicate_t p,atom_t *name, int *arity, module_t *m) { YAP_PredicateInfo(p, (YAP_Atom *)name, (unsigned long int *)arity, (YAP_Module *)m); } typedef struct open_query_struct { int open; int state; YAP_Term g; } open_query; open_query execution; X_API qid_t PL_open_query(module_t ctx, int flags, predicate_t p, term_t t0) { YAP_Atom yname; atom_t name; unsigned long int arity; YAP_Module m; YAP_Term t[2]; /* ignore flags and module for now */ if (execution.open != 0) { YAP_Error(0, 0L, "only one query at a time allowed\n"); } execution.open=1; execution.state=0; YAP_PredicateInfo(p, &yname, &arity, &m); name = (atom_t)yname; t[0] = YAP_ModuleName(m); if (arity == 0) { t[1] = YAP_MkAtomTerm((YAP_Atom)name); } else { YAP_Functor f = YAP_MkFunctor((YAP_Atom)name, arity); t[1] = YAP_MkApplTerm(f,arity,YAP_AddressFromSlot(t0)); } execution.g = YAP_MkApplTerm(YAP_MkFunctor(YAP_LookupAtom(":"),2),2,t); return &execution; } X_API int PL_next_solution(qid_t qi) { int result; if (qi->open != 1) return 0; if (qi->state == 0) { result = YAP_RunGoal(qi->g); } else { result = YAP_RestartGoal(); } qi->state = 1; if (result == 0) { qi->open = 0; } return result; } X_API void PL_cut_query(qid_t qi) { YAP_PruneGoal(); qi->open = 0; } X_API void PL_close_query(qid_t qi) { /* need to implement backtracking here */ if (qi->open != 1) return; YAP_PruneGoal(); YAP_RestartGoal(); qi->open = 0; } X_API int PL_call_predicate(module_t ctx, int flags, predicate_t p, term_t t0) { qid_t qi = PL_open_query(ctx, flags, p, t0); int ret = PL_next_solution(qi); PL_cut_query(qi); return ret; } X_API int PL_call(term_t tp, module_t m) { YAP_Term t[2], g; t[0] = YAP_ModuleName((YAP_Module)m); t[1] = YAP_GetFromSlot(tp); g = YAP_MkApplTerm(YAP_MkFunctor(YAP_LookupAtom(":"),2),2,t); return YAP_RunGoal(g); } X_API void PL_register_extensions(PL_extension *ptr) { while(ptr->predicate_name != NULL) { if (ptr->flags & (PL_FA_NOTRACE|PL_FA_NONDETERMINISTIC|PL_FA_VARARGS|PL_FA_CREF)) { YAP_Error(0,YAP_MkIntTerm(ptr->flags),"non-implemented flag %x when creating predicates", ptr->flags); return; } if (ptr->flags & PL_FA_TRANSPARENT) YAP_UserCPredicateWithArgs(ptr->predicate_name,(YAP_Bool (*)(void))ptr->function,ptr->arity,YAP_MkAtomTerm(YAP_LookupAtom("prolog"))); else YAP_UserCPredicateWithArgs(ptr->predicate_name,(YAP_Bool (*)(void))ptr->function,ptr->arity,YAP_CurrentModule()); ptr++; } } X_API void PL_register_foreign_in_module(const char *module, const char *name, int arity, foreign_t (*function)(void), int flags) { if (flags & (PL_FA_NOTRACE|PL_FA_NONDETERMINISTIC|PL_FA_VARARGS|PL_FA_CREF)) { YAP_Error(0,YAP_MkIntTerm(flags),"non-implemented flag %x when creating predicates", flags); return; } if (flags & PL_FA_TRANSPARENT) YAP_UserCPredicateWithArgs(name,(YAP_Bool (*)(void))function,arity,YAP_MkAtomTerm(YAP_LookupAtom("prolog"))); else if (module == NULL) YAP_UserCPredicateWithArgs(name,(YAP_Bool (*)(void))function,arity,YAP_CurrentModule()); else YAP_UserCPredicateWithArgs(name,(YAP_Bool (*)(void))function,arity,YAP_MkAtomTerm(YAP_LookupAtom(module))); } X_API void PL_load_extensions(PL_extension *ptr) { /* ignore flags for now */ while(ptr->predicate_name != NULL) { YAP_UserCPredicateWithArgs(ptr->predicate_name,(YAP_Bool (*)(void))ptr->function,ptr->arity,YAP_CurrentModule()); ptr++; } } X_API int PL_handle_signals(void) { fprintf(stderr,"not implemented\n"); return 0; } X_API int PL_thread_self(void) { return YAP_ThreadSelf(); } X_API int PL_thread_attach_engine(const PL_thread_attr_t *attr) { int wid = YAP_ThreadSelf(); if (wid < 0) { /* we do not have an engine */ if (attr) { YAP_thread_attr yapt; int wid; yapt.ssize = attr->local_size; yapt.tsize = attr->global_size; yapt.alias = (YAP_Term)attr->alias; yapt.cancel = attr->cancel; wid = YAP_ThreadCreateEngine(&yapt); } else { wid = YAP_ThreadCreateEngine(NULL); } if (wid < 0) return -1; if (YAP_ThreadAttachEngine(wid)) { return wid; } return -1; } else { /* attach myself again */ YAP_ThreadAttachEngine(wid); return wid; } } X_API int PL_thread_destroy_engine(void) { int wid = YAP_ThreadSelf(); if (wid < 0) { /* we do not have an engine */ return FALSE; } YAP_ThreadDetachEngine(wid); return YAP_ThreadDestroyEngine(wid); } X_API int PL_thread_at_exit(void (*function)(void *), void *closure, int global) { /* don't do nothing for now */ fprintf(stderr,"%% YAP ERROR: PL_thread_at_exit not implemented yet\n"); return TRUE; } X_API PL_engine_t PL_create_engine(const PL_thread_attr_t *attr) { if (attr) { YAP_thread_attr yapt; yapt.ssize = attr->local_size; yapt.tsize = attr->global_size; yapt.alias = (YAP_Term)attr->alias; yapt.cancel = attr->cancel; return (PL_engine_t)YAP_ThreadCreateEngine(&yapt); } else { return (PL_engine_t)YAP_ThreadCreateEngine(NULL); } } X_API int PL_destroy_engine(PL_engine_t e) { return YAP_ThreadDestroyEngine((YAP_Int)e); } X_API int PL_set_engine(PL_engine_t engine, PL_engine_t *old) { long int cwid = YAP_ThreadSelf(); if (*old) *old = (PL_engine_t)cwid; if (engine == PL_ENGINE_CURRENT) return PL_ENGINE_SET; if (engine < 0) /* should really check if engine does not exist */ return PL_ENGINE_INVAL; if (!(YAP_ThreadAttachEngine((long int)engine))) { return PL_ENGINE_INUSE; } return PL_ENGINE_SET; } X_API void * PL_malloc(int sz) { return YAP_AllocSpaceFromYap(sz); } X_API void PL_free(void *obj) { return YAP_FreeSpaceFromYap(obj); } /* note: fprintf may be called from anywhere, so please don't try to be smart and allocate stack from somewhere else */ X_API int Sprintf(char *format,...) { va_list ap; char buf[512]; va_start(ap,format); #ifdef HAVE_VSNPRINTF vsnprintf(buf,512,format,ap); #else vsprintf(buf,format,ap); #endif va_end(ap); fputs(buf, stderr); return 1; } /* note: fprintf may be called from anywhere, so please don't try to be smart and allocate stack from somewhere else */ X_API int Sdprintf(char *format,...) { va_list ap; char buf[512]; va_start(ap,format); #ifdef HAVE_VSNPRINTF vsnprintf(buf,512,format,ap); #else vsprintf(buf,format,ap); #endif va_end(ap); #if DEBUG fputs(buf, stderr); #endif return 1; } static int SWI_ctime(void) { #if HAVE_CTIME time_t tim; #endif YAP_Term t1 = YAP_ARG1; if (YAP_IsVarTerm(t1)) { YAP_Error(0,t1,"bad argumento to ctime"); return FALSE; } #if HAVE_CTIME tim = (time_t)YAP_IntOfTerm(t1); return YAP_Unify(YAP_BufferToString(ctime(&tim)), YAP_ARG2); #else YAP_Error(0,0L,"convert_time requires ctime"); return FALSE; #endif } /***** SWI IO ***************/ #include #define char_to_int(c) (0xff & (int)(c)) struct { struct { IOSTREAM *streams[6]; } IO; } lds; #define LD (&lds) #define ARG_LD #define GET_LD #define PASS_LD #define LOCK() #define UNLOCK() #define FUNCTOR_dstream1 (functor_t)YAP_MkFunctor(YAP_LookupAtom("stream"),1) #define succeed return 1 #define fail return 0 static int S__removebuf(IOSTREAM *s); static int S__flushbuf(IOSTREAM *s); #ifndef MB_LEN_MAX #define MB_LEN_MAX 6 #endif #ifndef UTF8_H_INCLUDED #define UTF8_H_INCLUDED #define UTF8_MALFORMED_REPLACEMENT 0xfffd #define ISUTF8_MB(c) ((unsigned)(c) >= 0xc0 && (unsigned)(c) <= 0xfd) #define ISUTF8_CB(c) (((c)&0xc0) == 0x80) /* Is continuation byte */ #define ISUTF8_FB2(c) (((c)&0xe0) == 0xc0) #define ISUTF8_FB3(c) (((c)&0xf0) == 0xe0) #define ISUTF8_FB4(c) (((c)&0xf8) == 0xf0) #define ISUTF8_FB5(c) (((c)&0xfc) == 0xf8) #define ISUTF8_FB6(c) (((c)&0xfe) == 0xfc) #define UTF8_FBN(c) (!(c&0x80) ? 0 : \ ISUTF8_FB2(c) ? 1 : \ ISUTF8_FB3(c) ? 2 : \ ISUTF8_FB4(c) ? 3 : \ ISUTF8_FB5(c) ? 4 : \ ISUTF8_FB6(c) ? 5 : -1) #define UTF8_FBV(c,n) ( n == 0 ? c : (c & ((0x01<<(6-n))-1)) ) #define utf8_get_char(in, chr) \ (*(in) & 0x80 ? _PL__utf8_get_char(in, chr) \ : (*(chr) = *(in), (char *)(in)+1)) #define utf8_put_char(out, chr) \ ((chr) < 0x80 ? out[0]=(char)(chr), out+1 \ : _PL__utf8_put_char(out, (chr))) extern char *_PL__utf8_get_char(const char *in, int *chr); extern char *_PL__utf8_put_char(char *out, int chr); extern unsigned int utf8_strlen(const char *s, unsigned int len); #endif /*UTF8_H_INCLUDED*/ typedef struct symbol * Symbol; /* symbol of hash table */ struct symbol { Symbol next; /* next in chain */ void * name; /* name entry of symbol */ void * value; /* associated value with name */ }; static Symbol *streamContext; static Symbol *streamAliases; #define NULL_ATOM 0L #define allocHeap(size) YAP_AllocSpaceFromYap(size) // FIX THIS #define PL_error(A,B,C,D,E,F) 0 static Symbol lookupHTable(Symbol *htp, void *name) { Symbol ht = *htp; while (ht) { if (ht->name == name) return ht; } return NULL; } static void addHTable(Symbol *htp, void *name, void *val) { Symbol s = (Symbol)allocHeap(sizeof(Symbol)); if (!s) return; s->next = *htp; s->name = name; s->value = val; *htp = s; } typedef struct _alias { struct _alias *next; atom_t name; } alias; typedef struct { alias *alias_head; alias *alias_tail; atom_t filename; /* associated filename */ unsigned flags; } stream_context; static stream_context * getStreamContext(IOSTREAM *s) { Symbol symb; if ( !(symb = lookupHTable(streamContext, s)) ) { GET_LD stream_context *ctx = allocHeap(sizeof(*ctx)); // DEBUG(1, Sdprintf("Created ctx=%p for stream %p\n", ctx, s)); ctx->alias_head = ctx->alias_tail = NULL; ctx->filename = NULL_ATOM; ctx->flags = 0; addHTable(streamContext, s, ctx); return ctx; } return symb->value; } char * _PL__utf8_put_char(char *out, int chr) { if ( chr < 0x80 ) { *out++ = chr; } else if ( chr < 0x800 ) { *out++ = 0xc0|((chr>>6)&0x1f); *out++ = 0x80|(chr&0x3f); } else if ( chr < 0x10000 ) { *out++ = 0xe0|((chr>>12)&0x0f); *out++ = 0x80|((chr>>6)&0x3f); *out++ = 0x80|(chr&0x3f); } else if ( chr < 0x200000 ) { *out++ = 0xf0|((chr>>18)&0x07); *out++ = 0x80|((chr>>12)&0x3f); *out++ = 0x80|((chr>>6)&0x3f); *out++ = 0x80|(chr&0x3f); } else if ( chr < 0x4000000 ) { *out++ = 0xf8|((chr>>24)&0x03); *out++ = 0x80|((chr>>18)&0x3f); *out++ = 0x80|((chr>>12)&0x3f); *out++ = 0x80|((chr>>6)&0x3f); *out++ = 0x80|(chr&0x3f); } else if ( chr < 0x80000000 ) { *out++ = 0xfc|((chr>>30)&0x01); *out++ = 0x80|((chr>>24)&0x3f); *out++ = 0x80|((chr>>18)&0x3f); *out++ = 0x80|((chr>>12)&0x3f); *out++ = 0x80|((chr>>6)&0x3f); *out++ = 0x80|(chr&0x3f); } return out; } static inline void update_linepos(IOSTREAM *s, int c) { IOPOS *p = s->position; switch(c) { case '\n': p->lineno++; p->linepos = 0; s->flags &= ~SIO_NOLINEPOS; #ifdef __WIN32__ if ( s->flags & O_TEXT ) p->charno++; /* writes one extra! */ #endif break; case '\r': p->linepos = 0; s->flags &= ~SIO_NOLINEPOS; break; case '\b': if ( p->linepos > 0 ) p->linepos--; break; case EOF: break; case '\t': p->linepos |= 7; default: p->linepos++; } } /******************************* * BUFFER * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Note that the buffer is allocated from s->unbuffer, which starts MB_LEN_MAX before s->buffer, so we can always push-back a wide character into a multibyte stream. We do not do this for SIO_USERBUF case, but this is only used by the output stream Svfprintf() where it is not needed. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static int S__setbuf(IOSTREAM *s, char *buffer, int size) { if ( size == 0 ) size = SIO_BUFSIZE; S__removebuf(s); s->bufsize = size; if ( buffer ) { s->unbuffer = s->buffer = buffer; s->flags |= SIO_USERBUF; } else { if ( !(s->unbuffer = malloc(s->bufsize+MB_LEN_MAX)) ) { errno = ENOMEM; return -1; } s->flags &= ~SIO_USERBUF; s->buffer = s->unbuffer + MB_LEN_MAX; } s->limitp = &s->buffer[s->bufsize]; s->bufp = s->buffer; return size; } static int S__removebuf(IOSTREAM *s) { if ( s->buffer && s->unbuffer ) { int rval = 0; if ( (s->flags & SIO_OUTPUT) && S__flushbuf(s) < 0 ) rval = -1; if ( !(s->flags & SIO_USERBUF) ) free(s->unbuffer); s->bufp = s->limitp = s->buffer = s->unbuffer = NULL; s->bufsize = 0; return rval; } return 0; } #ifdef DEBUG_IO_LOCKS static char * Sname(IOSTREAM *s) { if ( s == Serror ) return "error"; if ( s == Sinput ) return "input"; if ( s == Soutput ) return "output"; return "?"; } #endif /******************************* * FLUSH/FILL * *******************************/ static int S__flushbuf(IOSTREAM *s) { int size; char *from = s->buffer; while ( (size = s->bufp - from) > 0 ) { int n = (*s->functions->write)(s->handle, from, size); if ( n > 0 ) /* wrote some */ { from += n; } else if ( n < 0 ) /* error */ { s->flags |= SIO_FERR; return -1; } else /* wrote nothing? */ { break; } } if ( s->bufp - from == 0 ) /* full flush */ { int rc = s->bufp - s->buffer; s->bufp = s->buffer; return rc; } else /* partial flush */ { int rc = from - s->buffer; int left = s->bufp - from; memmove(s->buffer, from, left); s->bufp = s->buffer + left; return rc; } } static inline int S__updatefilepos(IOSTREAM *s, int c) { IOPOS *p = s->position; if ( p ) { update_linepos(s, c); p->charno++; } return c; } int Sfileno(IOSTREAM *s) { int n; if ( s->flags & SIO_FILE ) { long h = (long)s->handle; n = (int)h; } else if ( s->flags & SIO_PIPE ) { n = fileno((FILE *)s->handle); } else if ( s->functions->control && (*s->functions->control)(s->handle, SIO_GETFILENO, (void *)&n) == 0 ) { ; } else { errno = EINVAL; n = -1; /* no file stream */ } return n; } IOSTREAM * Snew(void *handle, int flags, IOFUNCTIONS *functions) { IOSTREAM *s; int fd; if ( !(s = malloc(sizeof(IOSTREAM))) ) { errno = ENOMEM; return NULL; } memset((char *)s, 0, sizeof(IOSTREAM)); s->magic = SIO_MAGIC; s->lastc = EOF; s->flags = flags; s->handle = handle; s->functions = functions; s->timeout = -1; /* infinite */ s->posbuf.lineno = 1; s->encoding = ENC_ISO_LATIN_1; if ( flags & SIO_RECORDPOS ) s->position = &s->posbuf; #ifdef O_PLMT if ( !(flags & SIO_NOMUTEX) ) { if ( !(s->mutex = malloc(sizeof(recursiveMutex))) ) { free(s); return NULL; } recursiveMutexInit(s->mutex); } #endif if ( (fd = Sfileno(s)) >= 0 && isatty(fd) ) s->flags |= SIO_ISATTY; return s; } X_API int PL_unify_stream(term_t t, IOSTREAM *s) { GET_LD stream_context *ctx; term_t a = PL_new_term_ref(); LOCK(); ctx = getStreamContext(s); UNLOCK(); PL_put_pointer(a, s); PL_cons_functor(a, FUNCTOR_dstream1, a); if ( PL_unify(t, a) ) succeed; if ( PL_is_functor(t, FUNCTOR_dstream1) ) fail; return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_stream, t); } int /* old FLI name (compatibility) */ PL_open_stream(term_t handle, IOSTREAM *s) { return PL_unify_stream(handle, s); } #define SH_ERRORS 0x01 /* generate errors */ #define SH_ALIAS 0x02 /* allow alias */ #define SH_UNLOCKED 0x04 /* don't lock the stream */ #define SH_SAFE 0x08 /* Lookup in table */ #define _PL_get_arg PL_get_arg #define getStream(s) (s) static int get_stream_handle__LD(term_t t, IOSTREAM **s, int flags ARG_LD) { atom_t alias; if ( PL_is_functor(t, FUNCTOR_dstream1) ) { void *p; term_t a = PL_new_term_ref(); _PL_get_arg(1, t, a); if ( PL_get_pointer(a, &p) ) { if ( flags & SH_SAFE ) { Symbol symb; LOCK(); symb = lookupHTable(streamContext, p); UNLOCK(); if ( !symb ) goto noent; } if ( flags & SH_UNLOCKED ) { if ( ((IOSTREAM *)p)->magic == SIO_MAGIC ) { *s = p; return TRUE; } goto noent; } if ( (*s = getStream(p)) ) return TRUE; goto noent; } } else if ( PL_get_atom(t, &alias) ) { Symbol symb; if ( !(flags & SH_UNLOCKED) ) LOCK(); if ( (symb=lookupHTable(streamAliases, (void *)alias)) ) { IOSTREAM *stream; unsigned long n = (unsigned long)symb->value; if ( n < 6 ) /* standard stream! */ { stream = LD->IO.streams[n]; } else stream = symb->value; if ( !(flags & SH_UNLOCKED) ) UNLOCK(); if ( stream ) { if ( (flags & SH_UNLOCKED) ) { if ( stream->magic == SIO_MAGIC ) { *s = stream; return TRUE; } } else if ( (*s = getStream(stream)) ) return TRUE; goto noent; } } if ( !(flags & SH_UNLOCKED) ) UNLOCK(); goto noent; } if ( flags & SH_ERRORS ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, (flags&SH_ALIAS) ? ATOM_stream_or_alias : ATOM_stream, t); fail; noent: if ( flags & SH_ERRORS ) PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_stream, t); fail; } #define get_stream_handle(t, sp, flags) \ get_stream_handle__LD(t, sp, flags PASS_LD) int PL_get_stream_handle(term_t t, IOSTREAM **s) { GET_LD return get_stream_handle(t, s, SH_ERRORS|SH_ALIAS); } static inline int get_byte(IOSTREAM *s) { int c = Snpgetc(s); if ( s->position ) s->position->byteno++; return c; } int Sgetcode(IOSTREAM *s) { int c; #ifdef CRLF_MAPPING retry: #endif switch(s->encoding) { case ENC_OCTET: case ENC_ISO_LATIN_1: c = get_byte(s); break; case ENC_ASCII: { c = get_byte(s); if ( c > 128 ) Sseterr(s, SIO_WARN, "non-ASCII character"); break; } case ENC_ANSI: { char b[1]; int rc, n = 0; wchar_t wc; if ( !s->mbstate ) { if ( !(s->mbstate = malloc(sizeof(*s->mbstate))) ) return EOF; /* out of memory */ memset(s->mbstate, 0, sizeof(*s->mbstate)); } for(;;) { if ( (c = get_byte(s)) == EOF ) { if ( n == 0 ) return EOF; else { Sseterr(s, SIO_WARN, "EOF in multibyte Sequence"); goto mberr; } } b[0] = c; if ( (rc=mbrtowc(&wc, b, 1, s->mbstate)) == 1 ) { c = wc; goto out; } else if ( rc == -1 ) { Sseterr(s, SIO_WARN, "Illegal multibyte Sequence"); goto mberr; } /* else -2: incomplete */ } mberr: c = UTF8_MALFORMED_REPLACEMENT; goto out; } case ENC_UTF8: { c = get_byte(s); if ( c == EOF ) break; if ( c & 0x80 ) { int extra = UTF8_FBN(c); int code; code = UTF8_FBV(c,extra); for( ; extra > 0; extra-- ) { int c2 = get_byte(s); if ( !ISUTF8_CB(c2) ) { Sseterr(s, SIO_WARN, "Illegal UTF-8 Sequence"); c = UTF8_MALFORMED_REPLACEMENT; Sungetc(c2, s); goto out; } code = (code<<6)+(c2&0x3f); } c = code; } break; } case ENC_UNICODE_BE: case ENC_UNICODE_LE: { int c1, c2; c1 = get_byte(s); if ( c1 == EOF ) return EOF; c2 = get_byte(s); if ( c2 == EOF ) { Sseterr(s, SIO_WARN, "EOF in unicode character"); c = UTF8_MALFORMED_REPLACEMENT; } else { if ( s->encoding == ENC_UNICODE_BE ) c = (c1<<8)+c2; else c = (c2<<8)+c1; } break; } case ENC_WCHAR: { pl_wchar_t chr; char *p = (char*)&chr; int n; for(n=0; nflags&SIO_TEXT) ) goto retry; #endif if ( s->tee && s->tee->magic == SIO_MAGIC && c != -1 ) Sputcode(c, s->tee); return S__updatefilepos(s, c); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - S__fillbuf() fills the read-buffer, returning the first character of it. It also realises the SWI-Prolog timeout facility. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ int S__fillbuf(IOSTREAM *s) { int c; if ( s->flags & (SIO_FEOF|SIO_FERR) ) { s->flags |= SIO_FEOF2; /* reading past eof */ goto error; } #ifdef HAVE_SELECT s->flags &= ~SIO_TIMEOUT; if ( s->timeout >= 0 ) { int fd = Sfileno(s); 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 WIN32 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; goto error; } continue; } break; } if ( rc == 0 ) { s->flags |= (SIO_TIMEOUT|SIO_FERR); goto error; } } else { errno = EPERM; /* no permission to select */ s->flags |= SIO_FERR; goto error; } } #endif if ( s->flags & SIO_NBUF ) { char chr; int n; if ( (n=(*s->functions->read)(s->handle, &chr, 1)) == 1 ) { c = char_to_int(chr); goto ok; } else if ( n == 0 ) { if ( !(s->flags & SIO_NOFEOF) ) s->flags |= SIO_FEOF; goto error; } else { s->flags |= SIO_FERR; goto error; /* error */ } } else { int n, len; if ( !s->buffer ) { if ( S__setbuf(s, NULL, 0) < 0 ) goto error; s->bufp = s->limitp = s->buffer; len = s->bufsize; } else if ( s->bufp < s->limitp ) { len = s->limitp - s->bufp; memmove(s->buffer, s->bufp, s->limitp - s->bufp); s->bufp = s->buffer; s->limitp = &s->bufp[len]; len = s->bufsize - len; } else { s->bufp = s->limitp = s->buffer; len = s->bufsize; } if ( (n=(*s->functions->read)(s->handle, s->limitp, len)) > 0 ) { s->limitp += n; c = char_to_int(*s->bufp++); goto ok; } else { if ( n == 0 ) { if ( !(s->flags & SIO_NOFEOF) ) s->flags |= SIO_FEOF; goto error; #ifdef EWOULDBLOCK } else if ( errno == EWOULDBLOCK ) { s->bufp = s->buffer; s->limitp = s->buffer; goto error; #endif } else { s->flags |= SIO_FERR; goto error; } } } error: c = -1; ok: return c; } static int S__flushbufc(int c, IOSTREAM *s) { if ( s->buffer ) { if ( S__flushbuf(s) <= 0 ) /* == 0: no progress!? */ c = -1; else *s->bufp++ = (c & 0xff); } else { if ( s->flags & SIO_NBUF ) { char chr = (char)c; if ( (*s->functions->write)(s->handle, &chr, 1) != 1 ) { s->flags |= SIO_FERR; c = -1; } } else { if ( S__setbuf(s, NULL, 0) < 0 ) { s->flags |= SIO_FERR; c = -1; } else *s->bufp++ = (char)c; } } return c; } static inline void unget_byte(int c, IOSTREAM *s) { IOPOS *p = s->position; *--s->bufp = c; if ( p ) { p->charno--; p->byteno--; s->flags |= (SIO_NOLINENO|SIO_NOLINEPOS); } } int Sungetc(int c, IOSTREAM *s) { if ( s->bufp > s->unbuffer ) { unget_byte(c, s); return c; } return -1; } static int put_byte(int c, IOSTREAM *s) { c &= 0xff; if ( s->bufp < s->limitp ) { *s->bufp++ = c; } else { if ( S__flushbufc(c, s) < 0 ) { s->lastc = EOF; return -1; } } if ( s->position ) s->position->byteno++; return c; } static int reperror(int c, IOSTREAM *s) { if ( c >= 0 && (s->flags & (SIO_REPXML|SIO_REPPL)) ) { char buf[16]; const char *q; if ( (s->flags & SIO_REPPL) ) { if ( c <= 0xffff ) sprintf(buf, "\\u%04X", c); else sprintf(buf, "\\U%08X", c); } else sprintf(buf, "&#%d;", c); for(q = buf; *q; q++) { if ( put_byte(*q, s) < 0 ) return -1; } return c; } Sseterr(s, SIO_FERR|SIO_CLEARERR, "Encoding cannot represent character"); return -1; } int Sputcode(int c, IOSTREAM *s) { if ( c < 0 ) return reperror(c, s); if ( s->tee && s->tee->magic == SIO_MAGIC ) Sputcode(c, s->tee); #ifdef CRLF_MAPPING if ( c == '\n' && (s->flags&SIO_TEXT) ) { if ( Sputcode('\r', s) < 0 ) return -1; } #endif switch(s->encoding) { case ENC_OCTET: case ENC_ISO_LATIN_1: if ( c >= 256 ) { if ( reperror(c, s) < 0 ) return -1; break; } simple: if ( put_byte(c, s) < 0 ) return -1; break; case ENC_ASCII: if ( c >= 128 ) { if ( reperror(c, s) < 0 ) return -1; break; } goto simple; case ENC_ANSI: { char b[MB_LEN_MAX]; int n; if ( !s->mbstate ) { 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)) < 0 ) { if ( reperror(c, s) < 0 ) return -1; } else { int i; for(i=0; i>8, s) < 0 ) return -1; if ( put_byte(c&0xff, s) < 0 ) return -1; break; case ENC_UNICODE_LE: if ( put_byte(c&0xff, s) < 0 ) return -1; if ( put_byte(c>>8, s) < 0 ) return -1; break; case ENC_WCHAR: { pl_wchar_t chr = c; unsigned char *q = (unsigned char *)&chr; unsigned char *e = &q[sizeof(pl_wchar_t)]; while(qlastc = c; if ( c == '\n' && (s->flags & SIO_LBUF) ) { if ( S__flushbuf(s) < 0 ) return -1; } return S__updatefilepos(s, c); } /******************************* * FLAGS * *******************************/ int Sfeof(IOSTREAM *s) { if ( s->flags & SIO_FEOF ) return TRUE; if ( s->bufp < s->limitp ) return FALSE; if ( s->flags & SIO_NBUF ) { errno = EINVAL; return -1; } if ( S__fillbuf(s) == -1 ) return TRUE; s->bufp--; return FALSE; } int Sferror(IOSTREAM *s) { return (s->flags & SIO_FERR) != 0; } int Sfpasteof(IOSTREAM *s) { return (s->flags & (SIO_FEOF2ERR|SIO_FEOF2)) == (SIO_FEOF2ERR|SIO_FEOF2); } void Sclearerr(IOSTREAM *s) { s->flags &= ~(SIO_FEOF|SIO_WARN|SIO_FERR|SIO_FEOF2|SIO_TIMEOUT|SIO_CLEARERR); Sseterr(s, 0, NULL); } void Sseterr(IOSTREAM *s, int flag, const char *message) { if ( s->message ) { free(s->message); s->message = NULL; s->flags &= ~SIO_CLEARERR; } if ( message ) { s->flags |= flag; s->message = strdup(message); } else { s->flags &= ~flag; } } void Yap_swi_install(void); void Yap_swi_install(void) { YAP_UserCPredicate("ctime", SWI_ctime, 2); } #ifdef _WIN32 #include int WINAPI PROTO(win_yap2swi, (HANDLE, DWORD, LPVOID)); int WINAPI win_yap2swi(HANDLE hinst, DWORD reason, LPVOID reserved) { switch (reason) { case DLL_PROCESS_ATTACH: break; case DLL_PROCESS_DETACH: break; case DLL_THREAD_ATTACH: break; case DLL_THREAD_DETACH: break; } return 1; } #endif