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

support new interface between YAP and GMP, so that we don't rely on our own

Browse Source 
allocation routines.
Several big fixes.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1490 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2006-01-02 02:16:19 +00:00
parent 6d079626af
commit e10213929a
26 changed files with 1609 additions and 1228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
C/absmi.c
View File

@ -10,8 +10,13 @@
* *
* File: absmi.c *
* comments: Portable abstract machine interpreter *
* Last rev: $Date: 2005-12-23 00:20:13 $,$Author: vsc $ *
* Last rev: $Date: 2006-01-02 02:16:17 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.190 2005/12/23 00:20:13 vsc
* updates to gprof
* support for __POWER__
* Try to saveregs before longjmp.
*
* Revision 1.189 2005/12/17 03:25:38 vsc
* major changes to support online event-based profiling
* improve error discovery and restart on scanner.
@ -316,6 +321,7 @@ AritFunctorOfTerm(Term t) {
}
}
#define TMP_BIG(v) Yap_BigTmp
#define RINT(v) return(MkIntegerTerm(v))
#define RFLOAT(v) return(MkFloatTerm(v))
#define RBIG(v) return(Yap_MkBigIntTerm(v))
@ -3788,6 +3794,7 @@ Yap_absmi(int inp)
ENDOp();
Op(get_bigint, xc);
#ifdef USE_GMP
BEGD(d0);
d0 = XREG(PREG->u.xc.x);
deref_head(d0, gbigint_unk);
@ -3797,25 +3804,17 @@ Yap_absmi(int inp)
FAIL();
/* we have met a preexisting bigint */
START_PREFETCH(xc);
#ifdef USE_GMP
BEGP(pt0);
pt0 = RepAppl(d0);
/* check functor */
if (*pt0 != (CELL)FunctorBigInt)
#else
if (TRUE)
#endif
{
FAIL();
}
#ifdef USE_GMP
if (mpz_cmp(Yap_BigIntOfTerm(d0),Yap_BigIntOfTerm(PREG->u.xc.c)))
FAIL();
#endif
PREG = NEXTOP(PREG, xc);
#ifdef USE_GMP
ENDP(pt0);
#endif
/* enter read mode */
GONext();
END_PREFETCH();
@ -3840,6 +3839,9 @@ Yap_absmi(int inp)
ENDP(pt0);
ENDD(d0);
#else
FAIL();
#endif
ENDOp();
/************************************************************************\
@ -5809,6 +5811,7 @@ Yap_absmi(int inp)
ENDOp();
Op(unify_bigint, oc);
#ifdef USE_GMP
BEGD(d0);
BEGP(pt0);
pt0 = SREG++;
@ -5819,25 +5822,19 @@ Yap_absmi(int inp)
if (!IsApplTerm(d0)) {
FAIL();
}
#ifdef USE_GMP
BEGP(pt0);
pt0 = RepAppl(d0);
BEGD(d0);
d0 = *pt0;
if (d0 != (CELL)FunctorBigInt)
#endif
BEGD(d1);
d1 = *pt0;
if (d1 != (CELL)FunctorBigInt)
{
FAIL();
}
#ifdef USE_GMP
ENDD(d0);
ENDD(d1);
if (mpz_cmp(Yap_BigIntOfTerm(d0),Yap_BigIntOfTerm(PREG->u.oc.c)))
FAIL();
PREG = NEXTOP(PREG, oc);
#endif
#ifdef USE_GMP
ENDP(pt0);
#endif
GONext();
derefa_body(d0, pt0, ubigint_unk, ubigint_nonvar);
@ -5854,9 +5851,13 @@ Yap_absmi(int inp)
ENDD(d1);
ENDP(pt0);
ENDD(d0);
#else
FAIL();
#endif
ENDOp();
Op(unify_l_bigint, oc);
#ifdef USE_GMP
BEGD(d0);
CACHE_S();
READ_IN_S();
@ -5866,25 +5867,19 @@ Yap_absmi(int inp)
if (!IsApplTerm(d0)) {
FAIL();
}
#ifdef USE_GMP
BEGP(pt0);
pt0 = RepAppl(d0);
BEGD(d0);
d0 = *pt0;
if (d0 != (CELL)FunctorBigInt)
#endif
{
FAIL();
}
#ifdef USE_GMP
ENDD(d0);
if (mpz_cmp(Yap_BigIntOfTerm(d0),Yap_BigIntOfTerm(PREG->u.oc.c)))
FAIL();
PREG = NEXTOP(PREG, oc);
#endif
#ifdef USE_GMP
ENDP(pt0);
#endif
GONext();
derefa_body(d0, S_SREG, ulbigint_unk, ulbigint_nonvar);
@ -5901,6 +5896,9 @@ Yap_absmi(int inp)
ENDD(d1);
ENDCACHE_S();
ENDD(d0);
#else
FAIL();
#endif
ENDOp();
OpW(unify_list_write, o);
@ -9762,15 +9760,19 @@ Yap_absmi(int inp)
sll_vv_nvar_nvar:
/* d0 and d1 are where I want them */
if (IsIntTerm(d0) && IsIntTerm(d1)) {
d0 = MkIntegerTerm(IntOfTerm(d0) << IntOfTerm(d1));
Int i2 = IntOfTerm(d1);
if (i2 < 0)
d0 = MkIntegerTerm(IntOfTerm(d0) >> -i2);
else
d0 = do_sll(IntOfTerm(d0),i2);
}
else {
saveregs();
d0 = p_sll(d0, d1);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
if (PREG == (yamop *)FAILCODE)
FAIL();
XREG(PREG->u.xxx.x) = d0;
PREG = NEXTOP(PREG, xxx);
GONext();
@ -9803,16 +9805,18 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.xxc.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(IntOfTerm(d0) << d1);
fprintf(stderr,"%d<<%d\n",IntOfTerm(d0), d1);
d0 = do_sll(IntOfTerm(d0), (Int)d1);
fprintf(stderr,"%d\n",IntegerOfTerm(d0));
}
else {
saveregs();
d0 = p_sll(d0, MkIntegerTerm(d1));
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
}
if (PREG == (yamop *)FAILCODE)
FAIL();
XREG(PREG->u.xxc.x) = d0;
PREG = NEXTOP(PREG, xxc);
GONext();
@ -9836,16 +9840,20 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.xcx.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(d1 << IntOfTerm(d0));
Int i2 = IntOfTerm(d0);
if (i2 < 0)
d0 = MkIntegerTerm(d1 >> -i2);
else
d0 = do_sll(d1,i2);
}
else {
saveregs();
d0 = p_sll(MkIntegerTerm(d1), d0);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
}
if (PREG == (yamop *)FAILCODE)
FAIL();
XREG(PREG->u.xxc.x) = d0;
PREG = NEXTOP(PREG, xcx);
GONext();
@ -9873,15 +9881,19 @@ Yap_absmi(int inp)
sll_y_vv_nvar_nvar:
/* d0 and d1 are where I want them */
if (IsIntTerm(d0) && IsIntTerm(d1)) {
d0 = MkIntegerTerm(IntOfTerm(d0) << IntOfTerm(d1));
Int i2 = IntOfTerm(d1);
if (i2 < 0)
d0 = MkIntegerTerm(IntOfTerm(d0) >> -i2);
else
d0 = do_sll(IntOfTerm(d0),i2);
}
else {
saveregs();
d0 = p_sll(d0, d1);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
if (PREG == (yamop *)FAILCODE)
FAIL();
BEGP(pt0);
pt0 = YREG + PREG->u.yxx.y;
PREG = NEXTOP(PREG, yxx);
@ -9921,16 +9933,16 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.yxc.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(IntOfTerm(d0) << d1);
d0 = do_sll(IntOfTerm(d0), d1);
}
else {
saveregs();
d0 = p_sll(d0, MkIntegerTerm(d1));
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
}
if (PREG == (yamop *)FAILCODE)
FAIL();
BEGP(pt0);
pt0 = YREG + PREG->u.yxc.y;
PREG = NEXTOP(PREG, yxc);
@ -9962,16 +9974,20 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.ycx.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(d1 << IntOfTerm(d0));
Int i2 = IntOfTerm(d0);
if (i2 < 0)
d0 = MkIntegerTerm(d1 >> -i2);
else
d0 = do_sll(d1,i2);
}
else {
saveregs();
d0 = p_sll(MkIntegerTerm(d1), d0);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
}
if (PREG == (yamop *)FAILCODE)
FAIL();
BEGP(pt0);
pt0 = YREG + PREG->u.ycx.y;
PREG = NEXTOP(PREG, ycx);
@ -10006,15 +10022,19 @@ Yap_absmi(int inp)
slr_vv_nvar_nvar:
/* d0 and d1 are where I want them */
if (IsIntTerm(d0) && IsIntTerm(d1)) {
d0 = MkIntegerTerm(IntOfTerm(d0) >> IntOfTerm(d1));
Int i2 = IntOfTerm(d1);
if (i2 < 0)
d0 = do_sll(IntOfTerm(d0), -i2);
else
d0 = MkIntTerm(IntOfTerm(d0) >> i2);
}
else {
saveregs();
d0 = p_slr(d0, d1);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
if (PREG == (yamop *)FAILCODE)
FAIL();
XREG(PREG->u.xxx.x) = d0;
PREG = NEXTOP(PREG, xxx);
GONext();
@ -10047,7 +10067,7 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.xxc.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(IntOfTerm(d0) >> d1);
d0 = MkIntTerm(IntOfTerm(d0) >> d1);
}
else {
saveregs();
@ -10080,16 +10100,20 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.xcx.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(d1 >> IntOfTerm(d0));
Int i2 = IntOfTerm(d0);
if (i2 < 0)
d0 = do_sll(d1, -i2);
else
d0 = MkIntTerm(d1 >> i2);
}
else {
saveregs();
d0 = p_slr(MkIntegerTerm(d1), d0);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
}
if (PREG == (yamop *)FAILCODE)
FAIL();
XREG(PREG->u.xxc.x) = d0;
PREG = NEXTOP(PREG, xcx);
GONext();
@ -10117,16 +10141,20 @@ Yap_absmi(int inp)
slr_y_vv_nvar_nvar:
/* d0 and d1 are where I want them */
if (IsIntTerm(d0) && IsIntTerm(d1)) {
d0 = MkIntegerTerm(IntOfTerm(d0) >> IntOfTerm(d1));
Int i2 = IntOfTerm(d1);
if (i2 < 0)
d0 = do_sll(IntOfTerm(d0), -i2);
else
d0 = MkIntTerm(IntOfTerm(d0) >> i2);
}
else {
saveregs();
d0 = p_slr(d0, d1);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
BEGP(pt0);
if (PREG == (yamop *)FAILCODE)
FAIL();
pt0 = YREG + PREG->u.yxx.y;
PREG = NEXTOP(PREG, yxx);
#if defined(SBA) && defined(FROZEN_STACKS)
@ -10165,7 +10193,7 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.yxc.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(IntOfTerm(d0) >> d1);
d0 = MkIntTerm(IntOfTerm(d0) >> d1);
}
else {
saveregs();
@ -10204,16 +10232,20 @@ Yap_absmi(int inp)
{
Int d1 = PREG->u.ycx.c;
if (IsIntTerm(d0)) {
d0 = MkIntegerTerm(d1 >> IntOfTerm(d0));
Int i2 = IntOfTerm(d0);
if (i2 < 0)
d0 = do_sll(d1, -i2);
else
d0 = MkIntTerm(d1 >> i2);
}
else {
saveregs();
d0 = p_slr(MkIntegerTerm(d1), d0);
setregs();
if (PREG == (yamop *)FAILCODE)
FAIL();
}
}
if (PREG == (yamop *)FAILCODE)
FAIL();
BEGP(pt0);
pt0 = YREG + PREG->u.ycx.y;
PREG = NEXTOP(PREG, ycx);

34
C/amasm.c
View File

@ -11,8 +11,12 @@
* File: amasm.c *
* comments: abstract machine assembler *
* *
* Last rev: $Date: 2005-12-17 03:25:39 $ *
* Last rev: $Date: 2006-01-02 02:16:17 $ *
* $Log: not supported by cvs2svn $
* Revision 1.85 2005/12/17 03:25:39 vsc
* major changes to support online event-based profiling
* improve error discovery and restart on scanner.
*
* Revision 1.84 2005/09/08 22:06:44 rslopes
* BEAM for YAP update...
*
@ -2241,10 +2245,20 @@ a_f2(int var, cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermed
code_p->opc = emit_op(_p_or_y_vc);
break;
case _sll:
code_p->opc = emit_op(_p_sll_y_vc);
if ((Int)cmp_info->c_arg < 0) {
code_p->opc = emit_op(_p_slr_y_vc);
cmp_info->c_arg = -(Int)cmp_info->c_arg;
} else {
code_p->opc = emit_op(_p_sll_y_vc);
}
break;
case _slr:
code_p->opc = emit_op(_p_slr_y_vc);
if ((Int)cmp_info->c_arg < 0) {
code_p->opc = emit_op(_p_sll_y_vc);
cmp_info->c_arg = -(Int)cmp_info->c_arg;
} else {
code_p->opc = emit_op(_p_slr_y_vc);
}
break;
case _arg:
Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x2_arg, "internal assembler error for arg/3");
@ -2376,10 +2390,20 @@ a_f2(int var, cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermed
code_p->opc = emit_op(_p_or_vc);
break;
case _sll:
code_p->opc = emit_op(_p_sll_vc);
if ((Int)cmp_info->c_arg < 0) {
code_p->opc = emit_op(_p_slr_vc);
cmp_info->c_arg = -(Int)cmp_info->c_arg;
} else {
code_p->opc = emit_op(_p_sll_vc);
}
break;
case _slr:
code_p->opc = emit_op(_p_slr_vc);
if ((Int)cmp_info->c_arg < 0) {
code_p->opc = emit_op(_p_sll_vc);
cmp_info->c_arg = -(Int)cmp_info->c_arg;
} else {
code_p->opc = emit_op(_p_slr_vc);
}
break;
case _arg:
Yap_Error(INTERNAL_COMPILER_ERROR, cmp_info->x2_arg, "internal assembler error for arg/3");

372
C/arith1.c
View File

@ -31,9 +31,12 @@ static char SccsId[] = "%W% %G%";
#define E_FUNC blob_type
#define E_ARGS , arith_retptr o
#define RINT(v) (o)->Int = v; return(long_int_e)
#define RFLOAT(v) (o)->dbl = v; return(double_e)
#define RBIG(v) (o)->big = v; return(big_int_e)
#define TMP_BIG() ((o)->big)
#define RINT(v) (o)->Int = v; return(long_int_e)
#define RFLOAT(v) (o)->dbl = v; return(double_e)
#define RBIG(v) return(big_int_e)
#define RERROR() return(db_ref_e)
#if USE_GMP
static blob_type
float_to_int(Float v, union arith_ret *o)
@ -43,18 +46,32 @@ float_to_int(Float v, union arith_ret *o)
o->Int = i;
return(long_int_e);
} else {
MP_INT *new = Yap_PreAllocBigNum();
mpz_set_d(new, v);
o->big = new;
return(big_int_e);
mpz_init_set_d(o->big, v);
return big_int_e;
}
}
#define RBIG_FL(v) return(float_to_int(v,o))
#else
#define RBIG_FL(v) (o)->Int = (Int)v; return(long_int_e)
#define RBIG_FL(v) (o)->Int = (Int)v; return long_int_e)
#endif
#define RERROR() return(db_ref_e)
static void
process_iso_error(MP_INT *big, Term t, char *operation)
{ /* iso */
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is %s(%s)", operation, s);
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is %s(t)",operation);
P = (yamop *)FAILCODE;
}
}
inline static Functor
AritFunctorOfTerm(Term t) {
@ -81,10 +98,14 @@ EvalToTerm(blob_type f, union arith_ret *res)
return(MkFloatTerm(res->dbl));
#ifdef USE_GMP
case big_int_e:
return(Yap_MkBigIntTerm(res->big));
{
Term t = Yap_MkBigIntTerm(res->big);
mpz_clear(res->big);
return t;
}
#endif
default:
return(TermNil);
return TermNil;
}
}
@ -132,7 +153,9 @@ p_uplus(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
{
RBIG(Yap_BigIntOfTerm(t));
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
RBIG(new);
}
#endif
default:
@ -147,7 +170,9 @@ p_uplus(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
{
RBIG(v.big);
MP_INT *new = TMP_BIG();
MPZ_SET(new, v.big);
RBIG(new);
}
#endif
default:
@ -175,9 +200,10 @@ p_uminus(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = Yap_PreAllocBigNum();
MP_INT *new = TMP_BIG();
mpz_neg(new, Yap_BigIntOfTerm(t));
MPZ_SET(new, Yap_BigIntOfTerm(t));
mpz_neg(new, new);
RBIG(new);
}
#endif
@ -192,12 +218,8 @@ p_uminus(Term t E_ARGS)
RFLOAT(-v.dbl);
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = Yap_PreAllocBigNum();
mpz_neg(new, v.big);
RBIG(new);
}
mpz_neg(v.big, v.big);
RBIG(v.big);
#endif
default:
/* Error */
@ -226,9 +248,10 @@ p_unot(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = Yap_PreAllocBigNum();
mpz_t new;
mpz_com(new, Yap_BigIntOfTerm(t));
mpz_init_set(new, Yap_BigIntOfTerm(t));
mpz_com(new, new);
RBIG(new);
}
#endif
@ -245,12 +268,13 @@ p_unot(Term t E_ARGS)
RERROR();
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = Yap_PreAllocBigNum();
mpz_com(new, v.big);
RBIG(new);
}
{
MP_INT *new = TMP_BIG();
MPZ_SET(new, v.big);
mpz_com(new, new);
RBIG(new);
}
#endif
default:
/* Yap_Error */
@ -276,7 +300,7 @@ p_exp(Term t E_ARGS)
RFLOAT(exp(FloatOfTerm(t)));
#ifdef USE_GMP
case big_int_e:
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
RFLOAT(exp(mpz_get_d(Yap_BigIntOfTerm(t))));
#endif
default:
/* we've got a full term, need to evaluate it first */
@ -289,7 +313,12 @@ p_exp(Term t E_ARGS)
RFLOAT(exp(v.dbl));
#ifdef USE_GMP
case big_int_e:
RFLOAT(mpz_get_d(v.big));
{
double dbl = mpz_get_d(v.big);
mpz_clear(v.big);
RFLOAT(exp(dbl));
}
#endif
default:
/* Yap_Error */
@ -333,8 +362,8 @@ p_log(Term t E_ARGS)
dbl = v.dbl;
break;
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -389,6 +418,7 @@ p_log10(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -443,6 +473,7 @@ p_sqrt(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -498,6 +529,7 @@ p_sin(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -546,6 +578,7 @@ p_cos(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -594,6 +627,7 @@ p_tan(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -642,6 +676,7 @@ p_sinh(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -690,6 +725,7 @@ p_cosh(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -738,6 +774,7 @@ p_tanh(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -786,6 +823,7 @@ p_asin(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -842,6 +880,7 @@ p_acos(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -898,6 +937,7 @@ p_atan(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -946,6 +986,7 @@ p_asinh(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -994,6 +1035,7 @@ p_acosh(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -1050,6 +1092,7 @@ p_atanh(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -1106,6 +1149,7 @@ p_lgamma(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
break;
#endif
default:
@ -1161,8 +1205,8 @@ p_floor(Term t E_ARGS)
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%s)", IntegerOfTerm(t));
mpz_get_str(s, 10, big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%s)", s);
P = (yamop *)FAILCODE;
Yap_FreeCodeSpace(s);
RERROR();
@ -1172,7 +1216,7 @@ p_floor(Term t E_ARGS)
RERROR();
}
} else {
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
@ -1194,23 +1238,25 @@ p_floor(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = v.big;
Int sz = 2+mpz_sizeinbase(big,10);
Int sz = 2+mpz_sizeinbase(v.big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%s)", IntegerOfTerm(t));
mpz_get_str(s, 10, v.big);
mpz_clear(v.big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(%s)", s);
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
mpz_clear(v.big);
Yap_Error(TYPE_ERROR_FLOAT, t, "X is floor(t)");
P = (yamop *)FAILCODE;
RERROR();
}
} else {
RFLOAT(mpz_get_d(v.big));
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
@ -1252,23 +1298,10 @@ p_ceiling(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = Yap_BigIntOfTerm(t);
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is ceiling(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is ceiling(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(Yap_BigIntOfTerm(t), t, "ceiling");
RERROR();
} else {
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
@ -1290,23 +1323,12 @@ p_ceiling(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = v.big;
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is ceiling(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is ceiling(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(v.big, t, "ceiling");
mpz_clear(v.big);
RERROR();
} else {
RFLOAT(mpz_get_d(v.big));
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
@ -1374,24 +1396,11 @@ p_round(Term t E_ARGS)
break;
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = Yap_BigIntOfTerm(t);
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is round(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is round(t)");
P = (yamop *)FAILCODE;
RERROR();
}
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
process_iso_error(Yap_BigIntOfTerm(t), t, "round");
RERROR();
} else {
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
@ -1413,23 +1422,12 @@ p_round(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = v.big;
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s == NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is round(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is round(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(v.big, t, "round");
mpz_clear(v.big);
RERROR();
} else {
RFLOAT(mpz_get_d(v.big));
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
@ -1473,23 +1471,10 @@ p_truncate(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = Yap_BigIntOfTerm(t);
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is truncate(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is truncate(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(Yap_BigIntOfTerm(t), t, "truncate");
RERROR();
} else {
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
dbl = mpz_get_d(Yap_BigIntOfTerm(t));
}
#endif
default:
@ -1511,23 +1496,12 @@ p_truncate(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = v.big;
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s == NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is truncate(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is truncate(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(v.big, t, "truncate");
mpz_clear(v.big);
RERROR();
} else {
RFLOAT(mpz_get_d(v.big));
dbl = mpz_get_d(v.big);
mpz_clear(v.big);
}
#endif
default:
@ -1570,7 +1544,11 @@ p_integer(Term t E_ARGS)
break;
#ifdef USE_GMP
case big_int_e:
RBIG(Yap_BigIntOfTerm(t));
{
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
RBIG(new);
}
#endif
default:
/* we've got a full term, need to evaluate it first */
@ -1584,7 +1562,12 @@ p_integer(Term t E_ARGS)
break;
#ifdef USE_GMP
case big_int_e:
RBIG(v.big);
{
MP_INT *new = TMP_BIG();
MPZ_SET(new,v.big);
RBIG(new);
}
#endif
default:
/* Yap_Error */
@ -1595,9 +1578,9 @@ p_integer(Term t E_ARGS)
RINT((Int) dbl);
} else {
#ifdef USE_GMP
MP_INT *new = Yap_PreAllocBigNum();
mpz_t new;
mpz_set_d(new, dbl);
mpz_init_set_d(new, dbl);
RBIG(new);
#else
Yap_Error(EVALUATION_ERROR_INT_OVERFLOW, MkFloatTerm(dbl), "integer/1");
@ -1637,7 +1620,11 @@ p_float(Term t E_ARGS)
RFLOAT(v.dbl);
#ifdef USE_GMP
case big_int_e:
RFLOAT(mpz_get_d(v.big));
{
Float dbl = mpz_get_d(v.big);
mpz_clear(v.big);
RFLOAT(dbl);
}
#endif
default:
/* Yap_Error */
@ -1689,9 +1676,10 @@ p_abs(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = Yap_PreAllocBigNum();
MP_INT *new = TMP_BIG();
mpz_abs(new, Yap_BigIntOfTerm(t));
mpz_init_set(new, Yap_BigIntOfTerm(t));
mpz_abs(new, new);
RBIG(new);
}
#endif
@ -1707,9 +1695,10 @@ p_abs(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
{
MP_INT *new = Yap_PreAllocBigNum();
MP_INT *new = TMP_BIG();
mpz_abs(new, v.big);
MPZ_SET(new, v.big);
mpz_abs(new, new);
RBIG(new);
}
#endif
@ -1754,7 +1743,12 @@ p_msb(Term t E_ARGS)
RERROR();
#ifdef USE_GMP
case big_int_e:
RINT(mpz_sizeinbase(v.big,2));
{
int sz = mpz_sizeinbase(v.big,2);
mpz_clear(v.big);
RINT(sz);
}
#endif
default:
/* Yap_Error */
@ -1789,21 +1783,8 @@ p_ffracp(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = Yap_BigIntOfTerm(t);
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s != NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(Yap_BigIntOfTerm(t), t, "float_fractional_part");
RERROR();
} else {
RFLOAT(0.0);
}
@ -1827,22 +1808,11 @@ p_ffracp(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = v.big;
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s == NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_fractional_part(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(v.big, t, "float_fractional_part");
mpz_clear(v.big);
RERROR();
} else {
mpz_clear(v.big);
RFLOAT(0.0);
}
#endif
@ -1881,21 +1851,8 @@ p_fintp(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = Yap_BigIntOfTerm(t);
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s == NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_integer_part(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_integer_part(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(Yap_BigIntOfTerm(t), t, "float_integer_part");
RERROR();
} else {
RFLOAT(mpz_get_d(Yap_BigIntOfTerm(t)));
}
@ -1919,23 +1876,13 @@ p_fintp(Term t E_ARGS)
#ifdef USE_GMP
case big_int_e:
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
MP_INT *big = v.big;
Int sz = 2+mpz_sizeinbase(big,10);
char *s = Yap_AllocCodeSpace(sz);
if (s == NULL) {
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_integer_part(%s)", IntegerOfTerm(t));
Yap_FreeCodeSpace(s);
P = (yamop *)FAILCODE;
RERROR();
} else {
Yap_Error(TYPE_ERROR_FLOAT, t, "X is float_integer_part(t)");
P = (yamop *)FAILCODE;
RERROR();
}
process_iso_error(Yap_BigIntOfTerm(t), t, "float_integer_part");
RERROR();
} else {
RFLOAT(mpz_get_d(v.big));
Float dbl = mpz_get_d(v.big);
mpz_clear(v.big);
RFLOAT(dbl);
}
#endif
default:
@ -1983,7 +1930,12 @@ p_sign(Term t E_ARGS)
RINT((v.dbl > 0.0 ? 1 : (v.dbl < 0.0 ? -1 : 0)));
#ifdef USE_GMP
case big_int_e:
RINT(mpz_sgn(v.big));
{
int sgn = mpz_sgn(v.big);
mpz_clear(v.big);
RINT(sgn);
}
#endif
default:
/* Yap_Error */

640
C/arith2.c
View File

File diff suppressed because it is too large Load Diff

16
C/attvar.c
View File

@ -274,8 +274,22 @@ ReplaceAtts(attvar_record *attv, Term oatt, Term att)
{
UInt ar = ArityOfFunctor(FunctorOfTerm(oatt)), i;
CELL *oldp = RepAppl(oatt)+1;
CELL *newp = RepAppl(att)+1;
CELL *newp;
if (oldp > HB) {
oldp++;
newp = RepAppl(att)+2;
/* if deterministic */
for (i=1; i< ar; i++) {
if (*newp != TermFoundVar) {
*oldp = *newp;
}
oldp++;
newp++;
}
return;
}
newp = RepAppl(att)+1;
*newp++ = *oldp++;
for (i=1; i< ar; i++) {
if (*newp == TermFoundVar) {

205
C/bignum.c
View File

@ -30,182 +30,43 @@ static char SccsId[] = "%W% %G%";
#include <string.h>
#endif
/* This global variable tells how things are going */
static CELL *pre_alloc_base = NULL, *alloc_ptr;
/* This is a trivial allocator that use the global space:
Each unit has a:
size;
nof elements;
*/
static void *
AllocBigNumSpace(size_t size)
{
void *ret = (void *)(alloc_ptr+1);
if (pre_alloc_base == NULL) {
return((void *)malloc(size));
}
size = AdjustSize(size)/CellSize;
alloc_ptr[0] = size;
alloc_ptr += size+1;
return(ret);
}
static void *
ReAllocBigNumSpace(void *optr, size_t osize, size_t size)
{
void *out;
if (pre_alloc_base == NULL) {
return((void *)realloc(optr,size));
}
size = AdjustSize(size)/CellSize;
osize = AdjustSize(osize)/CellSize;
if (((CELL *)optr)+osize == alloc_ptr) {
alloc_ptr += (size-osize);
((CELL *)optr)[-1] = size;
return(optr);
}
out = AllocBigNumSpace(size);
memcpy(out, (const void *)optr, size*CellSize);
return(out);
}
static void
FreeBigNumSpace(void *optr, size_t size)
{
CELL *bp = (CELL *)optr;
if (pre_alloc_base == NULL) {
free(optr);
return;
}
size = AdjustSize(size)/CellSize;
if (bp+size == alloc_ptr) {
alloc_ptr = bp-1;
return;
}
/* just say it is free */
bp[-1] = -bp[-1];
}
MP_INT *
Yap_PreAllocBigNum(void)
{
MP_INT *ret;
#ifdef USE_GMP
/* YAP style memory allocation */
mp_set_memory_functions(
AllocBigNumSpace,
ReAllocBigNumSpace,
FreeBigNumSpace);
#endif
if (pre_alloc_base != H) {
/* inform where we are allocating */
alloc_ptr = pre_alloc_base = H;
}
ret = (MP_INT *)(alloc_ptr+1);
/* first reserve space for the functor */
alloc_ptr[0] = 0L;
/* now allocate space for mpz_t */
alloc_ptr = (CELL *)(ret+1);
/* initialise the fields */
mpz_init(ret);
return(ret);
}
void
Yap_CleanBigNum(void)
{
H = pre_alloc_base;
pre_alloc_base = NULL;
}
MP_INT *
Yap_InitBigNum(Int in)
{
MP_INT *ret;
if (pre_alloc_base == NULL) {
/* inform where we are allocating */
alloc_ptr = pre_alloc_base = H;
}
ret = (MP_INT *)(alloc_ptr+1);
/* first reserve space for the functor */
/* I use a 0 to indicate this is the first time
we are building the bignum */
alloc_ptr[0] = 0L;
/* now allocate space for mpz_t */
alloc_ptr = (CELL *)(ret+1);
/* initialise the fields */
mpz_init_set_si(ret, in);
return(ret);
}
/* This can be done in several different situations:
- we did BigIntOf and want to recover now (check through ret[0]);
- we have done PreAlloc() and then a lot happened in between:
o our final computation fits in an Int;
o our final computation is the first we PreAlloced();
o our final computation is not the first term we PreAlloced();
The result may be an Int, the old BigInt, or a BigInt moved to
pre_alloc_base;
*/
Term
Yap_MkBigIntTerm(MP_INT *big)
{
CELL *new = (CELL *)(big+1);
Int nlimbs = (big->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
Int sz;
CELL *ret = ((CELL *)big)-1;
int sz0 = mpz_sizeinbase(big, 2);
Int nlimbs;
MP_INT *dst = (MP_INT *)(H+1);
CELL *ret = H;
sz = mpz_sizeinbase(big, 2);
/* was already there */
if (ret[0] == (CELL)FunctorBigInt) {
/* don't need to do no nothing */
return(AbsAppl(ret));
if (sz0 < SIZEOF_LONG_INT*8-1) {
int out = mpz_get_si(big);
mpz_clear(big);
return MkIntegerTerm(out);
}
if (sz < SIZEOF_LONG_INT*8-1) {
Int out;
H = pre_alloc_base;
pre_alloc_base = NULL;
out = mpz_get_si(big);
return(MkIntegerTerm(out));
} else {
/* we may have created a lot of bignums since we did the first
PreAlloc(). We want to recover the space, not leave "holes" on
the global stack */
if (pre_alloc_base != ret) {
/* copy everything to the start of the temp area */
MP_INT *dst = (MP_INT *)(pre_alloc_base+1);
nlimbs = (big->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
if (nlimbs > (ASP-ret)-1024) {
mpz_clear(big);
return TermNil;
}
H[0] = (CELL)FunctorBigInt;
dst->_mp_size = big->_mp_size;
dst->_mp_alloc = big->_mp_alloc;
new = (CELL *)(dst+1);
ret = pre_alloc_base;
}
ret[0] = (CELL)FunctorBigInt;
memmove((void *)new, (const void *)(big->_mp_d), nlimbs*CellSize);
H = (CELL *)(new+nlimbs);
if ((char *)H-(char *)ret > MAX_SPECIALS_TAG-EndSpecials) {
/* too large */
return TermNil;
}
dst->_mp_size = big->_mp_size;
dst->_mp_alloc = big->_mp_alloc;
memmove((void *)(dst+1), (const void *)(big->_mp_d), nlimbs*CellSize);
H = (CELL *)(dst+1)+nlimbs;
if ((char *)H-(char *)ret > MAX_SPECIALS_TAG-EndSpecials) {
/* too large */
mpz_clear(big);
return TermNil;
}
#if GC_NO_TAGS
H[0] = (H-ret)*sizeof(CELL)+EndSpecials;
H[0] = (H-ret)*sizeof(CELL)+EndSpecials;
#else
H[0] = ((H-ret)*sizeof(CELL)+EndSpecials)|MBIT;
H[0] = ((H-ret)*sizeof(CELL)+EndSpecials)|MBIT;
#endif
H++;
pre_alloc_base = NULL;
return(AbsAppl(ret));
}
H++;
mpz_clear(big);
return AbsAppl(ret);
}
MP_INT *
@ -223,8 +84,9 @@ Term
Yap_MkULLIntTerm(YAP_ULONG_LONG n)
{
#if __GNUC__ && USE_GMP
MP_INT *new = Yap_PreAllocBigNum();
mpz_t new;
char tmp[256];
Term t;
#if HAVE_SNPRINTF
snprintf(tmp,256,"%llu",n);
@ -232,12 +94,13 @@ Yap_MkULLIntTerm(YAP_ULONG_LONG n)
sprintf(tmp,"%llu",n);
#endif
/* try to scan it as a bignum */
mpz_init(new);
mpz_set_str(new, tmp, 10);
mpz_init_set_str (new, tmp, 10);
if (mpz_fits_slong_p(new)) {
return MkIntegerTerm(mpz_get_si(new));
}
return Yap_MkBigIntTerm(new);
t = Yap_MkBigIntTerm(new);
mpz_clear(new);
return t;
#else
return MkIntegerTerm(n);
#endif

25
C/c_interface.c
View File

@ -10,8 +10,11 @@
* File: c_interface.c *
* comments: c_interface primitives definition *
* *
* Last rev: $Date: 2005-11-18 18:48:51 $,$Author: tiagosoares $ *
* Last rev: $Date: 2006-01-02 02:16:18 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.77 2005/11/18 18:48:51 tiagosoares
* support for executing c code when a cut occurs
*
* Revision 1.76 2005/11/03 18:49:26 vsc
* fix bignum conversion
*
@ -224,7 +227,7 @@ X_API Bool STD_PROTO(YAP_IsApplTerm,(Term));
X_API Term STD_PROTO(YAP_MkIntTerm,(Int));
X_API Term STD_PROTO(YAP_MkBigNumTerm,(void *));
X_API Int STD_PROTO(YAP_IntOfTerm,(Term));
X_API void *STD_PROTO(YAP_BigNumOfTerm,(Term));
X_API void STD_PROTO(YAP_BigNumOfTerm,(Term, void *));
X_API Term STD_PROTO(YAP_MkFloatTerm,(flt));
X_API flt STD_PROTO(YAP_FloatOfTerm,(Term));
X_API Term STD_PROTO(YAP_MkAtomTerm,(Atom));
@ -418,10 +421,7 @@ YAP_MkBigNumTerm(void *big)
#if USE_GMP
Term I;
BACKUP_H();
MP_INT *new = Yap_PreAllocBigNum();
mpz_set(new, (MP_INT *)big);
I = Yap_MkBigIntTerm(new);
I = Yap_MkBigIntTerm((MP_INT *)big);
RECOVER_H();
return I;
#else
@ -429,17 +429,16 @@ YAP_MkBigNumTerm(void *big)
#endif /* USE_GMP */
}
X_API void *
YAP_BigNumOfTerm(Term t)
X_API void
YAP_BigNumOfTerm(Term t, void *b)
{
#if USE_GMP
MP_INT *bz = (MP_INT *)b;
if (IsVarTerm(t))
return NULL;
return;
if (!IsBigIntTerm(t))
return NULL;
return (void *)Yap_BigIntOfTerm(t);
#else
return NULL;
return;
mpz_init_set(bz,Yap_BigIntOfTerm(t));
#endif /* USE_GMP */
}

24
C/eval.c
View File

@ -33,7 +33,8 @@ yap_error_number Yap_matherror = YAP_NO_ERROR;
#define E_ARGS arith_retptr o
#define USE_E_ARGS o
#define RBIG(v) (o)->big = v; return(big_int_e)
#define TMP_BIG() ((o)->big)
#define RBIG(v) return(big_int_e)
#define RINT(v) (o)->Int = v; return(long_int_e)
#define RFLOAT(v) (o)->dbl = v; return(double_e)
#define RERROR() return(db_ref_e)
@ -72,7 +73,11 @@ Eval(Term t, E_ARGS)
RFLOAT(FloatOfTerm(t));
#ifdef USE_GMP
case (CELL)FunctorBigInt:
RBIG(Yap_BigIntOfTerm(t));
{
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
RBIG(new);
}
#endif
default:
{
@ -128,6 +133,7 @@ Yap_Eval(Term t, E_ARGS)
}
if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
switch ((CELL)fun) {
case (CELL)FunctorLongInt:
RINT(LongIntOfTerm(t));
@ -135,7 +141,11 @@ Yap_Eval(Term t, E_ARGS)
RFLOAT(FloatOfTerm(t));
#ifdef USE_GMP
case (CELL)FunctorBigInt:
RBIG(Yap_BigIntOfTerm(t));
{
MP_INT *new = TMP_BIG();
mpz_init_set(new, Yap_BigIntOfTerm(t));
RBIG(new);
}
#endif
default:
{
@ -202,9 +212,15 @@ p_is(void)
{ /* X is Y */
union arith_ret res;
blob_type bt;
Term out;
bt = Eval(Deref(ARG2), &res);
return (Yap_unify_constant(ARG1,EvalToTerm(bt,&res)));
out = EvalToTerm(bt,&res);
if (out == TermNil) {
Yap_Error(EVALUATION_ERROR_INT_OVERFLOW, ARG2, "is/2");
return FALSE;
}
return Yap_unify_constant(ARG1,out);
}
void

3
C/grow.c
View File

@ -634,12 +634,14 @@ static_growglobal(long size, CELL **ptr)
Int ReallocDiff;
/* adjust to a multiple of 256) */
Yap_PrologMode |= GrowStackMode;
if (size < (omax-Yap_GlobalBase)/8)
size = (omax-Yap_GlobalBase)/8;
size = AdjustPageSize(size);
Yap_ErrorMessage = NULL;
if (!Yap_ExtendWorkSpace(size)) {
Yap_ErrorMessage = "Global Stack crashed against Local Stack";
Yap_PrologMode &= ~GrowStackMode;
return FALSE;
}
start_growth_time = Yap_cputime();
@ -671,6 +673,7 @@ static_growglobal(long size, CELL **ptr)
fprintf(Yap_stderr, "%% DO took %g sec\n", (double)growth_time/1000);
fprintf(Yap_stderr, "%% DO Total of %g sec expanding stacks \n", (double)total_delay_overflow_time/1000);
}
Yap_PrologMode &= ~GrowStackMode;
return(TRUE);
}

9
C/heapgc.c
View File

@ -153,9 +153,6 @@ gc_growtrail(int committed)
#if !GC_TAGS
YAPLeaveCriticalSection();
#endif
#if THREADS
longjmp(Yap_gc_restore, 2);
#endif
#if USE_SYSTEM_MALLOC
TR = OldTR;
#endif
@ -166,9 +163,11 @@ gc_growtrail(int committed)
#if USE_SYSTEM_MALLOC
#if !GC_NO_TAGS
if (committed) {
save_machine_regs();
longjmp(Yap_gc_restore, 2);
}
#endif
save_machine_regs();
longjmp(Yap_gc_restore, 1);
#endif
@ -3606,6 +3605,7 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
#endif /* GC_NO_TAGS */
if (setjmp(Yap_gc_restore) == 2) {
/* we cannot recover, fail system */
restore_machine_regs();
*--ASP = (CELL)current_env;
TR = OldTR;
if (
@ -3825,7 +3825,8 @@ Yap_gc(Int predarity, CELL *current_env, yamop *nextop)
int res;
Yap_PrologMode |= GCMode;
res=call_gc(4096, predarity, current_env, nextop);
Yap_PrologMode &= ~GCMode;
if (Yap_PrologMode & GCMode)
Yap_PrologMode &= ~GCMode;
return res;
}

1
C/init.c
View File

@ -1110,6 +1110,7 @@ InitCodes(void)
AtomVar = Yap_FullLookupAtom("$VAR");
Yap_heap_regs->atom_version_number = Yap_FullLookupAtom("$version_name");
Yap_heap_regs->atom_write = Yap_LookupAtom ("write");
Yap_heap_regs->float_format = Yap_LookupAtom ("\%.15g");
#ifdef USE_SOCKET
Yap_heap_regs->functor_af_inet = Yap_MkFunctor(Yap_LookupAtom("AF_INET"),2);
Yap_heap_regs->functor_af_local = Yap_MkFunctor(Yap_LookupAtom("AF_LOCAL"),1);

24
C/iopreds.c
View File

@ -666,6 +666,7 @@ MemPutc(int sno, int ch)
if ((newbuf = Yap_AllocAtomSpace(new_max_size*sizeof(char))) == NULL) {
if (Stream[sno].u.mem_string.error_handler) {
Yap_Error_Size = new_max_size*sizeof(char);
save_machine_regs();
longjmp(*(jmp_buf *)Stream[sno].u.mem_string.error_handler,1);
} else {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP could not grow heap for writing to string");
@ -2267,6 +2268,7 @@ CheckAlias (Atom arg)
{
AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases;
while (aliasp < aliasp_max) {
if (aliasp->name == arg) {
return(aliasp->alias_stream);
@ -2328,9 +2330,8 @@ CheckStream (Term arg, int kind, char *msg)
arg = Deref (arg);
if (IsVarTerm (arg)) {
Yap_Error(INSTANTIATION_ERROR, arg, msg);
return (-1);
}
else if (IsAtomTerm (arg)) {
return -1;
} else if (IsAtomTerm (arg)) {
Atom sname = AtomOfTerm (arg);
if (sname == AtomUser) {
@ -3184,7 +3185,10 @@ static Int
v = Yap_VarNames(Yap_VarTable, TermNil);
break;
} else {
tr_fr_ptr old_TR = TR;
tr_fr_ptr old_TR;
restore_machine_regs();
old_TR = TR;
/* don't need to recheck tokens */
tokstart = NULL;
/* restart global */
@ -3912,6 +3916,7 @@ format(volatile Term otail, volatile Term oargs, int sno)
old_pos = Stream[sno].u.mem_string.pos;
/* set up an error handler */
if (setjmp(format_botch)) {
restore_machine_regs();
*H++ = oargs;
*H++ = otail;
if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
@ -4985,6 +4990,16 @@ p_same_file(void) {
#endif
}
static Int
p_float_format(void)
{
Term in = Deref(ARG1);
if (IsVarTerm(in))
return Yap_unify(ARG1, MkAtomTerm(FloatFormat));
FloatFormat = AtomOfTerm(in);
return TRUE;
}
Term
Yap_StringToTerm(char *s,Term *tp)
@ -5129,6 +5144,7 @@ Yap_InitIOPreds(void)
Yap_InitCPred ("stream_select", 3, p_stream_select, SafePredFlag|SyncPredFlag);
#endif
Yap_InitCPred ("$same_file", 2, p_same_file, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred ("$float_format", 1, p_float_format, SafePredFlag|SyncPredFlag|HiddenPredFlag);
#if USE_SOCKET
Yap_InitSockets ();

4
C/parser.c
View File

@ -179,6 +179,7 @@ VarNames(VarEntry *p,Term l)
VarNames(p->VarRight,
VarNames(p->VarLeft,l)));
if (H > ASP-4096) {
save_machine_regs();
longjmp(Yap_IOBotch,1);
}
return(o);
@ -436,8 +437,9 @@ ParseTerm(int prio, JMPBUFF *FailBuff)
t = MkFloatTerm(-FloatOfTerm(t));
#ifdef USE_GMP
else if (IsBigIntTerm(t)) {
MP_INT *new = Yap_PreAllocBigNum();
mpz_t new;
mpz_init(new);
mpz_neg(new, Yap_BigIntOfTerm(t));
t = Yap_MkBigIntTerm(new);
}

6
C/scanner.c
View File

@ -224,10 +224,12 @@ read_int_overflow(const char *s, Int base, Int val)
{
#ifdef USE_GMP
/* try to scan it as a bignum */
MP_INT *new = Yap_PreAllocBigNum();
mpz_t new;
Term t;
mpz_init_set_str (new, s, base);
return(Yap_MkBigIntTerm(new));
t = Yap_MkBigIntTerm(new);
return t;
#else
/* try to scan it as a float */
return(MkIntegerTerm(val));

28
C/write.c
View File

@ -117,12 +117,18 @@ wrputf(Float f, wrf writech) /* writes a float */
wrputc(' ', writech);
}
lastw = alphanum;
sprintf(s, "%.15g", f);
// sprintf(s, "%.15g", f);
sprintf(s, RepAtom(FloatFormat)->StrOfAE, f);
while (*pt == ' ')
pt++;
if (*pt == 'i' || *pt == 'n') /* inf or nan */
if (*pt == 'i' || *pt == 'n') /* inf or nan */ {
wrputc('(', writech);
wrputc('+', writech);
wrputs(pt, writech);
wrputs(pt, writech);
wrputc(')', writech);
} else {
wrputs(pt, writech);
}
if (*pt == '-') pt++;
while ((ch = *pt) != '\0') {
if (ch < '0' || ch > '9')
@ -448,9 +454,19 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb)
case (CELL)FunctorBigInt:
{
char *s = (char *)TR;
while (s+2+mpz_sizeinbase(Yap_BigIntOfTerm(t), 10) > (char *)Yap_TrailTop)
Yap_growtrail(2+mpz_sizeinbase(Yap_BigIntOfTerm(t), 10), TRUE);
mpz_get_str(s, 10, Yap_BigIntOfTerm(t));
MP_INT *big = Yap_BigIntOfTerm(t);
while (s+2+mpz_sizeinbase(big, 10) > (char *)Yap_TrailTop) {
Yap_growtrail(2+mpz_sizeinbase(big, 10), TRUE);
big = Yap_BigIntOfTerm(t);
}
if (mpz_sgn(big) < 0) {
if (lastw == symbol)
wrputc(' ', wglb->writech);
} else {
if (lastw == alphanum)
wrputc(' ', wglb->writech);
}
mpz_get_str(s, 10, big);
wrputs(s,wglb->writech);
}
return;

7
CLPBN/clpbn/viterbi.yap
View File

@ -8,16 +8,11 @@
:- use_module(library(clpbn), []).
:- use_module(library('clpbn/utils'), [
sort_vars_by_key_and_parents/3]).
:- attribute prob/1, emission/1, backp/1, ancestors/1.
viterbi(Start,End,Trace,Ticks,Slices) :-
attributes:all_attvars(Vars0),
sort_vars_by_key_and_parents(Vars0,Vars,_),
add_emissions(Vars),
topsort_vars(Vars,SortedVars),
group_vars_by_key_and_parents(Vars0,Ticks,Slices),
init_viterbi(Start),
viterbi_alg([Start|R],R),
backtrace(Start,End,[],Trace).

10
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.89 2005-12-17 03:25:39 vsc Exp $ *
* version: $Id: Heap.h,v 1.90 2006-01-02 02:16:18 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -81,6 +81,9 @@ typedef struct worker_local_struct {
#if defined(YAPOR) || defined(THREADS)
lockvar signal_lock; /* protect signal handlers from IPIs */
struct pred_entry *wpp;
#endif
#ifdef USE_GMP
mpz_t big_tmp;
#endif
UInt active_signals;
UInt i_pred_arity;
@ -368,6 +371,8 @@ typedef struct various_codes {
atom_usr_err,
atom_version_number,
atom_write;
Atom answer_format,
float_format;
Functor
#ifdef USE_SOCKET
functor_af_inet,
@ -637,6 +642,7 @@ struct various_codes *Yap_heap_regs;
#define AtomUsrOut Yap_heap_regs->atom_usr_out
#define AtomVersionNumber Yap_heap_regs->atom_version_number
#define AtomWrite Yap_heap_regs->atom_write
#define FloatFormat Yap_heap_regs->float_format
#ifdef USE_SOCKET
#define FunctorAfInet Yap_heap_regs->functor_af_inet
#define FunctorAfLocal Yap_heap_regs->functor_af_local
@ -767,6 +773,7 @@ struct various_codes *Yap_heap_regs;
#define WPP Yap_heap_regs->wl[worker_id].wpp
#define UncaughtThrow Yap_heap_regs->wl[worker_id].uncaught_throw
#define DoingUndefp Yap_heap_regs->wl[worker_id].doing_undefp
#define Yap_BigTmp Yap_heap_regs->wl[worker_id].big_tmp
#define ActiveSignals Yap_heap_regs->wl[worker_id].active_signals
#define IPredArity Yap_heap_regs->wl[worker_id].i_pred_arity
#define ProfEnd Yap_heap_regs->wl[worker_id].prof_end
@ -832,6 +839,7 @@ struct various_codes *Yap_heap_regs;
#define FormatInfo Yap_heap_regs->wl.f_info
#define ScannerStack Yap_heap_regs->wl.scanner_stack
#define ScannerExtraBlocks Yap_heap_regs->wl.scanner_extra_blocks
#define Yap_BigTmp Yap_heap_regs->wl.big_tmp
#define ActiveSignals Yap_heap_regs->wl.active_signals
#define IPredArity Yap_heap_regs->wl.i_pred_arity
#define ProfEnd Yap_heap_regs->wl.prof_end

15
H/TermExt.h
View File

@ -10,7 +10,7 @@
* File: TermExt.h *
* mods: *
* comments: Extensions to standard terms for YAP *
* version: $Id: TermExt.h,v 1.3 2005-11-23 03:01:33 vsc Exp $ *
* version: $Id: TermExt.h,v 1.4 2006-01-02 02:16:18 vsc Exp $ *
*************************************************************************/
#ifdef USE_SYSTEM_MALLOC
@ -342,12 +342,8 @@ IsLongIntTerm (Term t)
#include <gmp.h>
MP_INT *STD_PROTO (Yap_PreAllocBigNum, (void));
MP_INT *STD_PROTO (Yap_InitBigNum, (Int));
Term STD_PROTO (Yap_MkBigIntTerm, (MP_INT *));
MP_INT *STD_PROTO (Yap_BigIntOfTerm, (Term));
void STD_PROTO (Yap_CleanBigNum, (void));
inline EXTERN int IsBigIntTerm (Term);
@ -357,8 +353,15 @@ IsBigIntTerm (Term t)
return (int) (IsApplTerm (t) && FunctorOfTerm (t) == FunctorBigInt);
}
inline EXTERN void MPZ_SET (mpz_t, MP_INT *);
inline EXTERN void
MPZ_SET (mpz_t dest, MP_INT *src)
{
dest->_mp_size = src->_mp_size;
dest->_mp_alloc = src->_mp_alloc;
dest->_mp_d = src->_mp_d;
}
inline EXTERN int IsLargeIntTerm (Term);

555
H/arith2.h
View File

File diff suppressed because it is too large Load Diff

2
H/eval.h
View File

@ -43,7 +43,7 @@ typedef union arith_ret {
Int Int;
Float dbl;
#ifdef USE_GMP
MP_INT *big;
mpz_t big;
#endif
} *arith_retptr;

7
H/rheap.h
View File

@ -11,8 +11,12 @@
* File: rheap.h *
* comments: walk through heap code *
* *
* Last rev: $Date: 2005-12-17 03:25:39 $,$Author: vsc $ *
* Last rev: $Date: 2006-01-02 02:16:18 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.60 2005/12/17 03:25:39 vsc
* major changes to support online event-based profiling
* improve error discovery and restart on scanner.
*
* Revision 1.59 2005/12/05 17:16:11 vsc
* write_depth/3
* overflow handlings and garbage collection
@ -372,6 +376,7 @@ restore_codes(void)
Yap_heap_regs->atom_usr_out = AtomAdjust(Yap_heap_regs->atom_usr_out);
Yap_heap_regs->atom_version_number = AtomAdjust(Yap_heap_regs->atom_version_number);
Yap_heap_regs->atom_write = AtomAdjust(Yap_heap_regs->atom_write);
Yap_heap_regs->float_format = AtomAdjust(Yap_heap_regs->float_format);
#ifdef USE_SOCKET
Yap_heap_regs->functor_af_inet = FuncAdjust(Yap_heap_regs->functor_af_inet);
Yap_heap_regs->functor_af_local = FuncAdjust(Yap_heap_regs->functor_af_local);

5
changes-5.1.html
View File

@ -16,6 +16,11 @@
<h2>Yap-5.1.0:</h2>
<ul>
<li> NEW: SWI-like yap_flag(float_format,_). </li>
<li> FIXED: change C-interface to use new interface. </li>
<li> FIXED: << and >> should handle overflows. </li>
<li> FIXED: mod and rem now implement ISO semantics (hopefully). </li>
<li> FIXED: change implementation of bigints to be more like GMP style. </li>
<li> FIXED: handle assert/retracts and gprof overhead right. </li>
<li> FIXED: indexing code was not setting up properly registers on longjmps. </li>
<li> FIXED: use RISC architecture on MacOsX (__POWERPC__ + _POWER). </li>

9
docs/yap.tex
View File

@ -6277,6 +6277,15 @@ available in experimental implementations.
If @code{on} @code{fileerrors} is @code{on}, if @code{off} (default)
@code{fileerrors} is disabled.
@item float_format
@findex float_format (yap_flag/2 option)
@* C-library @code{printf()} format specification used by @code{write/1} and
friends to determine how floating point numbers are printed. The
default is @code{%.15g}. The specified value is passed to @code{printf()}
without further checking. For example, if you want less digits
printed, @code{%g} will print all floats using 6 digits instead of the
default 15.
@item gc
@findex gc (yap_flag/2 option)
@*

2
pl/arith.yap
View File

@ -275,6 +275,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
'$binaryop'(X*Y ,* ,X,Y).
'$binaryop'(X/Y ,/ ,X,Y).
'$binaryop'(X mod Y ,mod ,X,Y).
'$binaryop'(X rem Y ,rem ,X,Y).
'$binaryop'(X//Y ,// ,X,Y).
'$binaryop'(X/\Y ,/\ ,X,Y).
'$binaryop'(X\/Y ,\/ ,X,Y).
@ -287,7 +288,6 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
'$binaryop'(max(X,Y) ,max ,X,Y).
'$binaryop'(min(X,Y) ,min ,X,Y).
'$binaryop'(gcd(X,Y) ,gcd ,X,Y).
'$binaryop'(gcdmult(X,Y),gcdmult,X,Y).
% The table number for each operation is given here

670
pl/boot.yap
View File

@ -27,7 +27,7 @@ true :- true.
'$do_live' :-
repeat,
'$set_input'(user),'$set_output'(user),
'$set_input'(user_input),'$set_output'(user),
'$current_module'(Module),
( Module==user ->
'$compile_mode'(_,0)
@ -65,380 +65,380 @@ true :- true.
;
'$current_module'(_,V), '$compile_mode'(_,0),
('$access_yap_flags'(16,0) ->
( exists('~/.yaprc') -> load_files('~/.yaprc', []) ; true ),
( exists('~/.prologrc') -> load_files('~/.prologrc', []) ; true ),
( exists('~/prolog.ini') -> load_files('~/prolog.ini', []) ; true )
;
true
)
),
'$db_clean_queues'(0),
'$startup_reconsult',
'$startup_goals'
;
'$print_message'(informational,break(BreakLevel))
).
( exists('~/.yaprc') -> load_files('~/.yaprc', []) ; true ),
( exists('~/.prologrc') -> load_files('~/.prologrc', []) ; true ),
( exists('~/prolog.ini') -> load_files('~/prolog.ini', []) ; true )
;
true
)
),
'$db_clean_queues'(0),
'$startup_reconsult',
'$startup_goals'
;
'$print_message'(informational,break(BreakLevel))
).
%
% encapsulate $cut_by because of co-routining.
%
'$cut_by'(X) :- '$$cut_by'(X).
%
% encapsulate $cut_by because of co-routining.
%
'$cut_by'(X) :- '$$cut_by'(X).
% Start file for yap
% Start file for yap
/* I/O predicates */
/* I/O predicates */
/* meaning of flags for '$write' is
1 quote illegal atoms
2 ignore operator declarations
4 output '$VAR'(N) terms as A, B, C, ...
8 use portray(_)
*/
/* meaning of flags for '$write' is
1 quote illegal atoms
2 ignore operator declarations
4 output '$VAR'(N) terms as A, B, C, ...
8 use portray(_)
*/
/* main execution loop */
'$read_vars'(Stream,T,Mod,Pos,V) :-
'$read'(true,T,Mod,V,Pos,Err,Stream),
(nonvar(Err) ->
'$print_message'(error,Err), fail
;
true
).
/* main execution loop */
'$read_vars'(Stream,T,Mod,Pos,V) :-
'$read'(true,T,Mod,V,Pos,Err,Stream),
(nonvar(Err) ->
'$print_message'(error,Err), fail
;
true
).
% reset alarms when entering top-level.
'$enter_top_level' :-
'$alarm'(0, _),
fail.
'$enter_top_level' :-
'$clean_up_dead_clauses',
fail.
'$enter_top_level' :-
recorded('$restore_goal',G,R),
erase(R),
prompt(_,' | '),
'$system_catch'('$do_yes_no'((G->true),user),user,Error,user:'$Error'(Error)),
fail.
'$enter_top_level' :-
get_value('$break',BreakLevel),
( recorded('$trace',on,_) ->
TraceDebug = trace
;
recorded('$debug', on, _) ->
TraceDebug = debug
;
true
),
'$print_message'(informational,prompt(BreakLevel,TraceDebug)),
fail.
'$enter_top_level' :-
'$current_module'(Module),
get_value('$top_level_goal',GA), GA \= [], !,
set_value('$top_level_goal',[]),
'$run_atom_goal'(GA),
set_value('$live','$false').
'$enter_top_level' :-
prompt(_,' ?- '),
prompt(' | '),
'$run_toplevel_hooks',
'$read_vars'(user_input,Command,_,_,Varnames),
set_value(spy_gn,1),
( recorded('$spy_skip',_,R), erase(R), fail ; true),
( recorded('$spy_stop',_,R), erase(R), fail ; true),
prompt(_,' |: '),
'$command'((?-Command),Varnames,top),
'$sync_mmapped_arrays',
set_value('$live','$false').
% reset alarms when entering top-level.
'$enter_top_level' :-
'$alarm'(0, _),
fail.
'$enter_top_level' :-
'$clean_up_dead_clauses',
fail.
'$enter_top_level' :-
recorded('$restore_goal',G,R),
erase(R),
prompt(_,' | '),
'$system_catch'('$do_yes_no'((G->true),user),user,Error,user:'$Error'(Error)),
fail.
'$enter_top_level' :-
get_value('$break',BreakLevel),
( recorded('$trace',on,_) ->
TraceDebug = trace
;
recorded('$debug', on, _) ->
TraceDebug = debug
;
true
),
'$print_message'(informational,prompt(BreakLevel,TraceDebug)),
fail.
'$enter_top_level' :-
'$current_module'(Module),
get_value('$top_level_goal',GA), GA \= [], !,
set_value('$top_level_goal',[]),
'$run_atom_goal'(GA),
set_value('$live','$false').
'$enter_top_level' :-
prompt(_,' ?- '),
prompt(' | '),
'$run_toplevel_hooks',
'$read_vars'(user_input,Command,_,_,Varnames),
set_value(spy_gn,1),
( recorded('$spy_skip',_,R), erase(R), fail ; true),
( recorded('$spy_stop',_,R), erase(R), fail ; true),
prompt(_,' |: '),
'$command'((?-Command),Varnames,top),
'$sync_mmapped_arrays',
set_value('$live','$false').
'$startup_goals' :-
get_value('$extend_file_search_path',P), P \= [],
set_value('$extend_file_search_path',[]),
'$extend_file_search_path'(P),
fail.
'$startup_goals' :-
recorded('$startup_goal',G,_),
'$current_module'(Module),
'$system_catch'('$query'(once(G), []),Module,Error,user:'$Error'(Error)),
fail.
'$startup_goals' :-
get_value('$init_goal',GA), GA \= [],
set_value('$init_goal',[]),
'$run_atom_goal'(GA),
fail.
'$startup_goals'.
'$startup_goals' :-
get_value('$extend_file_search_path',P), P \= [],
set_value('$extend_file_search_path',[]),
'$extend_file_search_path'(P),
fail.
'$startup_goals' :-
recorded('$startup_goal',G,_),
'$current_module'(Module),
'$system_catch'('$query'(once(G), []),Module,Error,user:'$Error'(Error)),
fail.
'$startup_goals' :-
get_value('$init_goal',GA), GA \= [],
set_value('$init_goal',[]),
'$run_atom_goal'(GA),
fail.
'$startup_goals'.
'$startup_reconsult' :-
get_value('$consult_on_boot',X), X \= [], !,
set_value('$consult_on_boot',[]),
'$do_startup_reconsult'(X).
'$startup_reconsult'.
'$startup_reconsult' :-
get_value('$consult_on_boot',X), X \= [], !,
set_value('$consult_on_boot',[]),
'$do_startup_reconsult'(X).
'$startup_reconsult'.
%
% remove any debugging info after an abort.
%
'$clean_debugging_info' :-
recorded('$spy',_,R),
erase(R),
fail.
'$clean_debugging_info'.
%
% remove any debugging info after an abort.
%
'$clean_debugging_info' :-
recorded('$spy',_,R),
erase(R),
fail.
'$clean_debugging_info'.
'$erase_sets' :-
eraseall('$'),
eraseall('$$set'),
eraseall('$$one'),
eraseall('$reconsulted'), fail.
'$erase_sets' :- \+ recorded('$path',_,_), recorda('$path',"",_).
'$erase_sets'.
'$erase_sets' :-
eraseall('$'),
eraseall('$$set'),
eraseall('$$one'),
eraseall('$reconsulted'), fail.
'$erase_sets' :- \+ recorded('$path',_,_), recorda('$path',"",_).
'$erase_sets'.
'$version' :-
get_value('$version_name',VersionName),
'$print_message'(help, version(VersionName)),
fail.
'$version' :- recorded('$version',VersionName,_),
'$print_message'(help, VersionName),
fail.
'$version'.
'$version' :-
get_value('$version_name',VersionName),
'$print_message'(help, version(VersionName)),
fail.
'$version' :- recorded('$version',VersionName,_),
'$print_message'(help, VersionName),
fail.
'$version'.
repeat :- '$repeat'.
repeat :- '$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat' :- '$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat'.
'$repeat' :- '$repeat'.
'$start_corouts' :- recorded('$corout','$corout'(Name,_,_),R), Name \= main, finish_corout(R),
fail.
'$start_corouts' :-
eraseall('$corout'),
eraseall('$result'),
eraseall('$actual'),
fail.
'$start_corouts' :- recorda('$actual',main,_),
recordz('$corout','$corout'(main,main,'$corout'([],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[])),_Ref),
recorda('$result',going,_).
'$start_corouts' :- recorded('$corout','$corout'(Name,_,_),R), Name \= main, finish_corout(R),
fail.
'$start_corouts' :-
eraseall('$corout'),
eraseall('$result'),
eraseall('$actual'),
fail.
'$start_corouts' :- recorda('$actual',main,_),
recordz('$corout','$corout'(main,main,'$corout'([],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[])),_Ref),
recorda('$result',going,_).
'$command'(C,VL,Con) :-
'$access_yap_flags'(9,1), !,
'$execute_command'(C,VL,Con,C).
'$command'(C,VL,Con) :-
( (Con = top ; var(C) ; C = [_|_]) ->
'$execute_command'(C,VL,Con,C), ! ;
expand_term(C, EC),
'$execute_commands'(EC,VL,Con,C)
).
'$command'(C,VL,Con) :-
'$access_yap_flags'(9,1), !,
'$execute_command'(C,VL,Con,C).
'$command'(C,VL,Con) :-
( (Con = top ; var(C) ; C = [_|_]) ->
'$execute_command'(C,VL,Con,C), ! ;
expand_term(C, EC),
'$execute_commands'(EC,VL,Con,C)
).
%
% Hack in case expand_term has created a list of commands.
%
'$execute_commands'(V,_,_,Source) :- var(V), !,
'$do_error'(instantiation_error,meta_call(Source)).
'$execute_commands'([],_,_,_) :- !, fail.
'$execute_commands'([C|Cs],VL,Con,Source) :- !,
(
'$execute_command'(C,VL,Con,Source)
;
'$execute_commands'(Cs,VL,Con,Source)
),
fail.
'$execute_commands'(C,VL,Con,Source) :-
'$execute_command'(C,VL,Con,Source).
%
% Hack in case expand_term has created a list of commands.
%
'$execute_commands'(V,_,_,Source) :- var(V), !,
'$do_error'(instantiation_error,meta_call(Source)).
'$execute_commands'([],_,_,_) :- !, fail.
'$execute_commands'([C|Cs],VL,Con,Source) :- !,
(
'$execute_command'(C,VL,Con,Source)
;
'$execute_commands'(Cs,VL,Con,Source)
),
fail.
'$execute_commands'(C,VL,Con,Source) :-
'$execute_command'(C,VL,Con,Source).
%
%
%
%
%
%
'$execute_command'(C,_,top,Source) :- var(C), !,
'$do_error'(instantiation_error,meta_call(Source)).
'$execute_command'(C,_,top,Source) :- number(C), !,
'$do_error'(type_error(callable,C),meta_call(Source)).
'$execute_command'(R,_,top,Source) :- db_reference(R), !,
'$do_error'(type_error(callable,R),meta_call(Source)).
'$execute_command'(end_of_file,_,_,_) :- !.
'$execute_command'((:-G),_,Option,_) :- !,
'$current_module'(M),
'$process_directive'(G, Option, M),
fail.
'$execute_command'((?-G),V,_,Source) :- !,
'$execute_command'(G,V,top,Source).
'$execute_command'(G,V,Option,Source) :-
'$continue_with_command'(Option,V,G,Source).
'$execute_command'(C,_,top,Source) :- var(C), !,
'$do_error'(instantiation_error,meta_call(Source)).
'$execute_command'(C,_,top,Source) :- number(C), !,
'$do_error'(type_error(callable,C),meta_call(Source)).
'$execute_command'(R,_,top,Source) :- db_reference(R), !,
'$do_error'(type_error(callable,R),meta_call(Source)).
'$execute_command'(end_of_file,_,_,_) :- !.
'$execute_command'((:-G),_,Option,_) :- !,
'$current_module'(M),
'$process_directive'(G, Option, M),
fail.
'$execute_command'((?-G),V,_,Source) :- !,
'$execute_command'(G,V,top,Source).
'$execute_command'(G,V,Option,Source) :-
'$continue_with_command'(Option,V,G,Source).
%
% This command is very different depending on the language mode we are in.
%
% ISO only wants directives in files
% SICStus accepts everything in files
% YAP accepts everything everywhere
%
'$process_directive'(G, top, M) :-
'$access_yap_flags'(8, 0), !, % YAP mode, go in and do it,
'$process_directive'(G, consult, M).
'$process_directive'(G, top, _) :- !,
'$do_error'(context_error((:- G),clause),query).
%
% allow modules
%
'$process_directive'(M:G, Mode, _) :- !,
'$process_directive'(G, Mode, M).
%
% default case
%
'$process_directive'(Gs, Mode, M) :-
'$all_directives'(Gs), !,
'$exec_directives'(Gs, Mode, M).
%
% This command is very different depending on the language mode we are in.
%
% ISO only wants directives in files
% SICStus accepts everything in files
% YAP accepts everything everywhere
%
'$process_directive'(G, top, M) :-
'$access_yap_flags'(8, 0), !, % YAP mode, go in and do it,
'$process_directive'(G, consult, M).
'$process_directive'(G, top, _) :- !,
'$do_error'(context_error((:- G),clause),query).
%
% allow modules
%
'$process_directive'(M:G, Mode, _) :- !,
'$process_directive'(G, Mode, M).
%
% default case
%
'$process_directive'(Gs, Mode, M) :-
'$all_directives'(Gs), !,
'$exec_directives'(Gs, Mode, M).
%
% ISO does not allow goals (use initialization).
%
'$process_directive'(D, _, M) :-
'$access_yap_flags'(8, 1), !, % ISO Prolog mode, go in and do it,
'$do_error'(context_error((:- M:D),query),directive).
%
% but YAP and SICStus does.
%
'$process_directive'(G, _, M) :-
( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ),
'$do_not_creep'.
%
% ISO does not allow goals (use initialization).
%
'$process_directive'(D, _, M) :-
'$access_yap_flags'(8, 1), !, % ISO Prolog mode, go in and do it,
'$do_error'(context_error((:- M:D),query),directive).
%
% but YAP and SICStus does.
%
'$process_directive'(G, _, M) :-
( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ),
'$do_not_creep'.
'$continue_with_command'(reconsult,V,G,Source) :-
'$go_compile_clause'(G,V,5,Source),
fail.
'$continue_with_command'(consult,V,G,Source) :-
'$go_compile_clause'(G,V,13,Source),
fail.
'$continue_with_command'(top,V,G,_) :-
'$query'(G,V),
'$do_not_creep'.
'$continue_with_command'(reconsult,V,G,Source) :-
'$go_compile_clause'(G,V,5,Source),
fail.
'$continue_with_command'(consult,V,G,Source) :-
'$go_compile_clause'(G,V,13,Source),
fail.
'$continue_with_command'(top,V,G,_) :-
'$query'(G,V),
'$do_not_creep'.
%
% not 100% compatible with SICStus Prolog, as SICStus Prolog would put
% module prefixes all over the place, although unnecessarily so.
%
'$go_compile_clause'(Mod:G,V,N,Source) :- !,
'$go_compile_clause'(G,V,N,Mod,Source).
'$go_compile_clause'((M:G :- B),V,N,Source) :- !,
'$current_module'(M1),
(M1 = M ->
NG = (G :- B)
;
'$preprocess_clause_before_mod_change'((G:-B),M1,M,NG)
),
'$go_compile_clause'(NG,V,N,M,Source).
'$go_compile_clause'(G,V,N,Source) :-
'$current_module'(Mod),
'$go_compile_clause'(G,V,N,Mod,Source).
%
% not 100% compatible with SICStus Prolog, as SICStus Prolog would put
% module prefixes all over the place, although unnecessarily so.
%
'$go_compile_clause'(Mod:G,V,N,Source) :- !,
'$go_compile_clause'(G,V,N,Mod,Source).
'$go_compile_clause'((M:G :- B),V,N,Source) :- !,
'$current_module'(M1),
(M1 = M ->
NG = (G :- B)
;
'$preprocess_clause_before_mod_change'((G:-B),M1,M,NG)
),
'$go_compile_clause'(NG,V,N,M,Source).
'$go_compile_clause'(G,V,N,Source) :-
'$current_module'(Mod),
'$go_compile_clause'(G,V,N,Mod,Source).
'$go_compile_clause'(G, V, N, Mod, Source) :-
'$prepare_term'(G, V, G0, G1, Mod, Source),
'$$compile'(G1, G0, N, Mod).
'$go_compile_clause'(G, V, N, Mod, Source) :-
'$prepare_term'(G, V, G0, G1, Mod, Source),
'$$compile'(G1, G0, N, Mod).
'$prepare_term'(G, V, G0, G1, Mod, Source) :-
( get_value('$syntaxcheckflag',on) ->
'$check_term'(Source, V, Mod) ; true ),
'$precompile_term'(G, G0, G1, Mod).
'$prepare_term'(G, V, G0, G1, Mod, Source) :-
( get_value('$syntaxcheckflag',on) ->
'$check_term'(Source, V, Mod) ; true ),
'$precompile_term'(G, G0, G1, Mod).
% process an input clause
'$$compile'(G, G0, L, Mod) :-
'$head_and_body'(G,H,_),
'$flags'(H, Mod, Fl, Fl),
is(NFl, /\, Fl, 0x00002000),
( NFl \= 0 -> '$assertz_dynamic'(L,G,G0,Mod) ;
'$compile'(G, L, G0, Mod) ).
% process an input clause
'$$compile'(G, G0, L, Mod) :-
'$head_and_body'(G,H,_),
'$flags'(H, Mod, Fl, Fl),
is(NFl, /\, Fl, 0x00002000),
( NFl \= 0 -> '$assertz_dynamic'(L,G,G0,Mod) ;
'$compile'(G, L, G0, Mod) ).
% process a clause for a static predicate
'$$compile_stat'(G,G0,L,H, Mod) :-
'$compile'(G,L,G0,Mod).
% process a clause for a static predicate
'$$compile_stat'(G,G0,L,H, Mod) :-
'$compile'(G,L,G0,Mod).
'$check_if_reconsulted'(N,A) :-
recorded('$reconsulted',X,_),
( X = N/A , !;
X = '$', !, fail;
fail
).
'$check_if_reconsulted'(N,A) :-
recorded('$reconsulted',X,_),
( X = N/A , !;
X = '$', !, fail;
fail
).
'$inform_as_reconsulted'(N,A) :-
recorda('$reconsulted',N/A,_).
'$inform_as_reconsulted'(N,A) :-
recorda('$reconsulted',N/A,_).
'$clear_reconsulting' :-
recorded('$reconsulted',X,Ref),
erase(Ref),
X == '$', !,
( recorded('$reconsulting',_,R) -> erase(R) ).
'$clear_reconsulting' :-
recorded('$reconsulted',X,Ref),
erase(Ref),
X == '$', !,
( recorded('$reconsulting',_,R) -> erase(R) ).
/* Executing a query */
/* Executing a query */
'$query'(end_of_file,_).
'$query'(end_of_file,_).
% ***************************
% * -------- YAPOR -------- *
% ***************************
% ***************************
% * -------- YAPOR -------- *
% ***************************
'$query'(G,V) :-
\+ '$undefined'('$yapor_on', prolog),
'$yapor_on',
\+ '$undefined'('$start_yapor', prolog),
'$parallelizable'(G), !,
'$parallel_query'(G,V),
fail.
'$query'(G,V) :-
\+ '$undefined'('$yapor_on', prolog),
'$yapor_on',
\+ '$undefined'('$start_yapor', prolog),
'$parallelizable'(G), !,
'$parallel_query'(G,V),
fail.
% end of YAPOR
% end of YAPOR
'$query'(G,[]) :- !,
'$yes_no'(G,(?-)).
'$query'(G,V) :-
(
( recorded('$trace',on,_) -> '$creep' ; true),
'$execute'(G),
'$do_not_creep',
'$output_frozen'(G, V, LGs),
'$write_answer'(V, LGs, Written),
'$write_query_answer_true'(Written),
'$another',
!, fail ;
'$do_not_creep',
( '$undefined'('$print_message'(_,_),prolog) ->
'$present_answer'(user_error,"no~n", [])
;
print_message(help,no)
),
fail
).
'$query'(G,[]) :- !,
'$yes_no'(G,(?-)).
'$query'(G,V) :-
(
( recorded('$trace',on,_) -> '$creep' ; true),
'$execute'(G),
'$do_not_creep',
'$output_frozen'(G, V, LGs),
'$write_answer'(V, LGs, Written),
'$write_query_answer_true'(Written),
'$another',
!, fail ;
'$do_not_creep',
( '$undefined'('$print_message'(_,_),prolog) ->
'$present_answer'(user_error,"no~n", [])
;
print_message(help,no)
),
fail
).
'$yes_no'(G,C) :-
'$current_module'(M),
'$do_yes_no'(G,M),
'$do_not_creep',
'$output_frozen'(G, [], LGs),
'$write_answer'([], LGs, Written),
( Written = [] ->
!,'$present_answer'(C, yes);
'$another', !
),
fail.
'$yes_no'(_,_) :-
'$do_not_creep',
( '$undefined'('$print_message'(_,_),prolog) ->
'$present_answer'(user_error,"no~n", [])
;
print_message(help,no)
),
fail.
'$yes_no'(G,C) :-
'$current_module'(M),
'$do_yes_no'(G,M),
'$do_not_creep',
'$output_frozen'(G, [], LGs),
'$write_answer'([], LGs, Written),
( Written = [] ->
!,'$present_answer'(C, yes);
'$another', !
),
fail.
'$yes_no'(_,_) :-
'$do_not_creep',
( '$undefined'('$print_message'(_,_),prolog) ->
'$present_answer'(user_error,"no~n", [])
;
print_message(help,no)
),
fail.
'$do_yes_no'([X|L], M) :- !, '$csult'([X|L], M).
'$do_yes_no'(G, M) :-
( recorded('$trace',on,_) -> '$creep' ; true),
'$execute'(M:G).
'$do_yes_no'([X|L], M) :- !, '$csult'([X|L], M).
'$do_yes_no'(G, M) :-
( recorded('$trace',on,_) -> '$creep' ; true),
'$execute'(M:G).
'$write_query_answer_true'([]) :- !,
format(user_error,'~ntrue',[]).
'$write_query_answer_true'(_).
'$write_query_answer_true'([]) :- !,
format(user_error,'~ntrue',[]).
'$write_query_answer_true'(_).
'$output_frozen'(G,V,LGs) :-
'$output_frozen'(G,V,LGs) :-
\+ '$undefined'(bindings_message(_,_,_), swi),
swi:bindings_message(V, LGs, []), !.
'$output_frozen'(G,V,LGs) :-

18
pl/directives.yap
View File

@ -466,13 +466,6 @@ yap_flag(single_var_warnings,X) :-
yap_flag(single_var_warnings,X) :-
'$do_error'(domain_error(flag_value,single_var_warnings+X),yap_flag(single_var_warnings,X)).
yap_flag(single_var_warnings,X) :-
var(X), !,
('$syntax_check_mode'(on,_), '$syntax_check_single_var'(on,_) ->
X = on
;
X = off
).
yap_flag(system_options,X) :-
'$system_options'(X).
@ -633,8 +626,18 @@ yap_flag(verbose_auto_load,false) :- !,
yap_flag(verbose_auto_load,X) :-
'$do_error'(domain_error(flag_value,verbose_auto_load+X),yap_flag(verbose_auto_load,X)).
yap_flag(float_format,X) :-
var(X), !,
'$float_format'(X).
yap_flag(float_format,X) :-
atom(X), !,
'$float_format'(X).
yap_flag(float_format,X) :-
'$do_error'(type_error(atom,X),yap_flag(float_format,X)).
'$show_yap_flag_opts'(V,Out) :-
(
V = answer_format ;
V = argv ;
V = bounded ;
V = char_conversion ;
@ -646,6 +649,7 @@ yap_flag(verbose_auto_load,X) :-
V = double_quotes ;
% V = fast ;
V = fileerrors ;
V = float_format ;
V = gc ;
V = gc_margin ;
V = gc_trace ;