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

new text conversion and string code (big changes, take care please)

Browse Source
This commit is contained in:
Vítor Santos Costa 2013-12-02 14:49:41 +00:00
parent 8b7fa9be36
commit d7397b43af
65 changed files with 1498 additions and 2098 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

138
C/absmi.c
View File

@ -4409,6 +4409,52 @@ Yap_absmi(int inp)
ENDD(d0);
ENDOp();
Op(get_string, xu);
BEGD(d0);
d0 = XREG(PREG->u.xu.x);
deref_head(d0, gstring_unk);
gstring_nonvar:
if (!IsApplTerm(d0))
FAIL();
/* we have met a preexisting string */
START_PREFETCH(xu);
BEGP(pt0);
pt0 = RepAppl(d0);
/* check functor */
if (*pt0 != (CELL)FunctorString) {
FAIL();
}
BEGP(pt1);
pt1 = RepAppl(PREG->u.xu.u);
PREG = NEXTOP(PREG, xu);
if (
pt1[1] != pt0[1] ||
strcmp((const char *)(pt1+2), (const char *)(pt0+2))
) FAIL();
ENDP(pt1);
ENDP(pt0);
/* enter read mode */
GONext();
END_PREFETCH();
BEGP(pt0);
deref_body(d0, pt0, gstring_unk, gstring_nonvar);
/* Enter Write mode */
/* set d1 to be the new structure we are going to create */
START_PREFETCH(xc);
BEGD(d1);
d1 = PREG->u.xu.u;
PREG = NEXTOP(PREG, xu);
Bind(pt0, d1);
GONext();
ENDD(d1);
END_PREFETCH();
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(get_longint, xi);
BEGD(d0);
d0 = XREG(PREG->u.xi.x);
@ -6072,6 +6118,87 @@ Yap_absmi(int inp)
GONext();
ENDOp();
Op(unify_string, ou);
BEGD(d0);
BEGP(pt0);
pt0 = SREG++;
d0 = *pt0;
deref_head(d0, ustring_unk);
ustring_nonvar:
if (!IsApplTerm(d0)) {
FAIL();
}
/* look inside term */
BEGP(pt0);
pt0 = RepAppl(d0);
BEGD(d0);
d0 = *pt0;
if (d0 != (CELL)FunctorString) {
FAIL();
}
ENDD(d0);
BEGP(pt1);
pt1 = RepAppl(PREG->u.ou.u);
PREG = NEXTOP(PREG, ou);
if (
pt1[1] != pt0[1]
|| strcmp( (const char *)(pt1 + 2), (const char *)(pt0+2) )
) FAIL();
ENDP(pt1);
ENDP(pt0);
GONext();
derefa_body(d0, pt0, ustring_unk, ustring_nonvar);
BEGD(d1);
d1 = PREG->u.ou.u;
PREG = NEXTOP(PREG, ou);
Bind_Global(pt0, d1);
GONext();
ENDD(d1);
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(unify_l_string, ou);
BEGD(d0);
CACHE_S();
READ_IN_S();
d0 = *S_SREG;
deref_head(d0, ulstring_unk);
ulstring_nonvar:
if (!IsApplTerm(d0)) {
FAIL();
}
BEGP(pt0);
pt0 = RepAppl(d0);
BEGD(d0);
d0 = *pt0;
if (d0 != (CELL)FunctorString) {
FAIL();
}
ENDD(d0);
BEGP(pt1);
pt1 = RepAppl(PREG->u.ou.u);
PREG = NEXTOP(PREG, ou);
if (
pt1[1] != pt0[1]
|| strcmp( (const char *)(pt1 + 2), (const char *)(pt0+2) )
) FAIL();
ENDP(pt1);
ENDP(pt0);
GONext();
derefa_body(d0, S_SREG, ulstring_unk, ulstring_nonvar);
BEGD(d1);
d1 = PREG->u.ou.u;
PREG = NEXTOP(PREG, ou);
Bind_Global(S_SREG, d1);
GONext();
ENDD(d1);
ENDCACHE_S();
ENDD(d0);
ENDOp();
Op(unify_longint, oi);
BEGD(d0);
BEGP(pt0);
@ -11694,6 +11821,17 @@ Yap_absmi(int inp)
}
PREG = PREG->u.l.l;
GONext();
case (CELL)FunctorString:
if (f1 != FunctorString) {
PREG = PREG->u.l.l;
GONext();
}
if (strcmp((char *)(RepAppl(d0)+2),(char *)(RepAppl(d1)+2)) == 0) {
PREG = NEXTOP(PREG, l);
GONext();
}
PREG = PREG->u.l.l;
GONext();
#ifdef USE_GMP
case (CELL)FunctorBigInt:
if (f1 != FunctorBigInt) {

241
C/adtdefs.c
View File

@ -30,6 +30,7 @@ static Prop PredPropByFunc(Functor, Term);
static Prop PredPropByAtom(Atom, Term);
#include "Yatom.h"
#include "yapio.h"
#include "pl-utf8.h"
#include <stdio.h>
#include <wchar.h>
#if HAVE_STRING_H
@ -340,6 +341,25 @@ Yap_LookupMaybeWideAtomWithLength(wchar_t *atom, size_t len)
}
}
Atom
Yap_LookupAtomWithLength(char *atom, size_t len)
{ /* lookup atom in atom table */
char *p = atom;
Atom at;
char *ptr, *ptr0;
/* not really a wide atom */
p = atom;
ptr0 = ptr = Yap_AllocCodeSpace(len+1);
if (!ptr)
return NIL;
while (len--) {*ptr++ = *p++;}
ptr[0] = '\0';
at = LookupAtom(ptr0);
Yap_FreeCodeSpace(ptr0);
return at;
}
Atom
Yap_LookupAtom(char *atom)
{ /* lookup atom in atom table */
@ -1060,6 +1080,9 @@ Yap_GetValue(Atom a)
} else if (f == FunctorLongInt) {
CACHE_REGS
out = MkLongIntTerm(LongIntOfTerm(out));
} else if (f == FunctorString) {
CACHE_REGS
out = MkStringTerm(StringOfTerm(out));
}
#ifdef USE_GMP
else {
@ -1167,6 +1190,21 @@ Yap_PutValue(Atom a, Term v)
memcpy((void *)pt, (void *)ap, sz);
p->ValueOfVE = AbsAppl(pt);
#endif
} else if (IsStringTerm(v)) {
CELL *ap = RepAppl(v);
Int sz =
sizeof(CELL)*(3+ap[1]);
CELL *pt = (CELL *) Yap_AllocAtomSpace(sz);
if (pt == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return;
}
if (IsApplTerm(t0)) {
Yap_FreeCodeSpace((char *) RepAppl(t0));
}
memcpy((void *)pt, (void *)ap, sz);
p->ValueOfVE = AbsAppl(pt);
} else {
if (IsApplTerm(t0)) {
/* recover space */
@ -1201,209 +1239,6 @@ Yap_PutAtomTranslation(Atom a, Int i)
WRITE_UNLOCK(ae->ARWLock);
}
Term
Yap_StringToList(char *s)
{
CACHE_REGS
register Term t;
register unsigned char *cp = (unsigned char *)s + strlen(s);
t = MkAtomTerm(AtomNil);
while (cp > (unsigned char *)s) {
t = MkPairTerm(MkIntTerm(*--cp), t);
}
return (t);
}
Term
Yap_NStringToList(char *s, size_t len)
{
CACHE_REGS
Term t;
unsigned char *cp = (unsigned char *)s + len;
t = MkAtomTerm(AtomNil);
while (cp > (unsigned char *)s) {
t = MkPairTerm(MkIntegerTerm(*--cp), t);
}
return t;
}
Term
Yap_WideStringToList(wchar_t *s)
{
CACHE_REGS
Term t;
wchar_t *cp = s + wcslen(s);
t = MkAtomTerm(AtomNil);
while (cp > s) {
if (ASP < H+1024)
return (CELL)0;
t = MkPairTerm(MkIntegerTerm(*--cp), t);
}
return t;
}
Term
Yap_NWideStringToList(wchar_t *s, size_t len)
{
CACHE_REGS
Term t;
wchar_t *cp = s + len;
t = MkAtomTerm(AtomNil);
while (cp > s) {
if (ASP < H+1024)
return (CELL)0;
t = MkPairTerm(MkIntegerTerm(*--cp), t);
}
return t;
}
Term
Yap_StringToDiffList(char *s, Term t USES_REGS)
{
register unsigned char *cp = (unsigned char *)s + strlen(s);
t = Yap_Globalise(t);
while (cp > (unsigned char *)s) {
if (ASP < H+1024)
return (CELL)0;
t = MkPairTerm(MkIntTerm(*--cp), t);
}
return t;
}
Term
Yap_NStringToDiffList(char *s, Term t, size_t len)
{
CACHE_REGS
register unsigned char *cp = (unsigned char *)s + len;
t = Yap_Globalise(t);
while (cp > (unsigned char *)s) {
t = MkPairTerm(MkIntTerm(*--cp), t);
}
return t;
}
Term
Yap_WideStringToDiffList(wchar_t *s, Term t)
{
CACHE_REGS
wchar_t *cp = s + wcslen(s);
t = Yap_Globalise(t);
while (cp > s) {
t = MkPairTerm(MkIntegerTerm(*--cp), t);
}
return t;
}
Term
Yap_NWideStringToDiffList(wchar_t *s, Term t, size_t len)
{
CACHE_REGS
wchar_t *cp = s + len;
t = Yap_Globalise(t);
while (cp > s) {
t = MkPairTerm(MkIntegerTerm(*--cp), t);
}
return t;
}
Term
Yap_StringToListOfAtoms(char *s)
{
CACHE_REGS
register Term t;
char so[2];
register unsigned char *cp = (unsigned char *)s + strlen(s);
so[1] = '\0';
t = MkAtomTerm(AtomNil);
while (cp > (unsigned char *)s) {
so[0] = *--cp;
t = MkPairTerm(MkAtomTerm(LookupAtom(so)), t);
}
return t;
}
Term
Yap_NStringToListOfAtoms(char *s, size_t len)
{
CACHE_REGS
register Term t;
char so[2];
register unsigned char *cp = (unsigned char *)s + len;
so[1] = '\0';
t = MkAtomTerm(AtomNil);
while (cp > (unsigned char *)s) {
so[0] = *--cp;
t = MkPairTerm(MkAtomTerm(LookupAtom(so)), t);
}
return t;
}
Term
Yap_WideStringToListOfAtoms(wchar_t *s)
{
CACHE_REGS
register Term t;
wchar_t so[2];
wchar_t *cp = s + wcslen(s);
so[1] = '\0';
t = MkAtomTerm(AtomNil);
while (cp > s) {
so[0] = *--cp;
if (ASP < H+1024)
return (CELL)0;
t = MkPairTerm(MkAtomTerm(LookupWideAtom(so)), t);
}
return t;
}
Term
Yap_NWideStringToListOfAtoms(wchar_t *s, size_t len)
{
CACHE_REGS
register Term t;
wchar_t so[2];
wchar_t *cp = s + len;
so[1] = '\0';
t = MkAtomTerm(AtomNil);
while (cp > s) {
if (ASP < H+1024)
return (CELL)0;
so[0] = *--cp;
t = MkPairTerm(MkAtomTerm(LookupWideAtom(so)), t);
}
return t;
}
Term
Yap_NWideStringToDiffListOfAtoms(wchar_t *s, Term t0, size_t len)
{
CACHE_REGS
register Term t;
wchar_t so[2];
wchar_t *cp = s + len;
so[1] = '\0';
t = Yap_Globalise(t0);
while (cp > s) {
so[0] = *--cp;
t = MkPairTerm(MkAtomTerm(LookupWideAtom(so)), t);
}
return t;
}
Term
Yap_ArrayToList(register Term *tp, int nof)
{

2
C/agc.c
View File

@ -324,6 +324,8 @@ mark_global_cell(CELL *pt)
#else
return pt + 3;
#endif
case (CELL)FunctorString:
return pt + 3 + pt[1];
case (CELL)FunctorBigInt:
{
Int sz = 3 +

61
C/amasm.c
View File

@ -1144,6 +1144,22 @@ a_ublob(CELL rnd1, op_numbers opcode, op_numbers opcode_w, int *clause_has_blobs
return code_p;
}
// strings are blobs
inline static yamop *
a_ustring(CELL rnd1, op_numbers opcode, op_numbers opcode_w, int *clause_has_blobsp, yamop *code_p, int pass_no, struct intermediates *cip)
{
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.ou.opcw = emit_op(opcode_w);
code_p->u.ou.u =
AbsAppl((CELL *)(Unsigned(cip->code_addr) + cip->label_offset[rnd1]));
}
*clause_has_blobsp = TRUE;
GONEXT(ou);
return code_p;
}
inline static yamop *
a_udbt(CELL rnd1, op_numbers opcode, op_numbers opcode_w, int *clause_has_dbtermp, yamop *code_p, int pass_no, struct intermediates *cip)
{
@ -1384,6 +1400,19 @@ a_rb(op_numbers opcode, int *clause_has_blobsp, yamop *code_p, int pass_no, stru
return code_p;
}
inline static yamop *
a_rstring(op_numbers opcode, int *clause_has_blobsp, yamop *code_p, int pass_no, struct intermediates *cip)
{
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.xu.x = emit_x(cip->cpc->rnd2);
code_p->u.xu.u = AbsAppl((CELL *)(Unsigned(cip->code_addr) + cip->label_offset[cip->cpc->rnd1]));
}
*clause_has_blobsp = TRUE;
GONEXT(xu);
return code_p;
}
inline static yamop *
a_dbt(op_numbers opcode, int *clause_has_dbtermp, yamop *code_p, int pass_no, struct intermediates *cip)
{
@ -2421,6 +2450,16 @@ copy_blob(yamop *code_p, int pass_no, struct PSEUDO *cpc)
return code_p;
}
static yamop *
copy_string(yamop *code_p, int pass_no, struct PSEUDO *cpc)
{
/* copy the blob to code space, making no effort to align if a double */
int max = cpc->rnd1, i;
for (i = 0; i < max; i++)
code_p = fill_a(cpc->arnds[i], code_p, pass_no);
return code_p;
}
static void
a_fetch_vv(cmp_op_info *cmp_info, int pass_no, struct intermediates *cip)
@ -3240,6 +3279,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case get_bigint_op:
code_p = a_rb(_get_bigint, clause_has_blobsp, code_p, pass_no, cip);
break;
case get_string_op:
code_p = a_rb(_get_string, clause_has_blobsp, code_p, pass_no, cip);
break;
case get_dbterm_op:
code_p = a_dbt(_get_dbterm, clause_has_dbtermp, code_p, pass_no, cip);
break;
@ -3258,6 +3300,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case put_bigint_op:
code_p = a_rb(_put_bigint, clause_has_blobsp, code_p, pass_no, cip);
break;
case put_string_op:
code_p = a_rstring(_put_bigint, clause_has_blobsp, code_p, pass_no, cip);
break;
case put_dbterm_op:
code_p = a_dbt(_put_dbterm, clause_has_dbtermp, code_p, pass_no, cip);
break;
@ -3318,6 +3363,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case unify_bigint_op:
code_p = a_ublob(cip->cpc->rnd1, _unify_bigint, _unify_atom_write, clause_has_blobsp, code_p, pass_no, cip);
break;
case unify_string_op:
code_p = a_ublob(cip->cpc->rnd1, _unify_string, _unify_atom_write, clause_has_blobsp, code_p, pass_no, cip);
break;
case unify_dbterm_op:
code_p = a_udbt(cip->cpc->rnd1, _unify_dbterm, _unify_atom_write, clause_has_dbtermp, code_p, pass_no, cip);
break;
@ -3336,6 +3384,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case unify_last_bigint_op:
code_p = a_ublob(cip->cpc->rnd1, _unify_l_bigint, _unify_l_atom_write, clause_has_blobsp, code_p, pass_no, cip);
break;
case unify_last_string_op:
code_p = a_ublob(cip->cpc->rnd1, _unify_l_bigint, _unify_l_atom_write, clause_has_blobsp, code_p, pass_no, cip);
break;
case unify_last_dbterm_op:
code_p = a_udbt(cip->cpc->rnd1, _unify_l_dbterm, _unify_l_atom_write, clause_has_dbtermp, code_p, pass_no, cip);
break;
@ -3354,6 +3405,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case write_bigint_op:
code_p = a_wblob(cip->cpc->rnd1, _write_bigint, clause_has_blobsp, code_p, pass_no, cip);
break;
case write_string_op:
code_p = a_wblob(cip->cpc->rnd1, _write_bigint, clause_has_blobsp, code_p, pass_no, cip);
break;
case write_dbterm_op:
code_p = a_wdbt(cip->cpc->rnd1, _write_dbterm, clause_has_dbtermp, code_p, pass_no, cip);
break;
@ -3540,7 +3594,8 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
cip->cpc->nextInst != NULL &&
(cip->cpc->nextInst->op == mark_initialised_pvars_op ||
cip->cpc->nextInst->op == mark_live_regs_op ||
cip->cpc->nextInst->op == blob_op)) {
cip->cpc->nextInst->op == blob_op ||
cip->cpc->nextInst->op == string_op)) {
ystop_found = TRUE;
code_p = a_il((CELL)*entry_codep, _Ystop, code_p, pass_no, cip);
}
@ -3746,6 +3801,10 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
/* install a blob */
code_p = copy_blob(code_p, pass_no, cip->cpc);
break;
case string_op:
/* install a blob */
code_p = copy_string(code_p, pass_no, cip->cpc);
break;
case empty_call_op:
/* create an empty call */
code_p = a_empty_call(&clinfo, code_p, pass_no, cip);

