q#
This commit is contained in:
Vítor Santos Costa
539
LGPL/PLStream/pl-yap.c
Normal file
539
LGPL/PLStream/pl-yap.c
Normal file
@@ -0,0 +1,539 @@
|
||||
|
||||
/* YAP support for some low-level SWI stuff */
|
||||
|
||||
#include <stdio.h>
|
||||
#include "pl-incl.h"
|
||||
|
||||
static atom_t
|
||||
uncachedCodeToAtom(int chrcode)
|
||||
{ if ( chrcode < 256 )
|
||||
{ char tmp[1];
|
||||
|
||||
tmp[0] = chrcode;
|
||||
return lookupAtom(tmp, 1);
|
||||
} else
|
||||
{ pl_wchar_t tmp[2];
|
||||
int new;
|
||||
|
||||
tmp[0] = chrcode;
|
||||
tmp[1] = '\0';
|
||||
|
||||
return (atom_t)YAP_LookupWideAtom(tmp);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
atom_t
|
||||
codeToAtom(int chrcode)
|
||||
{ atom_t a;
|
||||
|
||||
if ( chrcode == EOF )
|
||||
return ATOM_end_of_file;
|
||||
|
||||
assert(chrcode >= 0);
|
||||
|
||||
if ( chrcode < (1<<15) )
|
||||
{ int page = chrcode / 256;
|
||||
int entry = chrcode % 256;
|
||||
atom_t *pv;
|
||||
|
||||
if ( !(pv=GD->atoms.for_code[page]) )
|
||||
{ pv = PL_malloc(256*sizeof(atom_t));
|
||||
|
||||
memset(pv, 0, 256*sizeof(atom_t));
|
||||
GD->atoms.for_code[page] = pv;
|
||||
}
|
||||
|
||||
if ( !(a=pv[entry]) )
|
||||
{ a = pv[entry] = uncachedCodeToAtom(chrcode);
|
||||
}
|
||||
} else
|
||||
{ a = uncachedCodeToAtom(chrcode);
|
||||
}
|
||||
|
||||
return a;
|
||||
}
|
||||
|
||||
int
|
||||
PL_rethrow(void)
|
||||
{ GET_LD
|
||||
|
||||
if ( LD->exception.throw_environment )
|
||||
longjmp(LD->exception.throw_environment->exception_jmp_env, 1);
|
||||
|
||||
fail;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
callProlog(module_t module, term_t goal, int flags, term_t *ex)
|
||||
{ term_t g = PL_new_term_ref();
|
||||
functor_t fd;
|
||||
predicate_t proc;
|
||||
|
||||
if ( ex )
|
||||
*ex = 0;
|
||||
|
||||
PL_strip_module(goal, &module, g);
|
||||
if ( !PL_get_functor(g, &fd) )
|
||||
{ PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_callable, goal);
|
||||
if ( ex )
|
||||
*ex = exception_term;
|
||||
|
||||
fail;
|
||||
}
|
||||
|
||||
proc = PL_pred(fd, module);
|
||||
|
||||
{ int arity = arityFunctor(fd);
|
||||
term_t args = PL_new_term_refs(arity);
|
||||
qid_t qid;
|
||||
int n, rval;
|
||||
|
||||
for(n=0; n<arity; n++)
|
||||
_PL_get_arg(n+1, g, args+n);
|
||||
|
||||
qid = PL_open_query(module, flags, proc, args);
|
||||
rval = PL_next_solution(qid);
|
||||
if ( !rval && ex )
|
||||
*ex = PL_exception(qid);
|
||||
PL_cut_query(qid);
|
||||
|
||||
return rval;
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags)
|
||||
{
|
||||
|
||||
YAP_Write(YAP_GetFromSlot(term), Sputc, flags);
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
int
|
||||
writeAtomToStream(IOSTREAM *so, atom_t at)
|
||||
{
|
||||
|
||||
YAP_Write(YAP_MkAtomTerm((YAP_Atom)at), Sputc, 0);
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
int
|
||||
valueExpression(term_t t, Number r ARG_LD)
|
||||
{ //return YAP__expression(t, r, 0 PASS_LD);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
toIntegerNumber(Number n, int flags)
|
||||
|
||||
Convert a number to an integer. Default, only rationals that happen to
|
||||
be integer are converted. If TOINT_CONVERT_FLOAT is present, floating
|
||||
point numbers are converted if they represent integers. If also
|
||||
TOINT_TRUNCATE is provided non-integer floats are truncated to integers.
|
||||
|
||||
Note that if a double is out of range for int64_t, it never has a
|
||||
fractional part.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
int
|
||||
toIntegerNumber(Number n, int flags)
|
||||
{
|
||||
#if SWI_PROLOG
|
||||
switch(n->type)
|
||||
{ case V_INTEGER:
|
||||
succeed;
|
||||
#ifdef O_GMP
|
||||
case V_MPZ:
|
||||
succeed;
|
||||
case V_MPQ: /* never from stacks iff integer */
|
||||
if ( mpz_cmp_ui(mpq_denref(n->value.mpq), 1L) == 0 )
|
||||
{ mpz_clear(mpq_denref(n->value.mpq));
|
||||
n->value.mpz[0] = mpq_numref(n->value.mpq)[0];
|
||||
n->type = V_MPZ;
|
||||
succeed;
|
||||
}
|
||||
fail;
|
||||
#endif
|
||||
case V_REAL:
|
||||
if ( (flags & TOINT_CONVERT_FLOAT) )
|
||||
{ if ( double_in_int64_range(n->value.f) )
|
||||
{ int64_t l = (int64_t)n->value.f;
|
||||
|
||||
if ( (flags & TOINT_TRUNCATE) ||
|
||||
(double)l == n->value.f )
|
||||
{ n->value.i = l;
|
||||
n->type = V_INTEGER;
|
||||
|
||||
return TRUE;
|
||||
}
|
||||
return FALSE;
|
||||
#ifdef O_GMP
|
||||
} else
|
||||
{ mpz_init_set_d(n->value.mpz, n->value.f);
|
||||
n->type = V_MPZ;
|
||||
|
||||
return TRUE;
|
||||
#endif
|
||||
}
|
||||
}
|
||||
return FALSE;
|
||||
}
|
||||
#endif
|
||||
assert(0);
|
||||
fail;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
_PL_unify_atomic(term_t t, PL_atomic_t a)
|
||||
{
|
||||
return YAP_Unify(Yap_GetFromSlot(t), (YAP_Term)a);
|
||||
}
|
||||
|
||||
word lookupAtom(const char *s, size_t len)
|
||||
{
|
||||
return (word)YAP_LookupAtom(s);
|
||||
}
|
||||
|
||||
atom_t lookupUCSAtom(const pl_wchar_t *s, size_t len)
|
||||
{
|
||||
return (atom_t)YAP_LookupWideAtom(s);
|
||||
}
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* OPTIONS *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Variable argument list:
|
||||
|
||||
atom_t name
|
||||
int type OPT_ATOM, OPT_STRING, OPT_BOOL, OPT_INT, OPT_LONG
|
||||
pointer value
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
#define MAXOPTIONS 32
|
||||
|
||||
typedef union
|
||||
{ bool *b; /* boolean value */
|
||||
long *l; /* long value */
|
||||
int *i; /* integer value */
|
||||
char **s; /* string value */
|
||||
word *a; /* atom value */
|
||||
term_t *t; /* term-reference */
|
||||
void *ptr; /* anonymous pointer */
|
||||
} optvalue;
|
||||
|
||||
|
||||
bool
|
||||
scan_options(term_t options, int flags, atom_t optype,
|
||||
const opt_spec *specs, ...)
|
||||
{ va_list args;
|
||||
const opt_spec *s;
|
||||
optvalue values[MAXOPTIONS];
|
||||
term_t list = PL_copy_term_ref(options);
|
||||
term_t head = PL_new_term_ref();
|
||||
term_t tmp = PL_new_term_ref();
|
||||
term_t val = PL_new_term_ref();
|
||||
int n;
|
||||
|
||||
if ( trueFeature(ISO_FEATURE) )
|
||||
flags |= OPT_ALL;
|
||||
|
||||
va_start(args, specs);
|
||||
for( n=0, s = specs; s->name; s++, n++ )
|
||||
values[n].ptr = va_arg(args, void *);
|
||||
va_end(args);
|
||||
|
||||
while ( PL_get_list(list, head, list) )
|
||||
{ atom_t name;
|
||||
int arity;
|
||||
|
||||
if ( PL_get_name_arity(head, &name, &arity) )
|
||||
{ if ( name == ATOM_equals && arity == 2 )
|
||||
{ PL_get_arg(1, head, tmp);
|
||||
|
||||
if ( !PL_get_atom(tmp, &name) )
|
||||
goto itemerror;
|
||||
PL_get_arg(2, head, val);
|
||||
} else if ( arity == 1 )
|
||||
{ PL_get_arg(1, head, val);
|
||||
} else if ( arity == 0 )
|
||||
PL_put_atom(val, ATOM_true);
|
||||
} else if ( PL_is_variable(head) )
|
||||
{ return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
|
||||
} else
|
||||
{ itemerror:
|
||||
return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head);
|
||||
}
|
||||
|
||||
for( n=0, s = specs; s->name; n++, s++ )
|
||||
{ if ( s->name == name )
|
||||
{ switch((s->type & OPT_TYPE_MASK))
|
||||
{ case OPT_BOOL:
|
||||
{ atom_t aval;
|
||||
|
||||
if ( !PL_get_atom(val, &aval) )
|
||||
fail;
|
||||
if ( aval == ATOM_true || aval == ATOM_on )
|
||||
*values[n].b = TRUE;
|
||||
else if ( aval == ATOM_false || aval == ATOM_off )
|
||||
*values[n].b = FALSE;
|
||||
else
|
||||
goto itemerror;
|
||||
break;
|
||||
}
|
||||
case OPT_INT:
|
||||
{ if ( !PL_get_integer(val, values[n].i) )
|
||||
goto itemerror;
|
||||
|
||||
break;
|
||||
}
|
||||
case OPT_LONG:
|
||||
{ if ( !PL_get_long(val, values[n].l) )
|
||||
{ if ( (s->type & OPT_INF) && PL_is_inf(val) )
|
||||
*values[n].l = LONG_MAX;
|
||||
else
|
||||
goto itemerror;
|
||||
}
|
||||
|
||||
break;
|
||||
}
|
||||
case OPT_NATLONG:
|
||||
{ if ( !PL_get_long(val, values[n].l) )
|
||||
goto itemerror;
|
||||
if ( *(values[n].l) <= 0 )
|
||||
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
|
||||
ATOM_not_less_than_one, val);
|
||||
|
||||
break;
|
||||
}
|
||||
case OPT_STRING:
|
||||
{ char *str;
|
||||
|
||||
if ( !PL_get_chars(val, &str, CVT_ALL) ) /* copy? */
|
||||
goto itemerror;
|
||||
*values[n].s = str;
|
||||
break;
|
||||
}
|
||||
case OPT_ATOM:
|
||||
{ atom_t a;
|
||||
|
||||
if ( !PL_get_atom(val, &a) )
|
||||
goto itemerror;
|
||||
*values[n].a = a;
|
||||
break;
|
||||
}
|
||||
case OPT_TERM:
|
||||
{ *values[n].t = val;
|
||||
val = PL_new_term_ref(); /* can't reuse anymore */
|
||||
break;
|
||||
}
|
||||
default:
|
||||
assert(0);
|
||||
fail;
|
||||
}
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if ( !s->name && (flags & OPT_ALL) )
|
||||
goto itemerror;
|
||||
}
|
||||
|
||||
if ( !PL_get_nil(list) )
|
||||
return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
|
||||
|
||||
succeed;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
get_atom_ptr_text(Atom a, PL_chars_t *text)
|
||||
{ if (YAP_IsWideAtom(a))
|
||||
{ pl_wchar_t *name = (pl_wchar_t *)YAP_WideAtomName(a);
|
||||
text->text.w = name;
|
||||
text->length = wcslen(name);
|
||||
text->encoding = ENC_WCHAR;
|
||||
} else
|
||||
{ char *name = (char *)YAP_AtomName(a);
|
||||
text->text.t = name;
|
||||
text->length = strlen(name);
|
||||
text->encoding = ENC_ISO_LATIN_1;
|
||||
}
|
||||
text->storage = PL_CHARS_HEAP;
|
||||
text->canonical = TRUE;
|
||||
|
||||
succeed;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
get_atom_text(atom_t atom, PL_chars_t *text)
|
||||
{ Atom a = atomValue(atom);
|
||||
|
||||
return get_atom_ptr_text(a, text);
|
||||
}
|
||||
|
||||
int
|
||||
get_string_text(word w, PL_chars_t *text ARG_LD)
|
||||
{ fail;
|
||||
}
|
||||
|
||||
void
|
||||
PL_get_number(term_t l, number *n) {
|
||||
YAP_Term t = valHandle(l);
|
||||
if (YAP_IsIntTerm(t)) {
|
||||
n->type = V_INTEGER;
|
||||
n->value.i = YAP_IntOfTerm(t);
|
||||
#ifdef O_GMP
|
||||
} else {
|
||||
n->type = V_MPZ;
|
||||
n->value.mpz = YAP_BigNumOfTerm(t);
|
||||
#endif
|
||||
}
|
||||
}
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Formatting a float. This is very complicated as we must write floats
|
||||
such that it can be read as a float. This means using the conventions of
|
||||
the C locale and if the float happens to be integer as <int>.0.
|
||||
|
||||
Switching the locale is no option as locale handling is not thread-safe
|
||||
and may have unwanted consequences for embedding. There is a intptr_t
|
||||
discussion on the very same topic on the Python mailinglist. Many hacks
|
||||
are proposed, none is very satisfactory. Richard O'Keefe suggested to
|
||||
use ecvt(), fcvt() and gcvt(). These are not thread-safe. The GNU C
|
||||
library provides *_r() variations that can do the trick. An earlier
|
||||
patch used localeconv() to find the decimal point, but this is both
|
||||
complicated and not thread-safe.
|
||||
|
||||
Finally, with help of Richard we decided to replace the first character
|
||||
that is not a digit nor [eE], as this must be the decimal point.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
#define isDigit(c) ((c) >= '0' && (c) <= '9')
|
||||
|
||||
char *
|
||||
format_float(double f, char *buf, const char *format)
|
||||
{ char *q;
|
||||
|
||||
sprintf(buf, format, f);
|
||||
|
||||
q = buf;
|
||||
if ( *q == '-' ) /* skip -?[0-9]* */
|
||||
q++;
|
||||
while(*q && (isDigit(*q) || *q <= ' '))
|
||||
q++;
|
||||
|
||||
switch( *q )
|
||||
{ case '\0':
|
||||
*q++ = '.';
|
||||
*q++ = '0';
|
||||
*q = EOS;
|
||||
break;
|
||||
case 'e':
|
||||
case 'E':
|
||||
break;
|
||||
default:
|
||||
*q = '.';
|
||||
}
|
||||
|
||||
return buf;
|
||||
}
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
codes_or_chars_to_buffer(term_t l, unsigned flags, int wide)
|
||||
|
||||
If l represents a list of codes or characters, return a buffer holding
|
||||
the characters. If wide == TRUE the buffer contains objects of type
|
||||
pl_wchar_t. Otherwise it contains traditional characters.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
static int
|
||||
charCode(YAP_Term w)
|
||||
{ if ( YAP_IsAtomTerm(w) )
|
||||
{
|
||||
Atom a = atomValue(w);
|
||||
|
||||
if ( YAP_AtomNameLength(a) == 1) {
|
||||
if (YAP_IsWideAtom(a)) {
|
||||
return YAP_WideAtomName(a)[0];
|
||||
}
|
||||
return YAP_AtomName(a)[0];
|
||||
}
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
Buffer
|
||||
codes_or_chars_to_buffer(term_t l, unsigned int flags, int wide)
|
||||
{ GET_LD
|
||||
Buffer b;
|
||||
YAP_Term list = YAP_GetFromSlot(l);
|
||||
YAP_Term arg;
|
||||
enum { CHARS, CODES } type;
|
||||
|
||||
if ( YAP_IsPairTerm(list) )
|
||||
{ arg = YAP_HeadOfTerm(list);
|
||||
if ( YAP_IsIntTerm(arg) )
|
||||
{ long int i = YAP_IntOfTerm(arg);
|
||||
if ( i >= 0 && (wide || i < 256) )
|
||||
{ type = CODES;
|
||||
goto ok;
|
||||
}
|
||||
} else if ( charCode(arg) >= 0 )
|
||||
{ type = CHARS;
|
||||
goto ok;
|
||||
}
|
||||
} else if ( list != YAP_TermNil() )
|
||||
{ return findBuffer(flags);
|
||||
}
|
||||
|
||||
fail;
|
||||
|
||||
ok:
|
||||
b = findBuffer(flags);
|
||||
|
||||
while( YAP_IsPairTerm(list) )
|
||||
{ intptr_t c = -1;
|
||||
|
||||
arg = YAP_HeadOfTerm(list);
|
||||
|
||||
switch(type)
|
||||
{ case CODES:
|
||||
if ( YAP_IsIntTerm(arg) )
|
||||
{ c = YAP_IntOfTerm(arg);
|
||||
}
|
||||
break;
|
||||
case CHARS:
|
||||
c = charCode(arg);
|
||||
break;
|
||||
}
|
||||
|
||||
if ( c < 0 || (!wide && c > 0xff) )
|
||||
{ unfindBuffer(flags); /* TBD: check unicode range */
|
||||
return NULL;
|
||||
}
|
||||
|
||||
if ( wide )
|
||||
addBuffer(b, (pl_wchar_t)c, pl_wchar_t);
|
||||
else
|
||||
addBuffer(b, (unsigned char)c, unsigned char);
|
||||
|
||||
list = YAP_TailOfTerm(list);
|
||||
}
|
||||
if ( list != YAP_TermNil() )
|
||||
{ unfindBuffer(flags);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
return b;
|
||||
}
|
||||
Reference in New Issue
Block a user