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 

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 ;