1358
C/atoms.c
View File

File diff suppressed because it is too large Load Diff

3
C/attvar.c
View File

@ -950,6 +950,9 @@ AllAttVars( USES_REGS1 ) {
pt += 3;
#endif
break;
case (CELL)FunctorString:
pt += 3+pt[1];
break;
case (CELL)FunctorBigInt:
{
Int sz = 3 +

136
C/bignum.c
View File

@ -469,142 +469,6 @@ p_rational( USES_REGS1 )
#endif
}
int
Yap_IsStringTerm(Term t)
{
CELL fl;
if (IsVarTerm(t))
return FALSE;
if (!IsApplTerm(t))
return FALSE;
if (FunctorOfTerm(t) != FunctorBigInt)
return FALSE;
fl = RepAppl(t)[1];
return fl == BLOB_STRING || fl == BLOB_WIDE_STRING;
}
int
Yap_IsWideStringTerm(Term t)
{
CELL fl;
if (IsVarTerm(t))
return FALSE;
if (!IsApplTerm(t))
return FALSE;
if (FunctorOfTerm(t) != FunctorBigInt)
return FALSE;
fl = RepAppl(t)[1];
return fl == BLOB_WIDE_STRING;
}
Term
Yap_MkBlobStringTerm(const char *s, size_t len)
{
CACHE_REGS
CELL *ret = H;
size_t sz;
MP_INT *dst = (MP_INT *)(H+2);
blob_string_t *sp;
size_t siz;
char *dest;
sz = strlen(s);
if (len > 0 && sz > len) sz = len;
if (len/sizeof(CELL) > (ASP-ret)-1024) {
return TermNil;
}
H[0] = (CELL)FunctorBigInt;
H[1] = BLOB_STRING;
siz = ALIGN_YAPTYPE((len+1+sizeof(blob_string_t)),CELL);
dst->_mp_size = 0L;
dst->_mp_alloc = siz/sizeof(mp_limb_t);
sp = (blob_string_t *)(dst+1);
sp->len = sz;
dest = (char *)(sp+1);
strncpy(dest, s, sz);
dest[sz] = '\0';
H += (siz + 2*sizeof(CELL)+sizeof(MP_INT)+sizeof(Functor))/sizeof(CELL);
H[-1] = EndSpecials;
return AbsAppl(ret);
}
Term
Yap_MkBlobWideStringTerm(const wchar_t *s, size_t len)
{
CACHE_REGS
CELL *ret = H;
size_t sz;
MP_INT *dst = (MP_INT *)(H+2);
blob_string_t *sp = (blob_string_t *)(dst+1);
size_t siz, i = 0;
H[0] = (CELL)FunctorBigInt;
dst->_mp_size = 0L;
sz = wcslen(s);
if (len > 0 && sz > len) {
sz = len;
}
if ((len/sizeof(CELL)) > (ASP-ret)-1024) {
return TermNil;
}
while (i < sz) {
if (s[i++] >= 255) break;
}
if (i == sz) {
/* we have a standard ascii string */
char *target;
size_t i = 0;
H[1] = BLOB_STRING;
siz = ALIGN_YAPTYPE((sz+1+sizeof(blob_string_t)),CELL);
dst->_mp_alloc = siz/sizeof(mp_limb_t);
sp->len = sz;
target = (char *)(sp+1);
for (i = 0 ; i < sz; i++) {
target[i] = s[i];
}
target[sz] = '\0';
H += (siz+2*sizeof(CELL)+sizeof(MP_INT)+sizeof(Functor))/sizeof(CELL);
} else {
wchar_t * target;
H[1] = BLOB_WIDE_STRING;
siz = ALIGN_YAPTYPE((sz+1)*sizeof(wchar_t)+sizeof(blob_string_t),CELL);
dst->_mp_alloc = siz/sizeof(mp_limb_t);
sp->len = sz;
target = (wchar_t *)(sp+1);
wcsncpy(target, s, sz);
target[sz] = '\0';
H += (siz + 2*sizeof(CELL)+sizeof(MP_INT)+sizeof(Functor))/sizeof(CELL);
}
H[-1] = EndSpecials;
return AbsAppl(ret);
}
char *
Yap_BlobStringOfTerm(Term t)
{
blob_string_t *new = (blob_string_t *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
return (char *)(new+1);
}
wchar_t *
Yap_BlobWideStringOfTerm(Term t)
{
blob_string_t *new = (blob_string_t *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
return (wchar_t *)(new+1);
}
char *
Yap_BlobStringOfTermAndLength(Term t, size_t *sp)
{
blob_string_t *new = (blob_string_t *)(RepAppl(t)+2+sizeof(MP_INT)/sizeof(CELL));
*sp = new->len;
return (char *)(new+1);
}
void
Yap_InitBigNums(void)
{

184
C/c_interface.c
View File

@ -354,6 +354,7 @@
#include "yap_structs.h"
#define _yap_c_interface_h 1
#include "pl-shared.h"
#include "YapMirror.h"
#include "pl-read.h"
#ifdef TABLING
#include "tab.macros.h"
@ -1984,42 +1985,16 @@ YAP_FreeSpaceFromYap(void *ptr)
X_API int
YAP_StringToBuffer(Term t, char *buf, unsigned int bufsize)
{
unsigned int j = 0;
while (t != TermNil) {
register Term Head;
register Int i;
Head = HeadOfTerm(t);
if (IsVarTerm(Head)) {
Yap_Error(INSTANTIATION_ERROR,Head,"user defined procedure");
return(FALSE);
} else if (!IsIntTerm(Head)) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"user defined procedure");
return FALSE;
}
i = IntOfTerm(Head);
if (i < 0 || i > 255) {
Yap_Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"user defined procedure");
return FALSE;
}
if (j == bufsize) {
buf[bufsize-1] = '\0';
return FALSE;
} else {
buf[j++] = i;
}
t = TailOfTerm(t);
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR,t,"user defined procedure");
return FALSE;
} else if (!IsPairTerm(t) && t != TermNil) {
Yap_Error(TYPE_ERROR_LIST, t, "user defined procedure");
return FALSE;
}
}
buf[j] = '\0';
return(TRUE);
CACHE_REGS
seq_tv_t inp, out;
inp.val.t = t;
inp.type = YAP_STRING_CODES|YAP_STRING_TRUNC;
inp.max = bufsize;
out.type = YAP_STRING_CHARS;
out.val.c = buf;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return FALSE;
return TRUE;
}
@ -2030,7 +2005,14 @@ YAP_BufferToString(char *s)
Term t;
BACKUP_H();
t = Yap_StringToList(s);
CACHE_REGS
seq_tv_t inp, out;
inp.val.c = s;
inp.type = YAP_STRING_CHARS;
out.type = YAP_STRING_CODES;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2043,7 +2025,16 @@ YAP_NBufferToString(char *s, size_t len)
Term t;
BACKUP_H();
t = Yap_NStringToList(s, len);
CACHE_REGS
seq_tv_t inp, out;
inp.val.c = s;
inp.type = YAP_STRING_CHARS;
out.type = YAP_STRING_CODES|YAP_STRING_NCHARS|YAP_STRING_TRUNC;
out.sz = len;
out.max = len;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2056,7 +2047,14 @@ YAP_WideBufferToString(wchar_t *s)
Term t;
BACKUP_H();
t = Yap_WideStringToList(s);
CACHE_REGS
seq_tv_t inp, out;
inp.val.w = s;
inp.type = YAP_STRING_WCHARS;
out.type = YAP_STRING_CODES;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2069,7 +2067,16 @@ YAP_NWideBufferToString(wchar_t *s, size_t len)
Term t;
BACKUP_H();
t = Yap_NWideStringToList(s, len);
CACHE_REGS
seq_tv_t inp, out;
inp.val.w = s;
inp.type = YAP_STRING_WCHARS;
out.type = YAP_STRING_CODES|YAP_STRING_NCHARS|YAP_STRING_TRUNC;
out.sz = len;
out.max = len;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2131,7 +2138,14 @@ YAP_BufferToAtomList(char *s)
Term t;
BACKUP_H();
t = Yap_StringToListOfAtoms(s);
CACHE_REGS
seq_tv_t inp, out;
inp.val.c = s;
inp.type = YAP_STRING_CHARS;
out.type = YAP_STRING_ATOMS;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2144,7 +2158,16 @@ YAP_NBufferToAtomList(char *s, size_t len)
Term t;
BACKUP_H();
t = Yap_NStringToListOfAtoms(s, len);
CACHE_REGS
seq_tv_t inp, out;
inp.val.c = s;
inp.type = YAP_STRING_CHARS;
out.type = YAP_STRING_ATOMS|YAP_STRING_NCHARS|YAP_STRING_TRUNC;
out.sz = len;
out.max = len;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2157,7 +2180,14 @@ YAP_WideBufferToAtomList(wchar_t *s)
Term t;
BACKUP_H();
t = Yap_WideStringToListOfAtoms(s);
CACHE_REGS
seq_tv_t inp, out;
inp.val.w = s;
inp.type = YAP_STRING_WCHARS;
out.type = YAP_STRING_ATOMS;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2170,7 +2200,16 @@ YAP_NWideBufferToAtomList(wchar_t *s, size_t len)
Term t;
BACKUP_H();
t = Yap_NWideStringToListOfAtoms(s, len);
CACHE_REGS
seq_tv_t inp, out;
inp.val.w = s;
inp.type = YAP_STRING_WCHARS;
out.type = YAP_STRING_ATOMS|YAP_STRING_NCHARS|YAP_STRING_TRUNC;
out.sz = len;
out.max = len;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2183,7 +2222,17 @@ YAP_NWideBufferToAtomDiffList(wchar_t *s, Term t0, size_t len)
Term t;
BACKUP_H();
t = Yap_NWideStringToDiffListOfAtoms(s, t0, len);
CACHE_REGS
seq_tv_t inp, out;
inp.val.w = s;
inp.type = YAP_STRING_WCHARS;
out.type = YAP_STRING_ATOMS|YAP_STRING_NCHARS|YAP_STRING_TRUNC|YAP_STRING_DIFF;
out.sz = len;
out.max = len;
out.dif = t0;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2193,11 +2242,18 @@ YAP_NWideBufferToAtomDiffList(wchar_t *s, Term t0, size_t len)
X_API Term
YAP_BufferToDiffList(char *s, Term t0)
{
CACHE_REGS
Term t;
BACKUP_H();
t = Yap_StringToDiffList(s, t0 PASS_REGS);
CACHE_REGS
seq_tv_t inp, out;
inp.val.c = s;
inp.type = YAP_STRING_CHARS;
out.type = YAP_STRING_CODES|YAP_STRING_DIFF;
out.dif = t0;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2210,7 +2266,17 @@ YAP_NBufferToDiffList(char *s, Term t0, size_t len)
Term t;
BACKUP_H();
t = Yap_NStringToDiffList(s, t0, len);
CACHE_REGS
seq_tv_t inp, out;
inp.val.c = s;
inp.type = YAP_STRING_CHARS;
out.type = YAP_STRING_CODES|YAP_STRING_NCHARS|YAP_STRING_TRUNC|YAP_STRING_DIFF;
out.sz = len;
out.max = len;
out.dif = t0;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2223,7 +2289,15 @@ YAP_WideBufferToDiffList(wchar_t *s, Term t0)
Term t;
BACKUP_H();
t = Yap_WideStringToDiffList(s, t0);
CACHE_REGS
seq_tv_t inp, out;
inp.val.w = s;
inp.type = YAP_STRING_WCHARS;
out.type = YAP_STRING_CODES|YAP_STRING_DIFF;
out.dif = t0;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;
@ -2236,7 +2310,17 @@ YAP_NWideBufferToDiffList(wchar_t *s, Term t0, size_t len)
Term t;
BACKUP_H();
t = Yap_NWideStringToDiffList(s, t0, len);
CACHE_REGS
seq_tv_t inp, out;
inp.val.w = s;
inp.type = YAP_STRING_WCHARS;
out.type = YAP_STRING_CODES|YAP_STRING_NCHARS|YAP_STRING_TRUNC|YAP_STRING_DIFF;
out.sz = len;
out.max = len;
out.dif = t0;
if (!Yap_CVT_Text(&inp, &out PASS_REGS))
return 0L;
t = out.val.t;
RECOVER_H();
return t;

58
C/cmppreds.c
View File

@ -141,6 +141,26 @@ static int compare_complex(register CELL *pt0, register CELL *pt0_end, register
}
if (out != 0)
goto done;
} else if (IsStringTerm(d0)) {
if (IsStringTerm(d1)){
out = strcmp(StringOfTerm(d0) , StringOfTerm(d1));
} else if (IsIntTerm(d1))
out = 1;
else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = 1;
#ifdef USE_GMP
} else if (IsBigIntTerm(d1)) {
out = 1;
#endif
} else if (IsRefTerm(d1)) {
out = 1 ;
} else {
out = -1;
}
if (out != 0)
goto done;
} else if (IsLongIntTerm(d0)) {
if (IsIntTerm(d1))
out = LongIntOfTerm(d0) - IntOfTerm(d1);
@ -319,24 +339,30 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
return cmp_atoms(AtomOfTerm(t1),AtomOfTerm(t2));
if (IsPrimitiveTerm(t2))
return 1;
if (IsStringTerm(t2))
return 1;
return -1;
} else {
if (IsIntTerm(t2)) {
return IntOfTerm(t1) - IntOfTerm(t2);
}
if (IsFloatTerm(t2)) {
return 1;
}
if (IsLongIntTerm(t2)) {
return IntOfTerm(t1) - LongIntOfTerm(t2);
}
if (IsApplTerm(t2)) {
Functor fun2 = FunctorOfTerm(t2);
switch ((CELL)fun2) {
case double_e:
return 1;
case long_int_e:
return IntOfTerm(t1) - LongIntOfTerm(t2);
#ifdef USE_GMP
if (IsBigIntTerm(t2)) {
return Yap_gmp_tcmp_int_big(IntOfTerm(t1), t2);
}
case big_int_e:
return Yap_gmp_tcmp_int_big(IntOfTerm(t1), t2);
#endif
if (IsRefTerm(t2))
return 1;
case db_ref_e:
return 1;
case string_e:
return 1;
}
}
return -1;
}
} else if (IsPairTerm(t1)) {
@ -408,6 +434,16 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
return -1;
}
#endif
case string_e:
{
if (IsApplTerm(t2)) {
Functor f2 = FunctorOfTerm(t2);
if (f2 == FunctorString)
return strcmp(StringOfTerm(t1), StringOfTerm(t2));
return 1;
}
return -1;
}
case db_ref_e:
if (IsRefTerm(t2))
return Unsigned(RefOfTerm(t2)) -

