This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/packages/PLStream/pl-yap.c

591 lines
12 KiB
C
Raw Normal View History

2008-12-22 12:02:22 +00:00
/* YAP support for some low-level SWI stuff */
#include <stdio.h>
#include "pl-incl.h"
2009-06-17 05:26:03 +01:00
#ifdef HAVE_LIMITS_H
#include <limits.h>
#endif
2008-12-22 12:02:22 +00:00
int fileerrors;
PL_local_data_t lds;
gds_t gds;
2008-12-22 12:02:22 +00:00
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];
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), (void (*)(int))Sputc, flags);
2008-12-22 12:02:22 +00:00
return TRUE;
}
int
writeAtomToStream(IOSTREAM *so, atom_t at)
{
YAP_Write(YAP_MkAtomTerm((YAP_Atom)at), (void (*)(int))Sputc, 0);
2008-12-22 12:02:22 +00:00
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);
2008-12-22 12:02:22 +00:00
}
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 ( truePrologFlag(PLFLAG_ISO) )
2008-12-22 12:02:22 +00:00
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 )
2008-12-22 12:02:22 +00:00
{ 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;
}
void
setPrologFlag(const char *name, int flags, ...)
{
}
void
PL_set_prolog_flag(const char *name, int flags, ...)
{
}
int
PL_unify_chars(term_t t, int flags, size_t len, const char *s)
{ PL_chars_t text;
term_t tail;
int rc;
if ( len == (size_t)-1 )
len = strlen(s);
text.text.t = (char *)s;
text.encoding = ((flags&REP_UTF8) ? ENC_UTF8 : \
(flags&REP_MB) ? ENC_ANSI : ENC_ISO_LATIN_1);
text.storage = PL_CHARS_HEAP;
text.length = len;
text.canonical = FALSE;
flags &= ~(REP_UTF8|REP_MB|REP_ISO_LATIN_1);
if ( (flags & PL_DIFF_LIST) )
{ tail = t+1;
flags &= (~PL_DIFF_LIST);
} else
{ tail = 0;
}
rc = PL_unify_text(t, tail, &text, flags);
PL_free_text(&text);
return rc;
}