43
C/compiler.c
View File

@ -668,7 +668,7 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_atom_op
: unify_atom_op) :
write_atom_op), (CELL) t, Zero, &cglobs->cint);
} else if (IsIntegerTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t)) {
} else if (IsIntegerTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t) || IsStringTerm(t)) {
if (!IsIntTerm(t)) {
if (IsFloatTerm(t)) {
if (level == 0)
@ -684,6 +684,41 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_longint_op
: unify_longint_op) :
write_longint_op), t, Zero, &cglobs->cint);
} else if (IsStringTerm(t)) {
/* we are taking a string, that is supposed to be
guarded in the clause itself. . */
CELL l1 = ++cglobs->labelno;
CELL *src = RepAppl(t);
PInstr *ocpc = cglobs->cint.cpc, *OCodeStart = cglobs->cint.CodeStart;
Int sz = (3+src[1])*sizeof(CELL);
CELL *dest;
/* use a special list to store the blobs */
cglobs->cint.cpc = cglobs->cint.icpc;
/* if (IsFloatTerm(t)) {
Yap_emit(align_float_op, Zero, Zero, &cglobs->cint);
}*/
Yap_emit(label_op, l1, Zero, &cglobs->cint);
dest =
Yap_emit_extra_size(blob_op, sz/CellSize, sz, &cglobs->cint);
/* copy the bignum */
memcpy(dest, src, sz);
/* note that we don't need to copy size info, unless we wanted
to garbage collect clauses ;-) */
cglobs->cint.icpc = cglobs->cint.cpc;
if (cglobs->cint.BlobsStart == NULL)
cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
cglobs->cint.cpc = ocpc;
cglobs->cint.CodeStart = OCodeStart;
/* The argument to pass to the structure is now the label for
where we are storing the blob */
if (level == 0)
Yap_emit((cglobs->onhead ? get_string_op : put_string_op), t, argno, &cglobs->cint);
else
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_string_op
: unify_string_op) :
write_string_op), t, Zero, &cglobs->cint);
} else {
/* we are taking a blob, that is a binary that is supposed to be
guarded in the clause itself. Possible examples include
@ -2585,6 +2620,7 @@ CheckVoids(compiler_struct *cglobs)
case get_float_op:
case get_dbterm_op:
case get_longint_op:
case get_string_op:
case get_bigint_op:
case get_list_op:
case get_struct_op:
@ -2935,6 +2971,7 @@ c_layout(compiler_struct *cglobs)
case get_num_op:
case get_float_op:
case get_longint_op:
case get_string_op:
case get_dbterm_op:
case get_bigint_op:
--cglobs->Uses[rn];
@ -3013,6 +3050,7 @@ c_layout(compiler_struct *cglobs)
case put_num_op:
case put_float_op:
case put_longint_op:
case put_string_op:
case put_dbterm_op:
case put_bigint_op:
rn = checkreg(arg, rn, ic, FALSE, cglobs);
@ -3311,10 +3349,13 @@ c_optimize(PInstr *pc)
case unify_last_float_op:
case write_float_op:
case unify_longint_op:
case unify_string_op:
case unify_bigint_op:
case unify_last_longint_op:
case unify_last_string_op:
case unify_last_bigint_op:
case write_longint_op:
case write_string_op:
case write_bigint_op:
case unify_list_op:
case write_list_op:

2
C/computils.c
View File

@ -435,6 +435,8 @@ write_functor(Functor f)
Yap_DebugPlWrite(MkAtomTerm(AtomLONGINT));
} else if (f == FunctorDouble) {
Yap_DebugPlWrite(MkAtomTerm(AtomDOUBLE));
} else if (f == FunctorString) {
Yap_DebugPlWrite(MkAtomTerm(AtomSTRING));
}
} else {
Yap_DebugPlWrite(MkAtomTerm(NameOfFunctor (f)));

6
C/corout.c
View File

@ -152,6 +152,9 @@ static int can_unify_complex(register CELL *pt0,
case (CELL)FunctorDouble:
if (FloatOfTerm(d0) == FloatOfTerm(d1)) continue;
goto comparison_failed;
case (CELL)FunctorString:
if (strcmp(StringOfTerm(d0), StringOfTerm(d1)) == 0) continue;
goto comparison_failed;
#ifdef USE_GMP
case (CELL)FunctorBigInt:
if (Yap_gmp_tcmp_big_big(d0,d1) == 0) continue;
@ -288,6 +291,9 @@ can_unify(Term t1, Term t2, Term *Vars USES_REGS)
case (CELL)FunctorLongInt:
if (RepAppl(t1)[1] == RepAppl(t2)[1]) return(TRUE);
return FALSE;
case (CELL)FunctorString:
if (strcmp(StringOfTerm(t1), StringOfTerm(t2)) == 0) return(TRUE);
return FALSE;
case (CELL)FunctorDouble:
if (FloatOfTerm(t1) == FloatOfTerm(t2)) return(TRUE);
return FALSE;

24
C/dbase.c
View File

@ -596,6 +596,16 @@ copy_double(CELL *st, CELL *pt)
return st+(2+SIZEOF_DOUBLE/SIZEOF_LONG_INT);
}
static CELL *
copy_string(CELL *st, CELL *pt)
{
UInt sz = pt[1]+3;
/* first thing, store a link to the list before we move on */
memcpy(st,pt,sizeof(CELL)*sz);
/* now reserve space */
return st+sz;
}
#ifdef USE_GMP
static CELL *
copy_big_int(CELL *st, CELL *pt)
@ -711,6 +721,17 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
++pt0;
continue;
#endif
case (CELL)FunctorString:
{
CELL *st = CodeMax;
CheckDBOverflow(3+ap2[1]);
/* first thing, store a link to the list before we move on */
*StoPoint++ = AbsAppl(st);
CodeMax = copy_string(CodeMax, ap2);
++pt0;
continue;
}
case (CELL)FunctorDouble:
{
CELL *st = CodeMax;
@ -1478,6 +1499,9 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
case (CELL)FunctorDouble:
ntp = copy_double(ntp0, RepAppl(Tm));
break;
case (CELL)FunctorString:
ntp = copy_string(ntp0, RepAppl(Tm));
break;
case (CELL)FunctorDBRef:
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return CreateDBWithDBRef(Tm, p, dbg);

110
C/errors.c
View File

@ -29,6 +29,100 @@
#endif
#include "Foreign.h"
static Term
gen_syntax_error(Atom InpAtom, char *s)
{
CACHE_REGS
Term ts[7], ti[2];
ti[0] = ARG1;
ti[1] = ARG2;
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(Yap_LookupAtom(s),2),2,ti);
ts[1] = ts[4] = ts[5] = MkIntTerm(0);
ts[2] = MkAtomTerm(AtomExpectedNumber);
ts[3] = TermNil;
ts[6] = MkAtomTerm(InpAtom);
return(Yap_MkApplTerm(FunctorSyntaxError,7,ts));
}
int Yap_HandleError( const char *s, ... ) {
CACHE_REGS
yap_error_number err = LOCAL_Error_TYPE;
char *serr;
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (LOCAL_ErrorMessage) {
serr = LOCAL_ErrorMessage;
} else {
serr = (char *)s;
}
switch (err) {
case OUT_OF_STACK_ERROR:
if (!Yap_gc(2, ENV, gc_P(P,CP))) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, serr);
return(FALSE);
}
return TRUE;
case OUT_OF_AUXSPACE_ERROR:
if (LOCAL_MAX_SIZE < (char *)AuxSp-AuxBase) {
LOCAL_MAX_SIZE += 1024;
}
if (!Yap_ExpandPreAllocCodeSpace(0,NULL, TRUE)) {
/* crash in flames */
Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, serr);
return FALSE;
}
return TRUE;
case OUT_OF_HEAP_ERROR:
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, ARG2, serr);
return FALSE;
}
default:
Yap_Error(err, LOCAL_Error_Term, serr);
return(FALSE);
}
}
int Yap_SWIHandleError( const char *s, ... )
{
CACHE_REGS
yap_error_number err = LOCAL_Error_TYPE;
char *serr;
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (LOCAL_ErrorMessage) {
serr = LOCAL_ErrorMessage;
} else {
serr = (char *)s;
}
switch (err) {
case OUT_OF_STACK_ERROR:
if (!Yap_gc(2, ENV, gc_P(P,CP))) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, serr);
return(FALSE);
}
return TRUE;
case OUT_OF_AUXSPACE_ERROR:
if (LOCAL_MAX_SIZE < (char *)AuxSp-AuxBase) {
LOCAL_MAX_SIZE += 1024;
}
if (!Yap_ExpandPreAllocCodeSpace(0,NULL, TRUE)) {
/* crash in flames */
Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, serr);
return FALSE;
}
return TRUE;
case OUT_OF_HEAP_ERROR:
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, ARG2, serr);
return FALSE;
}
default:
Yap_Error(err, LOCAL_Error_Term, serr);
return(FALSE);
}
}
void
Yap_RestartYap ( int flag )
@ -1454,7 +1548,7 @@ Yap_Error(yap_error_number type, Term where, char *format,...)
i = strlen(tmpbuf);
ti[0] = MkAtomTerm(AtomSyntaxError);
nt[0] = Yap_MkApplTerm(FunctorShortSyntaxError, 1, ti);
nt[0] = gen_syntax_error(AtomNil, tmpbuf);
psize -= i;
fun = FunctorError;
serious = TRUE;
@ -1535,6 +1629,20 @@ Yap_Error(yap_error_number type, Term where, char *format,...)
serious = TRUE;
}
break;
case TYPE_ERROR_BIGNUM:
{
int i;
Term ti[2];
i = strlen(tmpbuf);
ti[0] = MkAtomTerm(AtomBigNum);
ti[1] = where;
nt[0] = Yap_MkApplTerm(FunctorTypeError, 2, ti);
psize -= i;
fun = FunctorError;
serious = TRUE;
}
break;
case TYPE_ERROR_BYTE:
{
int i;

16
C/globals.c
View File

@ -395,6 +395,14 @@ copy_complex_term(register CELL *pt0, register CELL *pt0_end, int share, int cop
H += 3;
#endif
break;
case (CELL)FunctorString:
if (ASP - H > MIN_ARENA_SIZE+3+ap2[1]) {
goto overflow;
}
*ptf++ = AbsAppl(H);
memcpy(H, ap2, sizeof(CELL)*(3+ap2[1]));
H+=ap2[1]+3;
break;
default:
{
/* big int */
@ -680,6 +688,14 @@ CopyTermToArena(Term t, Term arena, int share, int copy_att_vars, UInt arity, Te
H += 3;
#endif
break;
case (CELL)FunctorString:
if (H > ASP - MIN_ARENA_SIZE+3+ap[1]) {
res = -1;
goto error_handler;
}
memcpy(H, ap, sizeof(CELL)*(3+ap[1]));
H += ap[1]+3;
break;
default:
{
UInt sz = ArenaSz(t), i;

58
C/gmp_support.c
View File

@ -1327,51 +1327,6 @@ Yap_gmp_tcmp_big_big(Term t1, Term t2)
return 1;
} else if (pt1[1] == BIG_RATIONAL) {
b1 = Yap_BigRatOfTerm(t1);
} else if (pt1[1] == BLOB_STRING) {
char *s1 = Yap_BlobStringOfTerm(t1);
if (pt2[1] == BLOB_STRING) {
char *s2 = Yap_BlobStringOfTerm(t2);
return strcmp(s1,s2);
} else if (pt2[1] == BLOB_WIDE_STRING) {
wchar_t *wcs2 = Yap_BlobWideStringOfTerm(t2), *wcs1, *tmp1;
int out;
size_t n = strlen(s1);
if (!(wcs1 = (wchar_t *)malloc((n+1)*sizeof(wchar_t)))) {
Yap_Error(OUT_OF_HEAP_ERROR, t1, "compare/3");
return 0;
}
tmp1 = wcs1;
while (*s1) {
*tmp1++ = *s1++;
}
out = wcscmp(wcs1, wcs2);
free(wcs1);
return out;
}
b1 = Yap_BigRatOfTerm(t1);
} else if (pt1[1] == BLOB_WIDE_STRING) {
wchar_t *wcs1 = Yap_BlobWideStringOfTerm(t1);
if (pt2[1] == BLOB_STRING) {
char *s2 = Yap_BlobStringOfTerm(t2);
wchar_t *wcs2, *tmp2;
int out;
size_t n = strlen(s2);
if (!(wcs2 = (wchar_t *)malloc((n+1)*sizeof(wchar_t)))) {
Yap_Error(OUT_OF_HEAP_ERROR, t2, "compare/3");
return 0;
}
tmp2 = wcs2;
while (*s2) {
*tmp2++ = *s2++;
}
out = wcscmp(wcs1, wcs2);
free(wcs2);
return out;
} else if (pt2[1] == BLOB_WIDE_STRING) {
wchar_t *wcs2 = Yap_BlobWideStringOfTerm(t2);
return wcscmp(wcs1,wcs2);
}
b1 = Yap_BigRatOfTerm(t1);
} else {
return pt1-pt2;
}
@ -1686,6 +1641,19 @@ Yap_gmp_popcount(Term t)
}
}
char *
Yap_mpz_to_string(MP_INT *b, char *s, size_t sz, int base)
{
if (s) {
size_t size = mpz_sizeinbase(b, base);
if (size+2 > sz) {
return NULL;
}
return mpz_get_str (s, base, b);
}
return NULL;
}
char *
Yap_gmp_to_string(Term t, char *s, size_t sz, int base)
{

21
C/grow.c
View File

@ -559,6 +559,9 @@ AdjustGlobal(long sz, int thread_copying USES_REGS)
pt += 2;
#endif
break;
case (CELL)FunctorString:
pt += 3+pt[1];
break;
case (CELL)FunctorBigInt:
{
Int sz = 2+
@ -1082,7 +1085,9 @@ fix_compiler_instructions(PInstr *pcpc USES_REGS)
case get_float_op:
case put_float_op:
case get_longint_op:
case get_string_op:
case put_longint_op:
case put_string_op:
case unify_float_op:
case unify_last_float_op:
case write_float_op:
@ -1112,8 +1117,11 @@ fix_compiler_instructions(PInstr *pcpc USES_REGS)
case unify_last_num_op:
case write_num_op:
case unify_longint_op:
case unify_string_op:
case unify_last_longint_op:
case unify_last_string_op:
case write_longint_op:
case write_string_op:
case unify_bigint_op:
case unify_last_bigint_op:
case unify_dbterm_op:
@ -1416,6 +1424,18 @@ Yap_growheap(int fix_code, size_t in_size, void *cip)
int res;
int blob_overflow = (NOfBlobs > NOfBlobsMax);
#if (THREADS) || YAPOR
res = FALSE;
if (NOfAtoms > 2*AtomHashTableSize || blob_overflow) {
LOCK(LOCAL_SignalLock);
if (LOCAL_ActiveSignals == YAP_CDOVF_SIGNAL) {
CreepFlag = CalculateStackGap();
}
LOCAL_ActiveSignals &= ~YAP_CDOVF_SIGNAL;
UNLOCK(LOCAL_SignalLock);
return TRUE;
}
#else
if (NOfAtoms > 2*AtomHashTableSize || blob_overflow) {
UInt n = NOfAtoms;
if (GLOBAL_AGcThreshold)
@ -1446,6 +1466,7 @@ Yap_growheap(int fix_code, size_t in_size, void *cip)
res=do_growheap(fix_code, in_size, (struct intermediates *)cip, NULL, NULL, NULL PASS_REGS);
#endif
LeaveGrowMode(GrowHeapMode);
#endif
return res;
}

17
C/heapgc.c
View File

@ -1378,6 +1378,23 @@ mark_variable(CELL_PTR current USES_REGS)
MARK(next+sz);
}
POP_CONTINUATION();
case (CELL)FunctorString:
MARK(next);
PUSH_POINTER(next PASS_REGS);
{
UInt sz = 2+next[1];
if (next < LOCAL_HGEN) {
LOCAL_total_oldies+= 1+sz;
} else {
DEBUG_printf0("%p 1\n", next);
DEBUG_printf1("%p %ld\n", next, (long int)(sz+1));
}
//fprintf(stderr,"%p M %d\n", next,1+sz);
LOCAL_total_marked += 1+sz;
PUSH_POINTER(next+sz PASS_REGS);
MARK(next+sz);
}
POP_CONTINUATION();
case (CELL)FunctorBigInt:
{
Opaque_CallOnGCMark f;

14
C/index.c
View File

@ -1203,6 +1203,16 @@ add_arg_info(ClauseDef *clause, PredEntry *ap, UInt argno)
cl = NEXTOP(cl,oc);
argno--;
break;
case _unify_string:
case _unify_l_string:
if (argno == 1) {
clause->Tag = AbsAppl((CELL *)FunctorString);
clause->u.t_ptr = cl->u.ou.u;
return;
}
cl = NEXTOP(cl,ou);
argno--;
break;
case _unify_n_atoms:
if (argno <= cl->u.osc.s) {
clause->Tag = cl->u.osc.c;
@ -2920,6 +2930,10 @@ install_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack)
if (cls->u.t_ptr &&
Yap_Double_key(sp->extra) != Yap_Double_key(cls->u.t_ptr))
break;
} else if (f == FunctorString) {
if (cls->u.t_ptr &&
Yap_String_key(sp->extra) != Yap_String_key(cls->u.t_ptr))
break;
} else {
if (cls->u.t_ptr &&
Yap_Int_key(sp->extra) != Yap_Int_key(cls->u.t_ptr))

4
C/inlines.c
View File

@ -325,6 +325,8 @@ eq(Term t1, Term t2 USES_REGS)
return (d0 == d1);
case (CELL)FunctorLongInt:
return(LongIntOfTerm(d0) == LongIntOfTerm(d1));
case (CELL)FunctorString:
return(strcmp(StringOfTerm(d0), StringOfTerm(d1)) == 0);
#ifdef USE_GMP
case (CELL)FunctorBigInt:
return (Yap_gmp_tcmp_big_big(d0, d1) == 0);
@ -611,6 +613,8 @@ p_functor( USES_REGS1 ) /* functor(?,?,?) */
d1 = MkIntTerm(0);
} else if (d1 == (CELL)FunctorLongInt) {
d1 = MkIntTerm(0);
} else if (d1 == (CELL)FunctorString) {
d1 = MkIntTerm(0);
} else
return(FALSE);
} else {

7
C/iopreds.c
View File

@ -31,6 +31,7 @@ static char SccsId[] = "%W% %G%";
#include "eval.h"
/* stuff we want to use in standard YAP code */
#include "pl-shared.h"
#include "YapMirror.h"
#include <stdlib.h>
#if HAVE_STDARG_H
#include <stdarg.h>
@ -324,7 +325,7 @@ syntax_error (TokEntry * tokptr, IOSTREAM *st, Term *outp)
VarEntry *varinfo = (VarEntry *)info;
t[0] = MkIntTerm(0);
t[1] = Yap_StringToList(varinfo->VarRep);
t[1] = Yap_CharsToListOfCodes((const char *)varinfo->VarRep PASS_REGS);
if (varinfo->VarAdr == TermNil) {
t[2] = varinfo->VarAdr = MkVarTerm();
} else {
@ -335,13 +336,13 @@ syntax_error (TokEntry * tokptr, IOSTREAM *st, Term *outp)
break;
case String_tok:
{
Term t0 = Yap_StringToList((char *)info);
Term t0 = Yap_CharsToListOfCodes((const char *)info PASS_REGS);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString,1),1,&t0);
}
break;
case WString_tok:
{
Term t0 = Yap_WideStringToList((wchar_t *)info);
Term t0 = Yap_WCharsToListOfCodes((const wchar_t *)info PASS_REGS);
ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomString,1),1,&t0);
}
break;

4
C/load_foreign.c
View File

@ -21,6 +21,8 @@ static char SccsId[] = "%W% %G%.2";
#include "Yatom.h"
#include "YapHeap.h"
#include "yapio.h"
#include "pl-shared.h"
#include "YapMirror.h"
#include <stdlib.h>
#if HAVE_STRING_H
#include <string.h>
@ -211,7 +213,7 @@ p_call_shared_object_function( USES_REGS1 ) {
static Int
p_obj_suffix( USES_REGS1 ) {
return Yap_unify(Yap_StringToList(SO_EXT),ARG1);
return Yap_unify(Yap_CharsToListOfCodes(SO_EXT PASS_REGS),ARG1);
}
static Int

45
C/parser.c
View File

@ -53,6 +53,7 @@ static char SccsId[] = "%W% %G%";
#include "eval.h"
/* stuff we want to use in standard YAP code */
#include "pl-shared.h"
#include "YapMirror.h"
#include "pl-read.h"
#include "pl-text.h"
#if HAVE_STRING_H
@ -392,7 +393,7 @@ checkfor(wchar_t c, JMPBUFF *FailBuff USES_REGS)
static int
is_quasi_quotation_syntax(Term goal, ReadData _PL_rd, Atom *pat)
{ GET_LD
{ CACHE_REGS
Term m = CurrentModule, t;
Atom at;
UInt arity;
@ -688,23 +689,9 @@ ParseTerm(read_data *rd, int prio, JMPBUFF *FailBuff USES_REGS)
case String_tok: /* build list on the heap */
{
Volatile char *p = (char *) LOCAL_tokptr->TokInfo;
if (*p == 0)
t = MkAtomTerm(AtomNil);
else {
unsigned int flags = Yap_GetModuleEntry(CurrentModule)->flags;
if (flags & DBLQ_CHARS)
t = Yap_StringToListOfAtoms(p);
else if (flags & DBLQ_ATOM) {
Atom at = Yap_LookupAtom(p);
if (at == NIL) {
LOCAL_ErrorMessage = "Heap Overflow";
FAIL;
}
t = MkAtomTerm(at);
} else if (flags & DBLQ_STRING) {
t = Yap_MkBlobStringTerm(p, strlen(p));
} else
t = Yap_StringToList(p);
t = Yap_CharsToTDQ(p, CurrentModule PASS_REGS);
if (!t) {
FAIL;
}
NextToken;
}
@ -713,26 +700,8 @@ ParseTerm(read_data *rd, int prio, JMPBUFF *FailBuff USES_REGS)
case WString_tok: /* build list on the heap */
{
Volatile wchar_t *p = (wchar_t *) LOCAL_tokptr->TokInfo;
if (*p == 0)
t = MkAtomTerm(AtomNil);
else {
unsigned int flags = Yap_GetModuleEntry(CurrentModule)->flags;
if (flags & DBLQ_CHARS)
t = Yap_WideStringToListOfAtoms(p);
else if (flags & DBLQ_ATOM) {
Atom at = Yap_LookupWideAtom(p);
if (at == NIL) {
LOCAL_ErrorMessage = "Heap Overflow";
FAIL;
}
t = MkAtomTerm(at);
} else if (flags & DBLQ_STRING) {
t = Yap_MkBlobWideStringTerm(p, wcslen(p));
} else
t = Yap_WideStringToList(p);
}
if (t == 0L) {
LOCAL_ErrorMessage = "Stack Overflow";
t = Yap_WCharsToTDQ(p, CurrentModule PASS_REGS);
if (!t) {
FAIL;
}
NextToken;

22
C/pl-yap.c
View File

@ -7,6 +7,7 @@
#include "Yap.h"
#include "Yatom.h"
#include "pl-incl.h"
#include "YapMirror.h"
#if HAVE_MATH_H
#include <math.h>
#endif
@ -84,13 +85,17 @@ codeToAtom(int chrcode)
word
globalString(size_t size, char *s)
{
return Yap_MkBlobStringTerm(s, size);
CACHE_REGS
return Yap_CharsToString(s PASS_REGS);
}
word
globalWString(size_t size, wchar_t *s)
{
return Yap_MkBlobWideStringTerm(s, size);
CACHE_REGS
return Yap_WCharsToString(s PASS_REGS);
}
int
@ -414,16 +419,9 @@ get_atom_text(atom_t atom, PL_chars_t *text)
int
get_string_text(word w, PL_chars_t *text ARG_LD)
{
CELL fl = RepAppl(w)[1];
if (fl == BLOB_STRING) {
text->text.t = Yap_BlobStringOfTerm(w);
text->encoding = ENC_ISO_LATIN_1;
text->length = strlen(text->text.t);
} else {
text->text.w = Yap_BlobWideStringOfTerm(w);
text->encoding = ENC_WCHAR;
text->length = wcslen(text->text.w);
}
text->text.t = (char *)StringOfTerm(w);
text->encoding = ENC_ISO_LATIN_1;
text->length = strlen(text->text.t);
text->storage = PL_CHARS_STACK;
text->canonical = TRUE;
return TRUE;

4
C/scanner.c
View File

@ -42,7 +42,7 @@
/* stuff we want to use in standard YAP code */
#include "pl-shared.h"
#include "pl-read.h"
#include "pl-utf8.h"
#include "YapMirror.h"
#if _MSC_VER || defined(__MINGW32__)
#if HAVE_FINITE==1
#undef HAVE_FINITE
@ -780,7 +780,7 @@ extend_comment(int ch USES_REGS) {
static void
close_comment( USES_REGS1 ) {
LOCAL_CommentsBuff[LOCAL_CommentsBuffPos] = '\0';
*LOCAL_CommentsNextChar = Yap_MkBlobWideStringTerm(LOCAL_CommentsBuff, LOCAL_CommentsBuffPos);
*LOCAL_CommentsNextChar = Yap_WCharsToString(LOCAL_CommentsBuff PASS_REGS);
free(LOCAL_CommentsBuff);
LOCAL_CommentsBuff = NULL;
LOCAL_CommentsBuffLim = 0;

9
C/sysbits.c
View File

@ -186,12 +186,14 @@ Yap_InitSysPath(void) {
int commons_done = FALSE;
{
char *dir;
if ((dir = Yap_RegistryGetString("library"))) {
if ((dir = Yap_RegistryGetString("library")) &&
is_directory(dir)) {
Yap_PutValue(AtomSystemLibraryDir,
MkAtomTerm(Yap_LookupAtom(dir)));
dir_done = TRUE;
}
if ((dir = Yap_RegistryGetString("prolog_commons"))) {
if ((dir = Yap_RegistryGetString("prolog_commons")) &&
is_directory(dir)) {
Yap_PutValue(AtomPrologCommonsDir,
MkAtomTerm(Yap_LookupAtom(dir)));
commons_done = TRUE;
@ -207,8 +209,7 @@ Yap_InitSysPath(void) {
int buflen;
char *pt;
if ((fatts = GetFileAttributes(LOCAL_FileNameBuf)) == 0xFFFFFFFFL ||
!(fatts & FILE_ATTRIBUTE_DIRECTORY)) {
if (!is_directory(LOCAL_FileNameBuf)) {
/* couldn't find it where it was supposed to be,
let's try using the executable */
if (!GetModuleFileNameEx( GetCurrentProcess(), NULL, LOCAL_FileNameBuf, YAP_FILENAME_MAX)) {

6
C/unify.c
View File

@ -376,6 +376,8 @@ oc_unify_nvar_nvar:
return(pt0[1] == pt1[1]);
case (CELL)FunctorDouble:
return(FloatOfTerm(AbsAppl(pt0)) == FloatOfTerm(AbsAppl(pt1)));
case (CELL)FunctorString:
return(strcmp( (const char *)(pt0+2), (const char )(pt1+2)) == 0);
#ifdef USE_GMP
case (CELL)FunctorBigInt:
return(Yap_gmp_tcmp_big_big(AbsAppl(pt0),AbsAppl(pt0)) == 0);
@ -505,6 +507,8 @@ unify_nvar_nvar:
return(pt0 == pt1);
case (CELL)FunctorLongInt:
return(pt0[1] == pt1[1]);
case (CELL)FunctorString:
return(strcmp( (const char *)(pt0+2), (const char )(pt1+2)) == 0);
case (CELL)FunctorDouble:
return(FloatOfTerm(AbsAppl(pt0)) == FloatOfTerm(AbsAppl(pt1)));
#ifdef USE_GMP
@ -870,6 +874,8 @@ unifiable_nvar_nvar:
return(pt0 == pt1);
case (CELL)FunctorLongInt:
return(pt0[1] == pt1[1]);
case (CELL)FunctorString:
return(strcmp( (const char *)(pt0+2), (const char )(pt1+2)) == 0);
case (CELL)FunctorDouble:
return(FloatOfTerm(AbsAppl(pt0)) == FloatOfTerm(AbsAppl(pt1)));
#ifdef USE_GMP

12
C/utilpreds.c
View File

@ -169,6 +169,8 @@ copy_complex_term(CELL *pt0, CELL *pt0_end, int share, int newattvs, CELL *ptf,
sz = sizeof(Float)/sizeof(CELL)+2;
} else if (f== FunctorLongInt) {
sz = 3;
} else if (f== FunctorString) {
sz = 3+ap2[1];
} else {
CELL *pt = ap2+1;
sz = 2+sizeof(MP_INT)+(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
@ -1333,6 +1335,8 @@ export_complex_term(Term tf, CELL *pt0, CELL *pt0_end, char * buf, size_t len0,
sz = sizeof(Float)/sizeof(CELL)+2;
} else if (f== FunctorLongInt) {
sz = 3;
} else if (f== FunctorString) {
sz = 3+ap2[1];
} else {
CELL *pt = ap2+1;
sz = 2+sizeof(MP_INT)+(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
@ -3331,6 +3335,9 @@ SizeOfExtension(Term t)
if (f== FunctorDouble) {
return 2 + sizeof(Float)/sizeof(CELL);
}
if (f== FunctorString) {
return 3 + RepAppl(t)[1];
}
if (f== FunctorLongInt) {
return 2 + sizeof(Float)/sizeof(CELL);
}
@ -3819,6 +3826,10 @@ hash_complex_term(register CELL *pt0,
case (CELL)FunctorLongInt:
*st++ = LongIntOfTerm(d0);
break;
case (CELL)FunctorString:
memcpy(st, RepAppl(d0), (3+RepAppl(d0)[1])*sizeof(CELL));
st += 3+RepAppl(d0)[1];
break;
#ifdef USE_GMP
case (CELL)FunctorBigInt:
{
@ -5498,6 +5509,7 @@ Yap_SkipList(Term *l, Term **tailp)
return length;
}
static Int
p_skip_list( USES_REGS1 ) {
Term *tail;

97
C/write.c
View File

@ -29,6 +29,7 @@ static char SccsId[] = "%W% %G%";
#include "attvar.h"
#endif
#include "pl-shared.h"
#include "pl-utf8.h"
#if HAVE_STRING_H
#include <string.h>
@ -69,7 +70,7 @@ typedef struct rewind_term {
} rwts;
typedef struct write_globs {
void *stream;
IOSTREAM*stream;
int Quote_illegal, Ignore_ops, Handle_vars, Use_portray, Portray_delays;
int Keep_terms;
int Write_Loops;
@ -166,6 +167,35 @@ wrputn(Int n, struct write_globs *wglb) /* writes an integer */
#define wrputs(s, stream) Sfputs(s, stream)
static void
wrpututf8(const char *s, struct write_globs *wglb) /* writes an integer */
{
IOSTREAM *stream = wglb->stream;
if (wglb->Write_strings)
wrputc('`', stream);
else
wrputc('"', stream);
if (stream->encoding == ENC_UTF8) {
wrputs( s, stream);
} else {
int chr;
char *ptr = (char *)s;
do {
ptr = utf8_get_char(ptr, &chr);
if (chr == '\0') break;
wrputc(chr, stream);
} while (TRUE);
}
if (wglb->Write_strings)
wrputc('`', stream);
else
wrputc('"', stream);
}
static void
wrputws(wchar_t *s, wrf stream) /* writes a string */
{
@ -242,8 +272,14 @@ writebig(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, stru
CELL *pt = RepAppl(t)+1;
CELL big_tag = pt[0];
if (big_tag == ARRAY_INT || big_tag == ARRAY_FLOAT) {
wrputc('{', wglb->stream);
wrputs("...", wglb->stream);
wrputc('}', wglb->stream);
lastw = separator;
return;
#ifdef USE_GMP
if (big_tag == BIG_INT)
} else if (big_tag == BIG_INT)
{
MP_INT *big = Yap_BigIntOfTerm(t);
write_mpint(big, wglb);
@ -252,39 +288,7 @@ writebig(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, stru
Term trat = Yap_RatTermToApplTerm(t);
writeTerm(trat, p, depth, rinfixarg, wglb, rwt);
return;
}
#endif
if (big_tag == BLOB_STRING) {
if (wglb->Write_strings)
wrputc('`',wglb->stream);
else
wrputc('"',wglb->stream);
wrputs(Yap_BlobStringOfTerm(t),wglb->stream);
if (wglb->Write_strings)
wrputc('`',wglb->stream);
else
wrputc('"',wglb->stream);
return;
} else if (big_tag == BLOB_WIDE_STRING) {
wchar_t *s = Yap_BlobWideStringOfTerm(t);
if (wglb->Write_strings)
wrputc('`',wglb->stream);
else
wrputc('"', wglb->stream);
while (*s) {
wrputc(*s++, wglb->stream);
}
if (wglb->Write_strings)
wrputc('`',wglb->stream);
else
wrputc('"',wglb->stream);
return;
} else if (big_tag == ARRAY_INT || big_tag == ARRAY_FLOAT) {
wrputc('{', wglb->stream);
wrputs("...", wglb->stream);
wrputc('}', wglb->stream);
lastw = separator;
return;
} else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) {
Opaque_CallOnWrite f;
CELL blob_info;
@ -391,6 +395,21 @@ wrputf(Float f, struct write_globs *wglb) /* writes a float */
protect_close_number(wglb, ob);
}
int
Yap_FormatFloat( Float f, const char *s, size_t sz )
{
struct write_globs wglb;
char *ws = (char *)s;
IOSTREAM *smem = Sopenmem(&ws, &sz, "w");
wglb.stream = smem;
wglb.lw = separator;
wglb.last_atom_minus = FALSE;
wrputf(f, &wglb);
Sclose(smem);
return TRUE;
}
/* writes a data base reference */
static void
wrputref(CODEADDR ref, int Quote_illegal, struct write_globs *wglb)
@ -429,6 +448,7 @@ wrputblob(AtomEntry * ref, int Quote_illegal, struct write_globs *wglb)
wrputs(s, stream);
}
lastw = alphanum;
return 1;
}
static int
@ -599,7 +619,7 @@ putAtom(Atom atom, int Quote_illegal, struct write_globs *wglb)
}
static int
IsStringTerm(Term string) /* checks whether this is a string */
IsCodesTerm(Term string) /* checks whether this is a string */
{
if (IsVarTerm(string))
return FALSE;
@ -888,7 +908,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str
if (Yap_GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
return;
}
if (yap_flags[WRITE_QUOTED_STRING_FLAG] && IsStringTerm(t)) {
if (yap_flags[WRITE_QUOTED_STRING_FLAG] && IsCodesTerm(t)) {
putString(t, wglb);
} else {
wrputc('[', wglb->stream);
@ -909,6 +929,9 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str
case (CELL)FunctorDouble:
wrputf(FloatOfTerm(t),wglb);
return;
case (CELL)FunctorString:
wrpututf8(StringOfTerm(t),wglb);
return;
case (CELL)FunctorAttVar:
write_var(RepAppl(t)+1, wglb, &nrwt);
return;
@ -1099,7 +1122,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str
if (lastw == alphanum) {
wrputc(' ', wglb->stream);
}
if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsStringTerm(ti) || IsAtomTerm(ti))) {
if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsCodesTerm(ti) || IsAtomTerm(ti))) {
if (IsIntTerm(ti)) {
Int k = IntOfTerm(ti);
if (k == -1) {

121
H/TermExt.h
View File

@ -45,18 +45,20 @@ typedef enum
{
db_ref_e = sizeof (Functor *),
attvar_e = 2*sizeof (Functor *),
long_int_e = 3 * sizeof (Functor *),
big_int_e = 4 * sizeof (Functor *),
double_e = 5 * sizeof (Functor *)
double_e = 3 * sizeof (Functor *),
long_int_e = 4 * sizeof (Functor *),
big_int_e = 5 * sizeof (Functor *),
string_e = 6 * sizeof (Functor *)
}
blob_type;
#define FunctorDBRef ((Functor)(db_ref_e))
#define FunctorAttVar ((Functor)(attvar_e))
#define FunctorDouble ((Functor)(double_e))
#define FunctorLongInt ((Functor)(long_int_e))
#define FunctorBigInt ((Functor)(big_int_e))
#define FunctorDouble ((Functor)(double_e))
#define EndSpecials (double_e+sizeof(Functor *))
#define FunctorString ((Functor)(string_e))
#define EndSpecials (string_e+sizeof(Functor *))
#include "inline-only.h"
@ -92,8 +94,6 @@ typedef enum
ARRAY_INT = 0x21,
ARRAY_FLOAT = 0x22,
CLAUSE_LIST = 0x40,
BLOB_STRING = 0x80, /* SWI style strings */
BLOB_WIDE_STRING = 0x81, /* SWI style strings */
EXTERNAL_BLOB = 0x100, /* generic data */
USER_BLOB_START = 0x1000, /* user defined blob */
USER_BLOB_END = 0x1100 /* end of user defined blob */
@ -295,13 +295,6 @@ OOPS
#include <stddef.h>
#endif
Term Yap_MkBlobStringTerm(const char *, size_t len);
Term Yap_MkBlobWideStringTerm(const wchar_t *, size_t len);
char *Yap_BlobStringOfTerm(Term);
wchar_t *Yap_BlobWideStringOfTerm(Term);
char *Yap_BlobStringOfTermAndLength(Term, size_t *);
INLINE_ONLY inline EXTERN int IsFloatTerm (Term);
@ -312,8 +305,6 @@ IsFloatTerm (Term t)
}
/* extern Functor FunctorLongInt; */
#define MkLongIntTerm(i) __MkLongIntTerm((i) PASS_REGS)
@ -350,6 +341,53 @@ IsLongIntTerm (Term t)
}
/****************************************************/
/*********** strings, coded as UTF-8 ****************/
#include <string.h>
/* extern Functor FunctorString; */
#define MkStringTerm(i) __MkStringTerm((i) PASS_REGS)
INLINE_ONLY inline EXTERN Term __MkStringTerm (const char *s USES_REGS);
INLINE_ONLY inline EXTERN Term
__MkStringTerm (const char *s USES_REGS)
{
Term t = AbsAppl(H);
size_t sz = ALIGN_YAPTYPE(strlen(s)+1,CELL);
H[0] = (CELL) FunctorString;
H[1] = (CELL) sz;
strcpy((char *)(H+2), s);
H[2+sz] = EndSpecials;
H += 3+sz;
return t;
}
INLINE_ONLY inline EXTERN const char *StringOfTerm (Term t);
INLINE_ONLY inline EXTERN const char *
StringOfTerm (Term t)
{
return (const char *) (RepAppl (t)+2);
}
INLINE_ONLY inline EXTERN int IsStringTerm (Term);
INLINE_ONLY inline EXTERN int
IsStringTerm (Term t)
{
return (int) (IsApplTerm (t) && FunctorOfTerm (t) == FunctorString);
}
/****************************************************/
#ifdef USE_GMP
@ -438,30 +476,6 @@ IsLargeIntTerm (Term t)
#endif
typedef struct string_struct {
UInt len;
} blob_string_t;
INLINE_ONLY inline EXTERN int IsBlobStringTerm (Term);
INLINE_ONLY inline EXTERN int
IsBlobStringTerm (Term t)
{
return (int) (IsApplTerm (t) &&
FunctorOfTerm (t) == FunctorBigInt &&
(RepAppl(t)[1] & BLOB_STRING) == BLOB_STRING);
}
INLINE_ONLY inline EXTERN int IsWideBlobStringTerm (Term);
INLINE_ONLY inline EXTERN int
IsWideBlobStringTerm (Term t)
{
return (int) (IsApplTerm (t) &&
FunctorOfTerm (t) == FunctorBigInt &&
RepAppl(t)[1] == BLOB_WIDE_STRING);
}
/* extern Functor FunctorLongInt; */
INLINE_ONLY inline EXTERN int IsLargeNumTerm (Term);
@ -470,8 +484,8 @@ INLINE_ONLY inline EXTERN int
IsLargeNumTerm (Term t)
{
return (int) (IsApplTerm (t)
&& ((FunctorOfTerm (t) <= FunctorDouble)
&& (FunctorOfTerm (t) >= FunctorLongInt)));
&& ((FunctorOfTerm (t) <= FunctorBigInt)
&& (FunctorOfTerm (t) >= FunctorDouble)));
}
INLINE_ONLY inline EXTERN int IsExternalBlobTerm (Term, CELL);
@ -523,7 +537,7 @@ INLINE_ONLY inline EXTERN Int IsExtensionFunctor (Functor);
INLINE_ONLY inline EXTERN Int
IsExtensionFunctor (Functor f)
{
return (Int) (f <= FunctorDouble);
return (Int) (f <= FunctorString);
}
@ -533,7 +547,7 @@ INLINE_ONLY inline EXTERN Int IsBlobFunctor (Functor);
INLINE_ONLY inline EXTERN Int
IsBlobFunctor (Functor f)
{
return (Int) ((f <= FunctorDouble && f >= FunctorDBRef));
return (Int) ((f <= FunctorString && f >= FunctorDBRef));
}
@ -665,6 +679,8 @@ unify_extension (Functor f, CELL d0, CELL * pt0, CELL d1)
return (d0 == d1);
case long_int_e:
return (pt0[1] == RepAppl (d1)[1]);
case string_e:
return strcmp( (char *)pt0[2], (char *)RepAppl (d1)[2] ) == 0;
case big_int_e:
#ifdef USE_GMP
return (Yap_gmp_tcmp_big_big(d0,d1) == 0);
@ -721,4 +737,21 @@ CELL Yap_Double_key(Term t)
return Yap_DoubleP_key(RepAppl(t)+1);
}
static inline
CELL Yap_StringP_key(CELL *pt)
{
UInt n = pt[1], i;
CELL val = pt[2];
for (i=1; i<n; i++) {
val ^= pt[i+1];
}
return MkIntTerm(val & (MAX_ABS_INT-1));
}
static inline
CELL Yap_String_key(Term t)
{
return Yap_StringP_key(RepAppl(t)+1);
}
#endif

1
H/Yap.h
View File

@ -230,7 +230,6 @@ typedef char *ADDR;
typedef CELL OFFSET;
typedef unsigned char *CODEADDR;
#define ALIGN_YAPTYPE(X,TYPE) (((CELL)(X)+(sizeof(TYPE)-1)) & ~(sizeof(TYPE)-1))
#define TermPtr(V) ((Term *) (V))
#define Addr(V) ((ADDR) (V))

3
H/YapOpcodes.h
View File

@ -76,6 +76,7 @@
OPCODE(get_list ,x),
OPCODE(get_struct ,xfa),
OPCODE(get_float ,xd),
OPCODE(get_string ,xu),
OPCODE(get_longint ,xi),
OPCODE(get_bigint ,xN),
OPCODE(get_dbterm ,xD),
@ -131,6 +132,8 @@
OPCODE(unify_float_write ,od),
OPCODE(unify_l_float ,od),
OPCODE(unify_l_float_write ,od),
OPCODE(unify_string ,ou),
OPCODE(unify_l_string ,ou),
OPCODE(unify_longint ,oi),
OPCODE(unify_longint_write ,oi),
OPCODE(unify_l_longint ,oi),

3
H/YapTerm.h
View File

@ -21,6 +21,9 @@ typedef void *Atom;
#endif
#define ALIGN_YAPTYPE(X,TYPE) (((CELL)(X)+(sizeof(TYPE)-1)) & ~(sizeof(TYPE)-1))
#ifndef EXTERN
#define EXTERN extern
#endif

20
H/Yapproto.h
View File

@ -26,6 +26,8 @@ Term Yap_GetValue(Atom);
int Yap_HasOp(Atom);
struct operator_entry *Yap_GetOpPropForAModuleHavingALock(AtomEntry *, Term);
Atom Yap_LookupAtom(char *);
Atom Yap_LookupAtomWithLength(char *, size_t);
Atom Yap_LookupUTF8Atom(char *);
Atom Yap_LookupMaybeWideAtom(wchar_t *);
Atom Yap_LookupMaybeWideAtomWithLength(wchar_t *, size_t);
Atom Yap_FullLookupAtom(char *);
@ -39,19 +41,6 @@ Functor Yap_MkFunctor(Atom,unsigned int);
void Yap_MkFunctorWithAddress(Atom,unsigned int,FunctorEntry *);
void Yap_PutValue(Atom,Term);
void Yap_ReleaseAtom(Atom);
Term Yap_StringToList(char *);
Term Yap_NStringToList(char *, size_t);
Term Yap_WideStringToList(wchar_t *);
Term Yap_NWideStringToList(wchar_t *, size_t);
Term Yap_StringToDiffList(char *,Term CACHE_TYPE);
Term Yap_NStringToDiffList(char *,Term, size_t);
Term Yap_WideStringToDiffList(wchar_t *,Term);
Term Yap_NWideStringToDiffList(wchar_t *,Term, size_t);
Term Yap_StringToListOfAtoms(char *);
Term Yap_NStringToListOfAtoms(char *, size_t);
Term Yap_WideStringToListOfAtoms(wchar_t *);
Term Yap_NWideStringToListOfAtoms(wchar_t *, size_t);
Term Yap_NWideStringToDiffListOfAtoms(wchar_t *, Term, size_t);
int Yap_AtomIncreaseHold(Atom);
int Yap_AtomDecreaseHold(Atom);
struct operator_entry *Yap_OpPropForModule(Atom, Term);
@ -169,6 +158,8 @@ void Yap_RestartYap(int);
void Yap_exit(int);
yamop *Yap_Error(yap_error_number,Term,char *msg, ...);
yamop *Yap_NilError(yap_error_number,char *msg, ...);
int Yap_HandleError( const char *msg, ... );
int Yap_SWIHandleError( const char *, ... );
/* eval.c */
void Yap_InitEval(void);
@ -348,6 +339,7 @@ void Yap_InitSignalCPreds(void);
/* sort.c */
void Yap_InitSortPreds(void);
/* stdpreds.c */
void Yap_InitBackCPreds(void);
void Yap_InitCPreds(void);
@ -430,7 +422,7 @@ Int Yap_SkipList(Term *, Term **);
/* write.c */
void Yap_plwrite(Term, void *, int, int, int);
int Yap_FormatFloat( Float f, const char *s, size_t sz );
/* MYDDAS */

11
H/amidefs.h
View File

@ -273,6 +273,7 @@ typedef enum {
p: predicate, struct pred_entry *
s: small integer, COUNT
t: pointer to table entry, used by yaptab, struct table_entry *
u: utf-8 string
x: wam register, wamreg
y: environment slot
@ -558,6 +559,11 @@ typedef struct yami {
COUNT s;
CELL next;
} os;
struct {
OPCODE opcw;
Term u;
CELL next;
} ou;
struct {
OPCODE opcw;
wamreg x;
@ -783,6 +789,11 @@ typedef struct yami {
wamreg xr;
CELL next;
} xx;
struct {
wamreg x;
Term u;
CELL next;
} xu;
struct {
wamreg x;
wamreg xi;

7
H/compile.h
View File

@ -34,6 +34,8 @@ typedef enum compiler_op {
put_dbterm_op,
get_longint_op,
put_longint_op,
get_string_op,
put_string_op,
get_bigint_op,
put_bigint_op,
get_list_op,
@ -55,6 +57,8 @@ typedef enum compiler_op {
write_dbterm_op,
unify_longint_op,
write_longint_op,
unify_string_op,
write_string_op,
unify_bigint_op,
write_bigint_op,
unify_list_op,
@ -76,6 +80,7 @@ typedef enum compiler_op {
unify_last_float_op,
unify_last_dbterm_op,
unify_last_longint_op,
unify_last_string_op,
unify_last_bigint_op,
ensure_space_op,
native_op,
@ -126,6 +131,7 @@ typedef enum compiler_op {
if_not_op,
index_dbref_op,
index_blob_op,
index_string_op,
index_long_op,
if_nonvar_op,
save_pair_op,
@ -182,6 +188,7 @@ typedef enum compiler_op {
fetch_args_for_bccall,
bccall_op,
blob_op,
string_op,
label_ctl_op
#ifdef SFUNC
,

2
H/dlocals.h
View File

@ -417,4 +417,6 @@
#define REMOTE_CurSlot(wid) REMOTE(wid)->CurSlot_
#define LOCAL_SourceModule LOCAL->SourceModule_
#define REMOTE_SourceModule(wid) REMOTE(wid)->SourceModule_
#define LOCAL_MAX_SIZE LOCAL->MAX_SIZE_
#define REMOTE_MAX_SIZE(wid) REMOTE(wid)->MAX_SIZE_

2
H/eval.h
View File

@ -233,6 +233,8 @@ ETypeOfTerm(Term t)
}
#if USE_GMP
char *Yap_mpz_to_string(MP_INT *b, char *s, size_t sz, int base);
Term Yap_gmq_rdiv_int_int(Int, Int);
Term Yap_gmq_rdiv_int_big(Int, Term);
Term Yap_gmq_rdiv_big_int(Term, Int);

14
H/findclause.h
View File

@ -409,6 +409,12 @@
case _unify_n_atoms_write:
cl = NEXTOP(cl,osc);
break;
case _unify_l_string:
cl = NEXTOP(cl,ou);
break;
case _unify_string:
cl = NEXTOP(cl,ou);
break;
case _save_appl_x:
if (!(nofregs = delete_regcopy(myregs, nofregs, cl->u.ox.x))) {
clause->Tag = (CELL)NULL;
@ -873,6 +879,14 @@
}
cl = NEXTOP(cl,xl);
break;
case _get_string:
if (is_regcopy(myregs, nofregs, cl->u.xu.x)) {
clause->Tag = AbsAppl((CELL *)FunctorString);
clause->u.t_ptr = (CELL)NULL;
return;
}
cl = NEXTOP(cl,xu);
break;
case _get_x_val:
if (!(nofregs = link_regcopies(myregs, nofregs, cl->u.xx.xl, cl->u.xx.xr))) {
clause->Tag = (CELL)NULL;

14
H/headclause.h
View File

@ -376,6 +376,12 @@
case _unify_n_atoms_write:
cl = NEXTOP(cl,osc);
break;
case _unify_l_string:
cl = NEXTOP(cl,ou);
break;
case _unify_string:
cl = NEXTOP(cl,ou);
break;
case _save_appl_x:
if (iarg == cl->u.ox.x) {
clause->Tag = (CELL)NULL;
@ -652,6 +658,14 @@
}
cl = NEXTOP(cl,xi);
break;
case _get_string:
if (iarg == cl->u.xu.x) {
clause->Tag = AbsAppl((CELL *)FunctorString);
clause->u.t_ptr = (CELL)NULL;
return;
}
cl = NEXTOP(cl,xu);
break;
case _get_x_val:
if (cl->u.xx.xl == iarg ||
cl->u.xx.xr == iarg) {

1
H/hlocals.h
View File

@ -235,4 +235,5 @@ typedef struct worker_local {
Int CurSlot_;
Term SourceModule_;
size_t MAX_SIZE_;
} w_local;

2
H/iatoms.h
View File

@ -34,6 +34,7 @@
AtomBatched = Yap_LookupAtom("batched");
AtomBetween = Yap_LookupAtom("between");
AtomHugeInt = Yap_LookupAtom("huge_int");
AtomBigNum = Yap_LookupAtom("big_num");
AtomBinaryStream = Yap_LookupAtom("binary_stream");
AtomBraces = Yap_LookupAtom("{}");
AtomBreak = Yap_FullLookupAtom("$break");
@ -296,6 +297,7 @@
AtomStreamPos = Yap_FullLookupAtom("$stream_position");
AtomStreamPosition = Yap_LookupAtom("stream_position");
AtomString = Yap_LookupAtom("string");
AtomSTRING = Yap_FullLookupAtom("String");
AtomSwi = Yap_LookupAtom("swi");
AtomSyntaxError = Yap_LookupAtom("syntax_error");
AtomSyntaxErrorHandler = Yap_LookupAtom("syntax_error_handler");

1
H/ilocals.h
View File

@ -235,4 +235,5 @@ static void InitWorker(int wid) {
REMOTE_CurSlot(wid) = 0;
REMOTE_SourceModule(wid) = 0;
REMOTE_MAX_SIZE(wid) = 1024L;
}

1
H/iopreds.h
View File

@ -54,3 +54,4 @@ typedef int (*GetsFunc)(int, UInt, char *);
void Yap_InitStdStreams(void);
Term Yap_StreamPosition(struct io_stream *);
void Yap_InitPlIO(void);

2
H/pl-incl.h
View File

@ -511,7 +511,6 @@ typedef struct wakeup_state
Defining built-in predicates using the new interface
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define EOS '\0'
#define ESC ((char) 27)
#define streq(s, q) ((strcmp((s), (q)) == 0))
@ -726,7 +725,6 @@ extern atom_t lookupUCSAtom(const pl_wchar_t *s, size_t len);
extern int toIntegerNumber(Number n, int flags);
extern int get_atom_ptr_text(Atom a, PL_chars_t *text);
extern int warning(const char *fm, ...);
extern int raiseSignal(PL_local_data_t *ld, int sig);
/**** stuff from pl-files.c ****/
void initFiles(void);

27
H/pl-shared.h
View File

@ -141,6 +141,8 @@ typedef struct redir_context
#include "pl-file.h"
#define EOS '\0'
/********************************
* HASH TABLES *
*********************************/
@ -264,7 +266,30 @@ COMMON(int) debugmode(debug_type new, debug_type *old);
COMMON(int) tracemode(debug_type new, debug_type *old);
COMMON(void) Yap_setCurrentSourceLocation(IOSTREAM **s);
#define SWIAtomToAtom(X) SWI_Atoms[(X)>>1]
extern int raiseSignal(PL_local_data_t *ld, int sig);
#ifdef YATOM_H
static inline atom_t
AtomToSWIAtom(Atom at)
{
TranslationEntry *p;
if ((p = Yap_GetTranslationProp(at)) != NULL)
return (atom_t)(p->Translation*2+1);
return (atom_t)at;
}
#endif
static inline Atom
SWIAtomToAtom(atom_t at)
{
if ((CELL)at & 1)
return SWI_Atoms[at/2];
return (Atom)at;
}
Atom YAP_AtomFromSWIAtom(atom_t at);
atom_t YAP_SWIAtomFromAtom(Atom at);

2
H/pl-yap.h
View File

@ -124,7 +124,7 @@ void PL_license(const char *license, const char *module);
#define stringAtom(w) (YAP_AtomFromSWIAtom(w)->StrOfAE)
#define isInteger(A) (!IsVarTerm(A) && ( IsIntegerTerm((A)) || YAP_IsBigNumTerm((A)) ))
#define isString(A) (!IsVarTerm(A) && Yap_IsStringTerm(A) )
#define isString(A) (!IsVarTerm(A) && IsStringTerm(A) )
#define isAtom(A) (!IsVarTerm(A) && IsAtomTerm((A)) )
#define isList(A) (!IsVarTerm(A) && IsPairTerm((A)) )
#define isNil(A) ((A) == TermNil)

2
H/ratoms.h
View File

@ -34,6 +34,7 @@
AtomBatched = AtomAdjust(AtomBatched);
AtomBetween = AtomAdjust(AtomBetween);
AtomHugeInt = AtomAdjust(AtomHugeInt);
AtomBigNum = AtomAdjust(AtomBigNum);
AtomBinaryStream = AtomAdjust(AtomBinaryStream);
AtomBraces = AtomAdjust(AtomBraces);
AtomBreak = AtomAdjust(AtomBreak);
@ -296,6 +297,7 @@
AtomStreamPos = AtomAdjust(AtomStreamPos);
AtomStreamPosition = AtomAdjust(AtomStreamPosition);
AtomString = AtomAdjust(AtomString);
AtomSTRING = AtomAdjust(AtomSTRING);
AtomSwi = AtomAdjust(AtomSwi);
AtomSyntaxError = AtomAdjust(AtomSyntaxError);
AtomSyntaxErrorHandler = AtomAdjust(AtomSyntaxErrorHandler);

13
H/rclause.h
View File

@ -389,6 +389,13 @@ restore_opcodes(yamop *pc, yamop *max USES_REGS)
pc->u.osc.c = ConstantTermAdjust(pc->u.osc.c);
pc = NEXTOP(pc,osc);
break;
/* instructions type ou */
case _unify_l_string:
case _unify_string:
pc->u.ou.opcw = OpcodeAdjust(pc->u.ou.opcw);
pc->u.ou.u = BlobTermInCodeAdjust(pc->u.ou.u);
pc = NEXTOP(pc,ou);
break;
/* instructions type ox */
case _save_appl_x:
case _save_appl_x_write:
@ -637,6 +644,12 @@ restore_opcodes(yamop *pc, yamop *max USES_REGS)
pc->u.xps.s = ConstantAdjust(pc->u.xps.s);
pc = NEXTOP(pc,xps);
break;
/* instructions type xu */
case _get_string:
pc->u.xu.x = XAdjust(pc->u.xu.x);
pc->u.xu.u = BlobTermInCodeAdjust(pc->u.xu.u);
pc = NEXTOP(pc,xu);
break;
/* instructions type xx */
case _get_x_val:
case _get_x_var:

1
H/rlocals.h
View File

@ -233,6 +233,7 @@ static void RestoreWorker(int wid USES_REGS) {
}

13
H/saveclause.h
View File

@ -406,6 +406,13 @@
CHECK(save_ConstantTerm(stream, pc->u.osc.c));
pc = NEXTOP(pc,osc);
break;
/* instructions type ou */
case _unify_l_string:
case _unify_string:
CHECK(save_Opcode(stream, pc->u.ou.opcw));
CHECK(save_BlobTermInCode(stream, pc->u.ou.u));
pc = NEXTOP(pc,ou);
break;
/* instructions type ox */
case _save_appl_x:
case _save_appl_x_write:
@ -653,6 +660,12 @@
CHECK(save_Constant(stream, pc->u.xps.s));
pc = NEXTOP(pc,xps);
break;
/* instructions type xu */
case _get_string:
CHECK(save_X(stream, pc->u.xu.x));
CHECK(save_BlobTermInCode(stream, pc->u.xu.u));
pc = NEXTOP(pc,xu);
break;
/* instructions type xx */
case _get_x_val:
case _get_x_var:

4
H/tatoms.h
View File

@ -66,6 +66,8 @@
#define AtomBetween Yap_heap_regs->AtomBetween_
Atom AtomHugeInt_;
#define AtomHugeInt Yap_heap_regs->AtomHugeInt_
Atom AtomBigNum_;
#define AtomBigNum Yap_heap_regs->AtomBigNum_
Atom AtomBinaryStream_;
#define AtomBinaryStream Yap_heap_regs->AtomBinaryStream_
Atom AtomBraces_;
@ -590,6 +592,8 @@
#define AtomStreamPosition Yap_heap_regs->AtomStreamPosition_
Atom AtomString_;
#define AtomString Yap_heap_regs->AtomString_
Atom AtomSTRING_;
#define AtomSTRING Yap_heap_regs->AtomSTRING_
Atom AtomSwi_;
#define AtomSwi Yap_heap_regs->AtomSwi_
Atom AtomSyntaxError_;

9
H/walkclause.h
View File

@ -293,6 +293,11 @@
case _unify_n_atoms_write:
pc = NEXTOP(pc,osc);
break;
/* instructions type ou */
case _unify_l_string:
case _unify_string:
pc = NEXTOP(pc,ou);
break;
/* instructions type ox */
case _save_appl_x:
case _save_appl_x_write:
@ -478,6 +483,10 @@
case _commit_b_x:
pc = NEXTOP(pc,xps);
break;
/* instructions type xu */
case _get_string:
pc = NEXTOP(pc,xu);
break;
/* instructions type xx */
case _get_x_val:
case _get_x_var:

6
Makefile.in
View File

@ -189,6 +189,7 @@ HEADERS = \
$(srcdir)/H/tracer.h \
$(srcdir)/H/trim_trail.h \
$(srcdir)/H/yapio.h \
$(srcdir)/H/YapMirrorn.h \
$(srcdir)/BEAM/eam.h $(srcdir)/BEAM/eamamasm.h \
$(srcdir)/OPTYap/opt.config.h \
$(srcdir)/OPTYap/opt.proto.h $(srcdir)/OPTYap/opt.structs.h \
@ -227,7 +228,7 @@ IOLIB_SOURCES=$(srcdir)/os/pl-buffer.c $(srcdir)/os/pl-ctype.c \
$(srcdir)/os/pl-tai.c \
$(srcdir)/os/pl-text.c \
$(srcdir)/os/pl-version.c \
$(srcdir)/os/pl-write.c \
$(srcdir)/os/pl-write.c \
$(srcdir)/C/pl-yap.c @ENABLE_WINCONSOLE@$(srcdir)/os/windows/uxnt.c
C_SOURCES= \
@ -262,6 +263,7 @@ C_SOURCES= \
$(srcdir)/C/qlyw.c \
$(srcdir)/C/range.c \
$(srcdir)/C/save.c $(srcdir)/C/scanner.c $(srcdir)/C/signals.c \
$(srcdir)/C/strings.c \
$(srcdir)/C/sort.c $(srcdir)/C/stdpreds.c $(srcdir)/C/sysbits.c \
$(srcdir)/C/threads.c \
$(srcdir)/C/tracer.c $(srcdir)/C/unify.c $(srcdir)/C/userpreds.c \
@ -370,7 +372,7 @@ ENGINE_OBJECTS = \
myddas_util.o myddas_statistics.o myddas_top_level.o \
myddas_wkb2prolog.o modules.o other.o \
parser.o qlyr.o qlyw.o range.o \
save.o scanner.o signals.o sort.o stdpreds.o \
save.o scanner.o signals.o strings.o sort.o stdpreds.o \
sysbits.o threads.o tracer.o \
udi.o\
unify.o userpreds.o utilpreds.o \

63
include/YapError.h
View File

@ -98,6 +98,7 @@ typedef enum
TYPE_ERROR_ARRAY,
TYPE_ERROR_ATOM,
TYPE_ERROR_ATOMIC,
TYPE_ERROR_BIGNUM,
TYPE_ERROR_BYTE,
TYPE_ERROR_CALLABLE,
TYPE_ERROR_CHAR,
@ -120,5 +121,67 @@ typedef enum
UNKNOWN_ERROR
} yap_error_number;
#define LOCAL_ERROR(v) \
if (H + 2*(v) > ASP-1024) { \
LOCAL_Error_TYPE = OUT_OF_STACK_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = 2*(v)*sizeof(CELL);\
return 0L; \
}
#define JMP_LOCAL_ERROR(v, LAB) \
if (H + 2*(v) > ASP-1024) { \
LOCAL_Error_TYPE = OUT_OF_STACK_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = 2*(v)*sizeof(CELL);\
goto LAB; \
}
#define AUX_ERROR(t, n, s, TYPE) \
if (s + (n+1) > (TYPE *)AuxSp) { \
LOCAL_Error_TYPE = OUT_OF_AUXSPACE_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = n*sizeof(TYPE);\
return NULL; \
}
#define AUX_TERM_ERROR(t, n, s, TYPE) \
if (s + (n+1) > (TYPE *)AuxSp) { \
LOCAL_Error_TYPE = OUT_OF_AUXSPACE_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = n*sizeof(TYPE);\
return 0L; \
}
#define JMP_AUX_ERROR(n, s, t, TYPE, LAB) \
if (s + (n+1) > (TYPE *)AuxSp) { \
LOCAL_Error_TYPE = OUT_OF_AUXSPACE_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = n*sizeof(TYPE);\
goto LAB; \
}
#define HEAP_ERROR(a,TYPE) if( a == NIL) { \
LOCAL_Error_TYPE = OUT_OF_HEAP_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = n*sizeof(TYPE);\
return NULL;\
}
#define HEAP_TERM_ERROR(a,TYPE) if( a == NIL) { \
LOCAL_Error_TYPE = OUT_OF_HEAP_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = n*sizeof(TYPE);\
return 0L;\
}
#define JMP_HEAP_ERROR(a,n,t,TYPE, LAB) if( a == NIL) { \
LOCAL_Error_TYPE = OUT_OF_HEAP_ERROR;\
LOCAL_Error_Term = t;\
LOCAL_Error_Size = n*sizeof(TYPE);\
goto LAB;\
}
#endif

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

@ -24,7 +24,7 @@
#define _WITH_DPRINTF
#include <stdio.h>
#include <SWI-Prolog.h>
#include <pl-shared.h>
#include "swi.h"
@ -113,10 +113,10 @@ lookupBlob(void *blob, size_t len, PL_blob_t *type, int *new)
ae->rep.blob->length = len;
memcpy(ae->rep.blob->data, blob, len);
SWI_Blobs = ae;
UNLOCK(SWI_Blobs_Lock);
if (NOfBlobs > NOfBlobsMax) {
Yap_signal(YAP_CDOVF_SIGNAL);
}
UNLOCK(SWI_Blobs_Lock);
return ae;
}

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

@ -36,10 +36,10 @@
#define PL_KERNEL 1
#include <SWI-Stream.h>
#include <SWI-Prolog.h>
#include <pl-shared.h>
#include <yapio.h>
#include <YapMirror.h>
#ifdef USE_GMP
#include <gmp.h>
@ -352,6 +352,19 @@ X_API int PL_get_float(term_t ts, double *f) /* SAM type check*/
return 1;
}
X_API int PL_get_string_chars(term_t t, char **s, size_t *len)
{
CACHE_REGS
Term tt = Yap_GetFromSlot(t PASS_REGS);
if (!IsStringTerm(tt)) {
return 0;
}
*s = (char *)StringOfTerm(tt);
*len = utf8_strlen(*s, strlen(*s));
return TRUE;
}
X_API int PL_get_head(term_t ts, term_t h)
{
CACHE_REGS
@ -368,18 +381,6 @@ X_API int PL_get_string(term_t t, char **s, size_t *len)
return PL_get_string_chars(t, s, len);
}
X_API int PL_get_string_chars(term_t t, char **s, size_t *len)
{
CACHE_REGS
Term tt = Yap_GetFromSlot(t PASS_REGS);
if (!IsBlobStringTerm(tt)) {
return 0;
}
*s = Yap_BlobStringOfTermAndLength(tt, len);
return TRUE;
}
/* 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)
@ -624,103 +625,47 @@ X_API int PL_get_tail(term_t ts, term_t tl)
*/
X_API atom_t PL_new_atom(const char *c)
{
CACHE_REGS
Atom at;
while ((at = Yap_LookupAtom((char *)c)) == NULL) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return 0L;
}
atom_t sat;
while((at = Yap_CharsToAtom(c PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_new_atom" ))
return FALSE;
}
Yap_AtomIncreaseHold(at);
return AtomToSWIAtom(at);
sat = AtomToSWIAtom(at);
return sat;
}
X_API atom_t PL_new_atom_nchars(size_t len, const char *c)
{
CACHE_REGS
Atom at;
char *pt;
if (strlen(c) > len) {
while ((pt = (char *)Yap_AllocCodeSpace(len+1)) == NULL) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return 0L;
}
}
memcpy(pt, c, len);
pt[len] = '\0';
} else {
pt = (char *)c;
}
while ((at = Yap_LookupAtom(pt)) == NULL) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return 0L;
}
atom_t sat;
while((at = Yap_NCharsToAtom(c, len PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_new_atom_nchars" ))
return FALSE;
}
Yap_AtomIncreaseHold(at);
return AtomToSWIAtom(at);
sat = AtomToSWIAtom(at);
return sat;
}
X_API atom_t PL_new_atom_wchars(size_t len, const wchar_t *c)
{
atom_t at;
int i;
CACHE_REGS
Atom at;
atom_t sat;
for (i=0;i<len;i++) {
if (c[i] > 255) break;
while((at = Yap_NWCharsToAtom(c, len PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_new_atom_wchars" ))
return FALSE;
}
if (i!=len) {
Atom at0;
wchar_t *nbf;
while (!(nbf = (wchar_t *)YAP_AllocSpaceFromYap((len+1)*sizeof(wchar_t)))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return 0;
}
}
for (i=0;i<len;i++)
nbf[i] = c[i];
nbf[len]='\0';
while ((at0 = Yap_LookupWideAtom(nbf)) == NULL) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return 0L;
}
}
at = AtomToSWIAtom(at0);
Yap_AtomIncreaseHold(at0);
YAP_FreeSpaceFromYap(nbf);
} else {
char *nbf;
Atom at0;
while (!(nbf = (char *)YAP_AllocSpaceFromYap((len+1)*sizeof(char)))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return 0;
}
}
for (i=0;i<len;i++)
nbf[i] = c[i];
nbf[len]='\0';
while (!(at0 = Yap_LookupAtom(nbf))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return 0;
}
}
at = AtomToSWIAtom(at0);
Yap_AtomIncreaseHold(at0);
YAP_FreeSpaceFromYap(nbf);
}
return at;
Yap_AtomIncreaseHold(at);
sat = AtomToSWIAtom(at);
return sat;
}
X_API wchar_t *PL_atom_wchars(atom_t name, size_t *sp)
@ -855,12 +800,9 @@ X_API int PL_put_atom_chars(term_t t, const char *s)
{
CACHE_REGS
Atom at;
if (!(at = Yap_LookupAtom((char *)s))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
while((at = Yap_CharsToAtom(s PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_atom_nchars" ))
return FALSE;
}
}
Yap_AtomIncreaseHold(at);
Yap_PutInSlot(t,MkAtomTerm(at) PASS_REGS);
@ -871,25 +813,9 @@ X_API int PL_put_atom_nchars(term_t t, size_t len, const char *s)
{
CACHE_REGS
Atom at;
char *buf;
if (strlen(s) > len) {
while (!(buf = (char *)Yap_AllocCodeSpace(len+1))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
memcpy(buf, s, len);
buf[len] = 0;
} else {
buf = (char *)s;
}
while (!(at = Yap_LookupAtom(buf))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
while((at = Yap_NCharsToAtom(s, len PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_atom_nchars" ))
return FALSE;
}
}
Yap_AtomIncreaseHold(at);
Yap_PutInSlot(t,MkAtomTerm(at) PASS_REGS);
@ -973,12 +899,12 @@ X_API int PL_put_list(term_t t)
X_API int PL_put_list_chars(term_t t, const char *s)
{
CACHE_REGS
Yap_PutInSlot(t,YAP_BufferToString((char *)s) PASS_REGS);
if (Unsigned(H) > Unsigned(ASP)-CreepFlag) {
if (!do_gc(0)) {
Term nt;
while((nt = Yap_CharsToListOfAtoms(s PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_put_string_nchars" ))
return FALSE;
}
}
Yap_PutInSlot(t, nt PASS_REGS);
return TRUE;
}
@ -1002,11 +928,12 @@ X_API int PL_put_pointer(term_t t, void *ptr)
X_API int PL_put_string_nchars(term_t t, size_t len, const char *chars)
{
CACHE_REGS
Term tt;
if ((tt = Yap_MkBlobStringTerm(chars, len)) == TermNil)
return FALSE;
Yap_PutInSlot(t,tt PASS_REGS);
Term nt;
while((nt = Yap_NCharsToString(chars, len PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_put_string_nchars" ))
return FALSE;
}
Yap_PutInSlot(t, nt PASS_REGS);
return TRUE;
}
@ -1084,17 +1011,13 @@ X_API int PL_unify_atom(term_t t, atom_t at)
X_API int PL_unify_atom_chars(term_t t, const char *s)
{
CACHE_REGS
Atom catom;
Term cterm;
while (!(catom = Yap_LookupAtom((char *)s))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
Atom at;
while((at = Yap_CharsToAtom(s PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_atom_nchars" ))
return FALSE;
}
}
Yap_AtomIncreaseHold(catom);
cterm = MkAtomTerm(catom);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS),cterm);
Yap_AtomIncreaseHold(at);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), MkAtomTerm(at));
}
/* SWI: int PL_unify_atom_chars(term_t ?t, const char *chars)
@ -1102,24 +1025,13 @@ X_API int PL_unify_atom_chars(term_t t, const char *s)
X_API int PL_unify_atom_nchars(term_t t, size_t len, const char *s)
{
CACHE_REGS
Atom catom;
YAP_Term cterm;
char *buf = (char *)malloc(len+1);
if (!buf)
return FALSE;
memcpy(buf, s, len);
buf[len] = '\0';
while (!(catom = Yap_LookupAtom(buf))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
Atom at;
while((at = Yap_NCharsToAtom(s, len PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_atom_nchars" ))
return FALSE;
}
}
free(buf);
Yap_AtomIncreaseHold(catom);
cterm = MkAtomTerm(catom);
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS),cterm);
Yap_AtomIncreaseHold(at);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), MkAtomTerm(at));
}
/* SWI: int PL_unify_float(term_t ?t, double f)
@ -1252,14 +1164,12 @@ X_API int PL_unify_arg(int index, term_t tt, term_t arg)
X_API int PL_unify_list_chars(term_t t, const char *chars)
{
CACHE_REGS
YAP_Term chterm;
if (Unsigned(H) > Unsigned(ASP)-CreepFlag) {
if (!do_gc(0)) {
Term chterm;
while((chterm = Yap_CharsToListOfAtoms(chars PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_list_chars" ))
return FALSE;
}
}
chterm = YAP_BufferToString((char *)chars);
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS), chterm);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
/* SWI: int PL_unify_list(term_t ?t, term_t +h, term_t -t)
@ -1268,27 +1178,31 @@ X_API int PL_unify_list_ncodes(term_t t, size_t len, const char *chars)
{
CACHE_REGS
Term chterm;
if (Unsigned(H) > Unsigned(ASP+len*2)-CreepFlag) {
if (!do_gc(0)) {
while((chterm = Yap_NCharsToListOfCodes(chars, len PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_list_ncodes" ))
return FALSE;
}
}
chterm = Yap_NStringToList((char *)chars, len);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
X_API int
PL_unify_list_codes(term_t l, const char *chars)
{ return PL_unify_list_ncodes(l, strlen(chars), chars);
PL_unify_list_codes(term_t t, const char *chars)
{
CACHE_REGS
Term chterm;
while((chterm = Yap_CharsToListOfCodes(chars PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_list_codes" ))
return FALSE;
}
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), 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)
X_API int PL_unify_nil(term_t t)
{
CACHE_REGS
YAP_Term nilterm = TermNil;
return YAP_Unify(Yap_GetFromSlot(l PASS_REGS), nilterm);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), TermNil);
}
/* SWI: int PL_unify_pointer(term_t ?t, void *ptr)
@ -1306,28 +1220,23 @@ X_API int PL_unify_pointer(term_t t, void *ptr)
X_API int PL_unify_string_chars(term_t t, const char *chars)
{
CACHE_REGS
YAP_Term chterm;
if (Unsigned(H) > Unsigned(ASP)-CreepFlag) {
if (!do_gc(0)) {
Term chterm;
while((chterm = Yap_CharsToString(chars PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_list_ncodes" ))
return FALSE;
}
}
chterm = YAP_BufferToString((char *)chars);
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS), chterm);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
X_API int PL_unify_string_nchars(term_t t, size_t len, const char *chars)
{
CACHE_REGS
YAP_Term chterm;
if (Unsigned(H) > Unsigned(ASP)-CreepFlag) {
if (!do_gc(0)) {
Term chterm;
while((chterm = Yap_NCharsToString(chars, len PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_list_ncodes" ))
return FALSE;
}
}
chterm = YAP_NBufferToString((char *)chars, len);
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS), chterm);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
/* SWI: int PL_unify_wchars(term_t ?t, int type, size_t len,, const pl_wchar_t *s)
@ -1337,43 +1246,42 @@ X_API int PL_unify_wchars(term_t t, int type, size_t len, const pl_wchar_t *char
CACHE_REGS
YAP_Term chterm;
if (len == (size_t)-1)
len = wcslen(chars);
if (Unsigned(H) > Unsigned(ASP)-CreepFlag) {
if (!do_gc(0)) return FALSE;
}
switch (type) {
case PL_ATOM:
while (TRUE) {
switch (type) {
case PL_ATOM:
{
Atom at;
while ((at = Yap_LookupMaybeWideAtomWithLength((wchar_t *)chars, len)) == NULL) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
at = Yap_NWCharsToAtom(chars, len PASS_REGS);
if (at) {
Yap_AtomIncreaseHold(at);
chterm = MkAtomTerm(at);
return Yap_unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
Yap_AtomIncreaseHold(at);
chterm = MkAtomTerm(at);
}
break;
case PL_STRING:
chterm = Yap_MkBlobWideStringTerm(chars, len);
break;
case PL_UTF8_STRING:
chterm = Yap_MkBlobWideStringTerm(chars, len);
break;
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;
case PL_UTF8_STRING:
case PL_STRING:
if ((chterm = Yap_NWCharsToString(chars, len PASS_REGS)) != 0) {
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
break;
case PL_CODE_LIST:
if ((chterm = Yap_NWCharsToListOfCodes(chars, len PASS_REGS)) != 0) {
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
break;
case PL_CHAR_LIST:
if ((chterm = Yap_NWCharsToListOfAtoms(chars, len PASS_REGS)) != 0) {
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
break;
default:
/* should give error?? */
return FALSE;
}
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_wchars" ))
return FALSE;
}
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS), chterm);
}
typedef struct {
@ -1399,52 +1307,6 @@ typedef struct {
} arg;
} arg_types;
static Atom
LookupMaxAtom(size_t n, char *s)
{
CACHE_REGS
Atom catom;
char *buf = (char *)Yap_AllocCodeSpace(n+1);
if (!buf)
return FALSE;
memcpy(buf, s, n);
buf[n] = '\0';
while (!(catom = Yap_LookupAtom(buf))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return NULL;
}
}
Yap_AtomIncreaseHold(catom);
Yap_FreeCodeSpace(buf);
return catom;
}
static Atom
LookupMaxWideAtom(size_t n, wchar_t *s)
{
Atom catom;
size_t sz = wcslen(s);
wchar_t *buf;
if (sz+1 < n) n = sz+1;
buf = (wchar_t *)Yap_AllocCodeSpace((n+1)*sizeof(wchar_t));
if (!buf)
return FALSE;
wcsncpy(buf, s, n);
buf[n] = '\0';
while (!(catom = Yap_LookupMaybeWideAtom(buf))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
CACHE_REGS
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return NULL;
}
}
Yap_AtomIncreaseHold(catom);
Yap_FreeAtomSpace((ADDR)buf);
return catom;
}
static YAP_Term
MkBoolTerm(int b)
@ -1511,33 +1373,52 @@ int PL_unify_termv(term_t l, va_list ap)
*pt++ = MkFloatTerm(va_arg(ap, double));
break;
case PL_STRING:
*pt++ = Yap_MkBlobStringTerm(va_arg(ap, char *), -1);
{
Term chterm;
const char *chars = va_arg(ap, char *);
while((chterm = Yap_CharsToString(chars PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_term" ))
return FALSE;
}
*pt++ = chterm;
}
break;
case PL_CHARS:
{
Atom at;
char *s = va_arg(ap, char *);
while (!(at = Yap_LookupAtom(s))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
const char *chars = va_arg(ap, char *);
while((at = Yap_CharsToAtom(chars PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_term" ))
return FALSE;
}
}
Yap_AtomIncreaseHold(at);
*pt++ = MkAtomTerm(at);
Yap_AtomIncreaseHold(at);
}
break;
case PL_NCHARS:
{
Atom at;
size_t sz = va_arg(ap, size_t);
*pt++ = MkAtomTerm(LookupMaxAtom(sz,va_arg(ap, char *)));
const char *chars = va_arg(ap, char *);
while((at = Yap_NCharsToAtom(chars, sz PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_term" ))
return FALSE;
}
*pt++ = MkAtomTerm(at);
Yap_AtomIncreaseHold(at);
}
break;
case PL_NWCHARS:
{
Atom at;
size_t sz = va_arg(ap, size_t);
wchar_t * arg = va_arg(ap, wchar_t *);
*pt++ = MkAtomTerm(LookupMaxWideAtom(sz,arg));
const wchar_t *chars = va_arg(ap, wchar_t *);
while((at = Yap_NWCharsToAtom(chars, sz PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_term" ))
return FALSE;
}
*pt++ = MkAtomTerm(at);
Yap_AtomIncreaseHold(at);
}
break;
case PL_TERM:
@ -1612,29 +1493,19 @@ int PL_unify_termv(term_t l, va_list ap)
{
char *fname = va_arg(ap, char *);
size_t arity = va_arg(ap, size_t);
Atom at;
while((at = Yap_CharsToAtom(fname PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE && !Yap_SWIHandleError( "PL_unify_term" ))
return FALSE;
}
Yap_AtomIncreaseHold(at);
if (!arity) {
Atom at;
while (!(at = Yap_LookupAtom(fname))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
Yap_AtomIncreaseHold(at);
*pt++ = MkAtomTerm(at);
} else {
Atom at;
Functor ff;
Term t;
while (!(at = Yap_LookupAtom(fname))) {
if (!Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
ff = Yap_MkFunctor(at,arity);
t = Yap_MkNewApplTerm(ff, arity);
if (nels) {
@ -1864,7 +1735,7 @@ X_API int PL_is_string(term_t ts)
{
CACHE_REGS
Term t = Yap_GetFromSlot(ts PASS_REGS);
return Yap_IsStringTerm(t);
return IsStringTerm(t);
}
X_API int PL_is_variable(term_t ts)
@ -2354,7 +2225,7 @@ X_API void PL_cut_query(qid_t qi)
if (qi->open != 1 || qi->state == 0) return;
YAP_LeaveGoal(FALSE, &qi->h);
qi->open = 0;
Yap_FreeCodeSpace( qi );
Yap_FreeCodeSpace( (char *)qi );
}
X_API void PL_close_query(qid_t qi)
@ -2370,7 +2241,7 @@ X_API void PL_close_query(qid_t qi)
}
YAP_LeaveGoal(FALSE, &qi->h);
qi->open = 0;
Yap_FreeCodeSpace( qi );
Yap_FreeCodeSpace( (char *)qi );
}
X_API int PL_call_predicate(module_t ctx, int flags, predicate_t p, term_t t0)
@ -2906,7 +2777,6 @@ str_prefix(const char *p0, char *s)
static int
atom_generator(const char *prefix, char **hit, int state)
{
CACHE_REGS
struct scan_atoms *index;
Atom catom;
Int i;

27
library/dialect/swi/fli/swi.h
View File

@ -39,24 +39,6 @@ in_hash(ADDR key)
}
static inline atom_t
AtomToSWIAtom(Atom at)
{
TranslationEntry *p;
if ((p = Yap_GetTranslationProp(at)) != NULL)
return (atom_t)(p->Translation*2+1);
return (atom_t)at;
}
static inline Atom
SWIAtomToAtom(atom_t at)
{
if ((CELL)at & 1)
return SWI_Atoms[at/2];
return (Atom)at;
}
static inline Term
SWIModuleToModule(module_t m)
{
@ -77,13 +59,4 @@ FunctorToSWIFunctor(Functor at)
return (functor_t)at;
}
/* This is silly, but let's keep it like that for now */
static inline Functor
SWIFunctorToFunctor(functor_t f)
{
if ((CELL)(f) & 2 && ((CELL)f) < N_SWI_FUNCTORS*4+2)
return SWI_Functors[((CELL)f)/4];
return (Functor)f;
}
#define isDefinedProcedure(pred) TRUE // TBD

2
misc/ATOMS
View File

@ -39,6 +39,7 @@ A B F "$last_choice_pt"
A Batched N "batched"
A Between N "between"
A HugeInt N "huge_int"
A BigNum N "big_num"
A BinaryStream N "binary_stream"
A Braces N "{}"
A Break F "$break"
@ -301,6 +302,7 @@ A StreamOrAlias N "stream_or_alias"
A StreamPos F "$stream_position"
A StreamPosition N "stream_position"
A String N "string"
A STRING F "String"
A Swi N "swi"
A SyntaxError N "syntax_error"
A SyntaxErrorHandler N "syntax_error_handler"

2
misc/LOCALS
View File

@ -271,4 +271,6 @@ Int CurSlot =0
Term SourceModule =0
size_t MAX_SIZE =1024L
END_WORKER_LOCAL

8
misc/buildops
View File

@ -261,6 +261,7 @@ get_op(0'O,"OrArg").
get_op(0'p,"PtoPred").
get_op(0's,"Constant").
get_op(0't,"TabEntry").
get_op(0'u,"BlobTermInCode").
get_op(0'x,"X").
get_op(0'y,"Y").
% '
@ -884,6 +885,7 @@ opinfo("gl_void_vary",[bind("y","AbsPair(NULL)",workpc=currentop),new("y")]).
opinfo("get_struct",[bind("x","AbsAppl((CELL *)cl->u.xfa.f)",workpc=nextop)]).
opinfo("get_float",[bind("x","AbsAppl((CELL *)FunctorDouble)",t_ptr="d")]).
opinfo("get_longint",[bind("x","AbsAppl((CELL *)FunctorLongInt)",t_ptr="i")]).
opinfo("get_string",[bind("x","AbsAppl((CELL *)FunctorString)",t_ptr=[])]).
opinfo("get_bigint",[bind("x","AbsAppl((CELL *)FunctorBigInt)",t_ptr=[])]).
opinfo("copy_idb_term",[logical]).
opinfo("unify_idb_term",[logical]).
@ -892,6 +894,7 @@ opinfo("put_dbterm",[new("x")]).
opinfo("put_bigint",[new("x")]).
opinfo("put_float",[new("x")]).
opinfo("put_longint",[new("x")]).
opinfo("put_string",[new("x")]).
opinfo("put_list",[new("x")]).
opinfo("put_struct",[new("x")]).
opinfo("get_2atoms",[bind(1,"c1",[]),
@ -1059,6 +1062,11 @@ opinfo("unify_bigint_write",[]).
opinfo("unify_l_bigint",[]).
opinfo("unify_l_bigint_write",[]).
opinfo("write_bigint",[body]).
opinfo("unify_string",[]).
opinfo("unify_string_write",[]).
opinfo("unify_l_string",[]).
opinfo("unify_l_string_write",[]).
opinfo("write_string",[body]).
opinfo("unify_dbterm",[]).
opinfo("unify_dbterm_write",[]).
opinfo("unify_l_dbterm",[]).

48
os/pl-utf8.c
View File

@ -65,6 +65,54 @@ _PL__utf8_get_char(const char *in, int *chr)
return (char *)in+1;
}
unicode_type_t
_PL__utf8_type(const char *in0, size_t len)
{ /* 2-byte, 0x80-0x7ff */
int chr;
char *in = (char *) in0;
int type = S_ASCII;
while (in[0] != '\0' && in-in0 < len) {
if ( (in[0]&0xe0) == 0xc0 && CONT(1) )
{ chr = ((in[0]&0x1f) << 6)|VAL(1,0);
if (chr > 255) return S_WIDE;
if (chr > 127) type = S_LATIN;
in += 2;
break;
}
/* 3-byte, 0x800-0xffff */
if ( (in[0]&0xf0) == 0xe0 && CONT(1) && CONT(2) )
{ chr = ((in[0]&0xf) << 12)|VAL(1,6)|VAL(2,0);
if (chr > 255) return S_WIDE;
if (chr > 127) type = S_LATIN;
in += 3;
}
/* 4-byte, 0x10000-0x1FFFFF */
if ( (in[0]&0xf8) == 0xf0 && CONT(1) && CONT(2) && CONT(3) )
{ chr = ((in[0]&0x7) << 18)|VAL(1,12)|VAL(2,6)|VAL(3,0);
if (chr > 255) return S_WIDE;
if (chr > 127) type = S_LATIN;
in += 4;
}
/* 5-byte, 0x200000-0x3FFFFFF */
if ( (in[0]&0xfc) == 0xf8 && CONT(1) && CONT(2) && CONT(3) && CONT(4) )
{ chr = ((in[0]&0x3) << 24)|VAL(1,18)|VAL(2,12)|VAL(3,6)|VAL(4,0);
if (chr > 255) return S_WIDE;
if (chr > 127) type = S_LATIN;
in += 5;
}
/* 6-byte, 0x400000-0x7FFFFFF */
if ( (in[0]&0xfe) == 0xfc && CONT(1) && CONT(2) && CONT(3) && CONT(4) && CONT(5) )
{ chr = ((in[0]&0x1) << 30)|VAL(1,24)|VAL(2,18)|VAL(3,12)|VAL(4,6)|VAL(5,0);
if (chr > 255) return S_WIDE;
if (chr > 127) type = S_LATIN;
in += 6;
}
in ++;
}
return type;
}
char *
_PL__utf8_put_char(char *out, int chr)

8
os/pl-utf8.h
View File

@ -59,4 +59,12 @@ extern char *_PL__utf8_put_char(char *out, int chr);
extern size_t utf8_strlen(const char *s, size_t len);
typedef enum {
S_ASCII,
S_LATIN,
S_WIDE
} unicode_type_t;
extern unicode_type_t _PL__utf8_type(const char *in0, size_t len);
#endif /*UTF8_H_INCLUDED*/

2
pl/boot.yap
View File

@ -1023,7 +1023,7 @@ bootstrap(F) :-
close(Stream).
'$read_vars'(Stream, T, Mod, Pos, V, _Prompt, false) :- !,
read_term(Stream, T, [ /* module(Mod), */ variable_names(V), term_position(Pos), syntax_errors(dec10) ]).
read_term(Stream, T, [ module(Mod), variable_names(V), term_position(Pos), syntax_errors(dec10) ]).
'$read_vars'(Stream, T, Mod, Pos, V, _Prompt, ReadComments) :-
read_term(Stream, T, [module(Mod), variable_names(V), term_position(Pos), syntax_errors(dec10), comments( ReadComments ) ]).

4
pl/preds.yap
View File

@ -983,9 +983,9 @@ current_predicate(F0) :-
'$$current_predicate'(F, M) :-
( var(M) -> % only for the predicate
'$current_module'(M),
M \= prolog
'$current_module'(M)
; true),
M \= prolog,
'$current_predicate3'(F,M).
'$current_predicate3'(A/Arity,M) :-