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

Merge branch 'master' of ssh://git.dcc.fc.up.pt/yap-6.3

This commit is contained in:
Vitor Santos Costa 2014-10-02 23:25:06 +01:00
parent 2c599d99f8 80faee6824
commit d2527528fa
37 changed files with 1302 additions and 1528 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
C/amasm.c
View File

@ -259,7 +259,6 @@ static yamop *a_try(op_numbers, CELL, CELL, yamop *, int, struct intermediates *
static yamop *a_either(op_numbers, CELL, CELL, yamop *, int, struct intermediates *);
#endif /* YAPOR */
static yamop *a_gl(op_numbers, yamop *, int, struct PSEUDO *, struct intermediates * CACHE_TYPE);
static yamop *a_bfunc(CELL, clause_info *, yamop *, int, struct intermediates *);
static
COUNT compile_cmp_flags(char *);
static yamop *a_igl(CELL, op_numbers, yamop *, int, struct intermediates *);
@ -1622,65 +1621,63 @@ Yap_compile_cmp_flags(PredEntry *pred)
}
static yamop *
a_bfunc(CELL pred, clause_info *clinfo, yamop *code_p, int pass_no, struct intermediates *cip)
a_bfunc(CELL a1, CELL a2, PredEntry *pred, clause_info *clinfo, yamop *code_p, int pass_no, struct intermediates *cip)
{
Ventry *ve = (Ventry *) cip->cpc->rnd1;
OPREG var_offset;
int is_y_var = (ve->KindOfVE == PermVar);
var_offset = Var_Ref(ve, is_y_var);
if (ve->KindOfVE == PermVar) {
yslot v1 = emit_yreg(var_offset);
cip->cpc = cip->cpc->nextInst;
ve = (Ventry *) cip->cpc->rnd1;
is_y_var = (ve->KindOfVE == PermVar);
var_offset = Var_Ref(ve, is_y_var);
if (is_y_var) {
Ventry *ve1 = (Ventry *)a1;
Ventry *ve2 = (Ventry *)a2;
OPREG var_offset1;
int is_y_var = (ve1->KindOfVE == PermVar);
var_offset1 = Var_Ref(ve1, is_y_var);
if (ve1->KindOfVE == PermVar) {
yslot v1 = emit_yreg(var_offset1);
bool is_y_var2 = (ve2->KindOfVE == PermVar);
OPREG var_offset2 = Var_Ref(ve2, is_y_var2);
if (is_y_var2) {
if (pass_no) {
code_p->opc = emit_op(_call_bfunc_yy);
code_p->y_u.plyys.p = RepPredProp(((Prop)pred));
code_p->y_u.plyys.p = pred;
code_p->y_u.plyys.f = emit_fail(cip);
code_p->y_u.plyys.y1 = v1;
code_p->y_u.plyys.y2 = emit_yreg(var_offset);
code_p->y_u.plyys.y2 = emit_yreg(var_offset2);
code_p->y_u.plyys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE);
}
GONEXT(plyys);
} else {
if (pass_no) {
code_p->opc = emit_op(_call_bfunc_yx);
code_p->y_u.plxys.p = RepPredProp(((Prop)pred));
code_p->y_u.plxys.p = pred;
code_p->y_u.plxys.f = emit_fail(cip);
code_p->y_u.plxys.x = emit_xreg(var_offset);
code_p->y_u.plxys.x = emit_xreg(var_offset2);
code_p->y_u.plxys.y = v1;
code_p->y_u.plxys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE);
code_p->y_u.plxys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE);
}
GONEXT(plxys);
}
} else {
wamreg x1 = emit_xreg(var_offset);
OPREG var_offset;
wamreg x1 = emit_xreg(var_offset1);
OPREG var_offset2;
cip->cpc = cip->cpc->nextInst;
ve = (Ventry *) cip->cpc->rnd1;
is_y_var = (ve->KindOfVE == PermVar);
var_offset = Var_Ref(ve, is_y_var);
if (is_y_var) {
bool is_y_var2 = (ve2->KindOfVE == PermVar);
var_offset2 = Var_Ref(ve2, is_y_var2);
if (is_y_var2) {
if (pass_no) {
code_p->opc = emit_op(_call_bfunc_xy);
code_p->y_u.plxys.p = RepPredProp(((Prop)pred));
code_p->y_u.plxys.p = pred;
code_p->y_u.plxys.f = emit_fail(cip);
code_p->y_u.plxys.x = x1;
code_p->y_u.plxys.y = emit_yreg(var_offset);
code_p->y_u.plxys.y = emit_yreg(var_offset2);
code_p->y_u.plxys.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE);
}
GONEXT(plxys);
} else {
if (pass_no) {
// printf(" %p --- %p\n", x1, emit_xreg(var_offset2) );
code_p->opc = emit_op(_call_bfunc_xx);
code_p->y_u.plxxs.p = RepPredProp(((Prop)pred));
code_p->y_u.plxxs.p = pred;
code_p->y_u.plxxs.f = emit_fail(cip);
code_p->y_u.plxxs.x1 = x1;
code_p->y_u.plxxs.x2 = emit_xreg(var_offset);
code_p->y_u.plxxs.x2 = emit_xreg(var_offset2);
code_p->y_u.plxxs.flags = compile_cmp_flags(RepAtom(NameOfFunctor(RepPredProp(((Prop)pred))->FunctorOfPred))->StrOfAE);
}
GONEXT(plxxs);
@ -3685,13 +3682,8 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case count_retry_op:
code_p = a_pl(_count_retry, (PredEntry *)(cip->cpc->rnd1), code_p, pass_no);
break;
case fetch_args_for_bccall_op:
if (cip->cpc->nextInst->op != bccall_op) {
Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "compiling binary test", (int) cip->cpc->op);
save_machine_regs();
siglongjmp(cip->CompilerBotch, 1);
}
code_p = a_bfunc(cip->cpc->nextInst->rnd2, &clinfo, code_p, pass_no, cip);
case bccall_op:
code_p = a_bfunc(cip->cpc->rnd1, cip->cpc->rnd3, (PredEntry *)(cip->cpc->rnd5), &clinfo, code_p, pass_no, cip);
break;
case align_float_op:
/* install a blob */
@ -3888,6 +3880,7 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates
DBTerm *x;
StaticClause *cl;
UInt osize;
if(!(x = fetch_clause_space(&t, size, cip, &osize PASS_REGS))) {
return NULL;
}

33
C/cdmgr.c
View File

@ -1651,6 +1651,7 @@ source_pred(PredEntry *p, yamop *q)
static void
add_first_static(PredEntry *p, yamop *cp, int spy_flag)
{
CACHE_REGS
yamop *pt = cp;
if (is_logupd(p)) {
@ -1701,12 +1702,17 @@ add_first_static(PredEntry *p, yamop *cp, int spy_flag)
if (source_pred(p, cp)) {
p->PredFlags |= SourcePredFlag;
}
if (!(p->PredFlags & MultiFileFlag) &&
p->src.OwnerFile == AtomNil)
p->src.OwnerFile = Yap_ConsultingFile( PASS_REGS1 );
}
/* p is already locked */
static void
add_first_dynamic(PredEntry *p, yamop *cp, int spy_flag)
{
CACHE_REGS
yamop *ncp = ((DynamicClause *)NULL)->ClCode;
DynamicClause *cl;
if (p == PredGoalExpansion || p->FunctorOfPred == FunctorGoalExpansion2) {
@ -1797,6 +1803,10 @@ add_first_dynamic(PredEntry *p, yamop *cp, int spy_flag)
ncp = NEXTOP(ncp,e);
ncp->opc = Yap_opcode(_Ystop);
ncp->y_u.l.l = cl->ClCode;
if (!(p->PredFlags & MultiFileFlag) &&
p->src.OwnerFile == AtomNil)
p->src.OwnerFile = Yap_ConsultingFile( PASS_REGS1 );
}
/* p is already locked */
@ -3264,6 +3274,28 @@ p_owner_file( USES_REGS1 )
return Yap_unify(ARG3, MkAtomTerm(owner));
}
static Int
p_set_owner_file( USES_REGS1 )
{ /* '$owner_file'(+P,M,F) */
PredEntry *pe;
pe = get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
if (EndOfPAEntr(pe))
return FALSE;
PELOCK(29,pe);
if (pe->ModuleOfPred == IDB_MODULE) {
UNLOCKPE(47,pe);
return FALSE;
}
if (pe->PredFlags & MultiFileFlag) {
UNLOCKPE(48,pe);
return FALSE;
}
pe->src.OwnerFile = AtomOfTerm(Deref(ARG3));
UNLOCKPE(49,pe);
return TRUE;
}
static Int
p_mk_d( USES_REGS1 )
{ /* '$is_dynamic'(+P) */
@ -6664,6 +6696,7 @@ Yap_InitCdMgr(void)
Yap_InitCPred("$is_source", 2, p_is_source, TestPredFlag | SafePredFlag);
Yap_InitCPred("$is_exo", 2, p_is_exo, TestPredFlag | SafePredFlag);
Yap_InitCPred("$owner_file", 3, p_owner_file, SafePredFlag);
Yap_InitCPred("$set_owner_file", 3, p_set_owner_file, SafePredFlag);
Yap_InitCPred("$mk_d", 2, p_mk_d, SafePredFlag);
Yap_InitCPred("$sys_export", 2, p_sys_export, TestPredFlag | SafePredFlag);
Yap_InitCPred("$pred_exists", 2, p_pred_exists, TestPredFlag | SafePredFlag);

4
C/cmppreds.c
View File

@ -794,7 +794,9 @@ a_eq(Term t1, Term t2)
{
CACHE_REGS
/* A =:= B */
int out;
Int out;
t1 = Deref(t1);
t2 = Deref(t2);
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "=:=/2");

164
C/compiler.c
View File

@ -236,7 +236,7 @@ static void c_bifun(basic_preds, Term, Term, Term, Term, Term, compiler_struct *
static void c_goal(Term, Term, compiler_struct *);
static void c_body(Term, Term, compiler_struct *);
static void c_head(Term, compiler_struct *);
static int usesvar(compiler_vm_op);
static bool usesvar(compiler_vm_op);
static CELL *init_bvarray(int, compiler_struct *);
#ifdef DEBUG
static void clear_bvarray(int, CELL *, compiler_struct *);
@ -446,12 +446,6 @@ c_var(Term t, Int argno, unsigned int arity, unsigned int level, compiler_struct
Yap_emit(f_val_op, t, (CELL)arity, &cglobs->cint);
}
break;
case bt1_flag:
Yap_emit(fetch_args_for_bccall_op, t, 0, &cglobs->cint);
break;
case bt2_flag:
Yap_emit(bccall_op, t, (CELL)cglobs->current_p0, &cglobs->cint);
break;
default:
#ifdef SFUNC
if (argno < 0) {
@ -483,6 +477,24 @@ c_var(Term t, Int argno, unsigned int arity, unsigned int level, compiler_struct
tag_var(t, new, cglobs);
}
// built-in like X >= Y.
static void
c_2vars(int op, Term t1, Int argno1, Term t2, Int argno2, CELL extra, unsigned int arity, unsigned int level, compiler_struct *cglobs)
{
int new1 = check_var((t1 = Deref(t1)), level, argno1, cglobs);
int new2 = check_var((t2 = Deref(t2)), level, argno2, cglobs);
switch (op) {
case bt_flag:
Yap_emit_5ops(bccall_op, t1, argno1, t2, argno2, extra, &cglobs->cint);
break;
default:
return;
}
tag_var(t1, new1, cglobs);
tag_var(t2, new2, cglobs);
}
static void
reset_vars(Ventry *vtable)
{
@ -1876,9 +1888,8 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs)
v->FlagsOfVE |= SafeVar;
return;
}
else if (p->PredFlags & AsmPredFlag) {
else if (p->PredFlags & (AsmPredFlag)) {
basic_preds op = p->PredFlags & 0x7f;
if (profiling)
Yap_emit(enter_profiling_op, (CELL)p, Zero, &cglobs->cint);
else if (call_counting)
@ -1941,7 +1952,7 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs)
#ifdef BEAM
else if (p->PredFlags & BinaryPredFlag && !EAM) {
#else
else if (p->PredFlags & BinaryPredFlag) {
else if (p->PredFlags & BinaryPredFlag ) {
#endif
CACHE_REGS
Term a1 = ArgOfTerm(1,Goal);
@ -1949,33 +1960,25 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs)
if (IsVarTerm(a1) && !IsNewVar(a1)) {
Term a2 = ArgOfTerm(2,Goal);
if (IsVarTerm(a2) && !IsNewVar(a2)) {
if (IsNewVar(a2)) {
LOCAL_Error_TYPE = INSTANTIATION_ERROR;
LOCAL_Error_Term = a2;
LOCAL_ErrorMessage = LOCAL_ErrorSay;
sprintf(LOCAL_ErrorMessage, "compiling %s/2 with second arg unbound", RepAtom(NameOfFunctor(p->FunctorOfPred))->StrOfAE);
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch,1);
}
c_var(a1, bt1_flag, 2, 0, cglobs);
cglobs->current_p0 = p0;
c_var(a2, bt2_flag, 2, 0, cglobs);
c_2vars(bt_flag, a1, 0, a2, 0, (CELL)p0, 0, 0, cglobs);
}
else {
Term t2 = MkVarTerm();
//c_var(t2, --cglobs->tmpreg, 0, 0, cglobs);
if (HR == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
c_eq(t2, a2, cglobs);
c_var(a1, bt1_flag, 2, 0, cglobs);
cglobs->current_p0 = p0;
c_var(t2, bt2_flag, 2, 0, cglobs);
c_eq(t2, a2, cglobs);
c_2vars(bt_flag, a1, 0, t2, 0, (CELL)p0, 0, 0, cglobs);
}
} else {
Term a2 = ArgOfTerm(2,Goal);
Term t1 = MkVarTerm();
//c_var(t1, --cglobs->tmpreg, 0, 0, cglobs);
if (HR == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
@ -1984,21 +1987,20 @@ c_goal(Term Goal, Term mod, compiler_struct *cglobs)
c_eq(t1, a1, cglobs);
if (IsVarTerm(a2) && !IsNewVar(a2)) {
c_var(t1, bt1_flag, 2, 0, cglobs);
cglobs->current_p0 = p0;
c_var(a2, bt2_flag, 2, 0, cglobs);
c_2vars(bt_flag, t1, 0, a2, 0, (CELL)p0, 0, 0, cglobs);
}
else {
Term t2 = MkVarTerm();
// c_var(t2, --cglobs->tmpreg, 0, 0, cglobs);
if (HR == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
c_eq(t2, a2, cglobs);
c_var(t1, bt1_flag, 2, 0, cglobs);
cglobs->current_p0 = p0;
c_var(t2, bt2_flag, 2, 0, cglobs);
c_2vars(bt_flag, t1, 0, t2, 0, (CELL)p0, 0, 0, cglobs);
}
}
if (cglobs->onlast) {
@ -2183,11 +2185,11 @@ c_head(Term t, compiler_struct *cglobs)
}
inline static int
inline static bool
usesvar(compiler_vm_op ic)
{
if (ic >= get_var_op && ic <= put_val_op)
return TRUE;
return true;
switch (ic) {
case save_b_op:
case commit_b_op:
@ -2196,21 +2198,36 @@ usesvar(compiler_vm_op ic)
case save_pair_op:
case f_val_op:
case f_var_op:
case fetch_args_for_bccall_op:
case bccall_op:
return TRUE;
return true;
default:
break;
}
#ifdef SFUNC
if (ic >= unify_s_var_op && ic <= write_s_val_op)
return TRUE;
return true;
#endif
return ((ic >= unify_var_op && ic <= write_val_op)
||
(ic >= unify_last_var_op && ic <= unify_last_val_op));
}
inline static bool
uses_this_var(PInstr *pc, Term arg)
{
compiler_vm_op ic = pc->op;
if (pc->rnd1 != arg)
return arg == pc->rnd3 && ic == bccall_op;
return usesvar( ic );
}
inline static bool
usesvar2(compiler_vm_op ic)
{
return ic == bccall_op;
}
/*
* Do as in the traditional WAM and make sure voids are in
* environments
@ -2224,6 +2241,34 @@ typedef struct env_tmp {
} EnvTmp;
#endif
static void
tag_use(Ventry *v USES_REGS)
{
#ifdef BEAM
if (EAM) {
if (v->NoOfVE == Unassigned || v->KindOfVE!=PermVar) {
v->NoOfVE = PermVar | (LOCAL_nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= PermFlag;
}
}
#endif
if (v->NoOfVE == Unassigned) {
if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE))
|| v->KindOfVE == PermVar /*
* * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE &
* * OnHeadFlag))
*/ ) {
v->NoOfVE = PermVar | (LOCAL_nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= PermFlag;
} else {
v->NoOfVE = v->KindOfVE = TempVar;
}
}
}
static void
AssignPerm(PInstr *pc, compiler_struct *cglobs)
{
@ -2277,28 +2322,12 @@ AssignPerm(PInstr *pc, compiler_struct *cglobs)
if (uses_var) {
Ventry *v = (Ventry *) (pc->rnd1);
#ifdef BEAM
if (EAM) {
if (v->NoOfVE == Unassigned || v->KindOfVE!=PermVar) {
v->NoOfVE = PermVar | (LOCAL_nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= PermFlag;
}
}
#endif
if (v->NoOfVE == Unassigned) {
if ((v->AgeOfVE > 1 && (v->AgeOfVE > v->FirstOfVE))
|| v->KindOfVE == PermVar /*
* * || (v->FlagsOfVE & NonVoid && !(v->FlagsOfVE &
* * OnHeadFlag))
*/ ) {
v->NoOfVE = PermVar | (LOCAL_nperm++);
v->KindOfVE = PermVar;
v->FlagsOfVE |= PermFlag;
} else {
v->NoOfVE = v->KindOfVE = TempVar;
}
tag_use(v PASS_REGS);
if (usesvar2(pc->op) ) {
Ventry *v2 = (Ventry *) (pc->rnd3);
tag_use(v2 PASS_REGS);
}
} else if (pc->op == empty_call_op) {
pc->rnd2 = LOCAL_nperm;
} else if (pc->op == call_op || pc->op == either_op || pc->op == orelse_op || pc->op == push_or_op) {
@ -2357,7 +2386,6 @@ clear_bvarray(int var, CELL *bvarray
LOCAL_Error_TYPE = INTERNAL_COMPILER_ERROR;
LOCAL_Error_Term = TermNil;
LOCAL_ErrorMessage = "compiler internal error: variable initialised twice";
fprintf(stderr," vsc: compiling7\n");
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
}
@ -2488,6 +2516,22 @@ CheckUnsafe(PInstr *pc, compiler_struct *cglobs)
}
break;
}
case bccall_op:
{
Ventry *v = (Ventry *) (pc->rnd1),
*v3 = (Ventry *) (pc->rnd3);
if ( (v->FlagsOfVE & PermFlag && pc == v->FirstOpForV) ||
(v3->FlagsOfVE & PermFlag && pc == v3->FirstOpForV) ) {
CACHE_REGS
LOCAL_Error_TYPE = INTERNAL_COMPILER_ERROR;
LOCAL_Error_Term = TermNil;
LOCAL_ErrorMessage = "comparison should not have first instance of variables";
save_machine_regs();
siglongjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
}
}
break;
case put_var_op:
case get_var_op:
case save_b_op:
@ -2625,6 +2669,10 @@ CheckVoids(compiler_struct *cglobs)
case get_list_op:
case get_struct_op:
cglobs->Uses[cpc->rnd2] = 1;
break;
case bccall_op:
cglobs->Uses[cpc->rnd2] = 1;
cglobs->Uses[cpc->rnd4] = 1;
default:
break;
}
@ -2676,7 +2724,9 @@ checktemp(Int arg, Int rn, compiler_vm_op ic, compiler_struct *cglobs)
n = v->RCountOfVE - 1;
while (q != v->LastOpForV && (q = q->nextInst) != NIL) {
if (q->rnd2 <= 0); /* don't try to reuse REGISTER 0 */
else if (usesvar(ic = q->op) && arg == q->rnd1) {
else if ((usesvar(ic = q->op) && arg == q->rnd1) ||
(ic == bccall_op && arg == q->rnd3)/*uses_this_var(q, arg)*/) {
ic = q->op;
--n;
if (ic == put_val_op) {
if (target1 == cglobs->MaxCTemps && Needed[q->rnd2] == 0)
@ -2963,9 +3013,11 @@ c_layout(compiler_struct *cglobs)
case unify_s_var_op:
case unify_s_val_op:
#endif
case fetch_args_for_bccall_op:
checktemp(arg, rn, ic, cglobs);
break;
case bccall_op:
checktemp(arg, rn, ic, cglobs);
checktemp(cglobs->cint.cpc->rnd3, cglobs->cint.cpc->rnd4, ic, cglobs);
break;
case get_atom_op:
case get_num_op:

553
C/computils.c
View File

@ -66,9 +66,6 @@ static char SccsId[] = "%W% %G%";
#include <string.h>
#endif
#ifdef DEBUG
static void ShowOp(const char *, struct PSEUDO *);
#endif /* DEBUG */
/*
* The compiler creates an instruction chain which will be assembled after
@ -288,6 +285,72 @@ Yap_emit_4ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, struct inte
}
}
void
Yap_emit_5ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+3*sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->rnd4 = r4;
p->rnd5 = r5;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
void
Yap_emit_6ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, CELL r6, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+4*sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->rnd4 = r4;
p->rnd5 = r5;
p->rnd6 = r6;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
void
Yap_emit_7ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, CELL r5, CELL r6, CELL r7, struct intermediates *cip)
{
PInstr *p;
p = (PInstr *) AllocCMem (sizeof (*p)+5*sizeof(CELL), cip);
p->op = o;
p->rnd1 = r1;
p->rnd2 = r2;
p->rnd3 = r3;
p->rnd4 = r4;
p->rnd5 = r5;
p->rnd6 = r6;
p->rnd7 = r7;
p->nextInst = NIL;
if (cip->cpc == NIL)
cip->cpc = cip->CodeStart = p;
else
{
cip->cpc->nextInst = p;
cip->cpc = p;
}
}
CELL *
Yap_emit_extra_size (compiler_vm_op o, CELL r1, int size, struct intermediates *cip)
{
@ -415,14 +478,51 @@ write_address(CELL address)
sprintf(buf,"%p",(void *)address);
#endif
p[31] = '\0'; /* so that I don't have to worry */
Yap_DebugErrorPutc('0');
Yap_DebugErrorPutc('x');
//Yap_DebugErrorPutc('0');
//Yap_DebugErrorPutc('x');
while (*p != '\0') {
Yap_DebugErrorPutc(*p++);
}
}
}
static void
write_special_label(special_label_op arg, special_label_id rn, UInt lab)
{
switch (arg) {
case SPECIAL_LABEL_INIT:
Yap_DebugErrorPuts("init,");
switch (rn) {
case SPECIAL_LABEL_EXCEPTION:
Yap_DebugErrorPuts("exception,");
break;
case SPECIAL_LABEL_SUCCESS:
Yap_DebugErrorPuts("success,");
break;
case SPECIAL_LABEL_FAILURE:
Yap_DebugErrorPuts("fail,");
break;
}
write_address(lab);
case SPECIAL_LABEL_SET:
Yap_DebugErrorPuts("set,");
break;
case SPECIAL_LABEL_CLEAR:
Yap_DebugErrorPuts("clear,");
switch (rn) {
case SPECIAL_LABEL_EXCEPTION:
Yap_DebugErrorPuts("exception");
break;
case SPECIAL_LABEL_SUCCESS:
Yap_DebugErrorPuts("success");
break;
case SPECIAL_LABEL_FAILURE:
Yap_DebugErrorPuts("fail");
break;
}
}
}
static void
write_functor(Functor f)
{
@ -445,14 +545,38 @@ write_functor(Functor f)
}
}
static void
ShowOp (const char *f, struct PSEUDO *cpc)
char *opDesc[] = { mklist(f_arr) };
static void send_pred(PredEntry *p)
{
Functor f = p->FunctorOfPred;
UInt arity = p->ArityOfPE;
Term mod = TermProlog;
if (p->ModuleOfPred) mod = p->ModuleOfPred;
Yap_DebugPlWrite (mod);
Yap_DebugErrorPutc (':');
if (arity == 0)
Yap_DebugPlWrite (MkAtomTerm ((Atom)f));
else
Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f)));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm (arity));
}
static void
ShowOp (compiler_vm_op ic, const char *f, struct PSEUDO *cpc)
{
CACHE_REGS
char ch;
Int arg = cpc->rnd1;
Int rn = cpc->rnd2;
CELL *cptr = cpc->arnds;
if (ic != label_op && ic != label_ctl_op && ic != name_op) {
Yap_DebugErrorPutc ('\t');
}
while ((ch = *f++) != 0)
{
if (ch == '%')
@ -466,6 +590,19 @@ ShowOp (const char *f, struct PSEUDO *cpc)
Yap_DebugPlWrite(MkIntTerm(arg));
break;
#endif
case '2':
{
Ventry *v = (Ventry *) cpc->rnd3;
Yap_DebugErrorPutc (v->KindOfVE == PermVar ? 'Y' : 'X');
Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs));
Yap_DebugErrorPutc (',');
Yap_DebugErrorPutc ('A');
Yap_DebugPlWrite (MkIntegerTerm (cpc->rnd4));
Yap_DebugErrorPutc (',');
send_pred( RepPredProp((Prop)(cpc->rnd5)) );
}
break;
case 'a':
case 'n':
case 'S':
@ -474,7 +611,6 @@ ShowOp (const char *f, struct PSEUDO *cpc)
case 'b':
/* write a variable bitmap for a call */
{
CACHE_REGS
int max = arg/(8*sizeof(CELL)), i;
CELL *ptr = cptr;
for (i = 0; i <= max; i++) {
@ -485,6 +621,9 @@ ShowOp (const char *f, struct PSEUDO *cpc)
case 'l':
write_address (arg);
break;
case 'L':
write_special_label (arg, rn, cpc->rnd3);
break;
case 'B':
{
char s[32];
@ -494,10 +633,7 @@ ShowOp (const char *f, struct PSEUDO *cpc)
}
break;
case 'd':
{
CACHE_REGS
Yap_DebugPlWrite (MkIntegerTerm (arg));
}
Yap_DebugPlWrite (MkIntegerTerm (arg));
break;
case 'z':
Yap_DebugPlWrite (MkIntTerm (cpc->rnd3));
@ -520,50 +656,17 @@ ShowOp (const char *f, struct PSEUDO *cpc)
Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs));
}
break;
case 'm':
Yap_DebugPlWrite (MkAtomTerm ((Atom) arg));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm (rn));
break;
case 'm':
Yap_DebugPlWrite (MkAtomTerm ((Atom) arg));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm (rn));
break;
case 'p':
{
PredEntry *p = RepPredProp ((Prop) arg);
Functor f = p->FunctorOfPred;
UInt arity = p->ArityOfPE;
Term mod;
if (p->ModuleOfPred)
mod = p->ModuleOfPred;
else
mod = TermProlog;
Yap_DebugPlWrite (mod);
Yap_DebugErrorPutc (':');
if (arity == 0)
Yap_DebugPlWrite (MkAtomTerm ((Atom)f));
else
Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f)));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm (arity));
}
break;
case 'P':
{
PredEntry *p = RepPredProp((Prop) rn);
Functor f = p->FunctorOfPred;
UInt arity = p->ArityOfPE;
Term mod = TermProlog;
if (p->ModuleOfPred) mod = p->ModuleOfPred;
Yap_DebugPlWrite (mod);
Yap_DebugErrorPutc (':');
if (arity == 0)
Yap_DebugPlWrite (MkAtomTerm ((Atom)f));
else
Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f)));
Yap_DebugErrorPutc ('/');
Yap_DebugPlWrite (MkIntTerm (arity));
}
break;
send_pred( RepPredProp((Prop)(arg) ));
break;
case 'P':
send_pred( RepPredProp((Prop)(rn) ));
break;
case 'f':
write_functor((Functor)arg);
break;
@ -667,342 +770,6 @@ ShowOp (const char *f, struct PSEUDO *cpc)
Yap_DebugErrorPutc ('\n');
}
static const char *
getFormat(compiler_vm_op ic) {
switch( ic ) {
case nop_op:
return "nop";
case get_var_op:
return "get_var\t\t%v,%r";
case put_var_op:
return "put_var\t\t%v,%r";
case get_val_op:
return "get_val\t\t%v,%r";
case put_val_op:
return "put_val\t\t%v,%r";
case get_atom_op:
return "get_atom\t%a,%r";
case put_atom_op:
return "put_atom\t%a,%r";
case get_num_op:
return "get_num\t\t%n,%r";
case put_num_op:
return "put_num\t\t%n,%r";
case get_float_op:
return "get_float\t\t%w,%r";
case put_float_op:
return "put_float\t\t%w,%r";
case get_string_op:
return "get_string\t\t%w,%S";
case put_string_op:
return "put_string\t\t%w,%S";
case get_dbterm_op:
return "get_dbterm\t%w,%r";
case put_dbterm_op:
return "put_dbterm\t%w,%r";
case get_longint_op:
return "get_longint\t\t%w,%r";
case put_longint_op:
return "put_longint\t\t%w,%r";
case get_bigint_op:
return "get_bigint\t\t%l,%r";
case put_bigint_op:
return "put_bigint\t\t%l,%r";
case get_list_op:
return "get_list\t%r";
case put_list_op:
return "put_list\t%r";
case get_struct_op:
return "get_struct\t%f,%r";
case put_struct_op:
return "put_struct\t%f,%r";
case put_unsafe_op:
return "put_unsafe\t%v,%r";
case unify_var_op:
return "unify_var\t%v";
case write_var_op:
return "write_var\t%v";
case unify_val_op:
return "unify_val\t%v";
case write_val_op:
return "write_val\t%v";
case unify_atom_op:
return "unify_atom\t%a";
case write_atom_op:
return "write_atom\t%a";
case unify_num_op:
return "unify_num\t%n";
case write_num_op:
return "write_num\t%n";
case unify_float_op:
return "unify_float\t%w";
case write_float_op:
return "write_float\t%w";
case unify_string_op:
return "unify_string\t%S";
case write_string_op:
return "write_string\t%S";
case unify_dbterm_op:
return "unify_dbterm\t%w";
case write_dbterm_op:
return "write_dbterm\t%w";
case unify_longint_op:
return "unify_longint\t%w";
case write_longint_op:
return "write_longint\t%w";
case unify_bigint_op:
return "unify_bigint\t%l";
case write_bigint_op:
return "write_bigint\t%l";
case unify_list_op:
return "unify_list";
case write_list_op:
return "write_list";
case unify_struct_op:
return "unify_struct\t%f";
case write_struct_op:
return "write_struct\t%f";
case write_unsafe_op:
return "write_unsafe\t%v";
case unify_local_op:
return "unify_local\t%v";
case write_local_op:
return "write local\t%v";
case unify_last_list_op:
return "unify_last_list";
case write_last_list_op:
return "write_last_list";
case unify_last_struct_op:
return "unify_last_struct\t%f";
case write_last_struct_op:
return "write_last_struct\t%f";
case unify_last_var_op:
return "unify_last_var\t%v";
case unify_last_val_op:
return "unify_last_val\t%v";
case unify_last_local_op:
return "unify_last_local\t%v";
case unify_last_atom_op:
return "unify_last_atom\t%a";
case unify_last_num_op:
return "unify_last_num\t%n";
case unify_last_float_op:
return "unify_last_float\t%w";
case unify_last_string_op:
return "unify_last_string\t%S";
case unify_last_dbterm_op:
return "unify_last_dbterm\t%w";
case unify_last_longint_op:
return "unify_last_longint\t%w";
case unify_last_bigint_op:
return "unify_last_bigint\t%l";
case ensure_space_op:
return "ensure_space";
case native_op:
return "native_code";
case f_var_op:
return "function_to_var\t%v,%B";
case f_val_op:
return "function_to_val\t%v,%B";
case f_0_op:
return "function_to_0\t%B";
case align_float_op:
return "align_float";
case fail_op:
return "fail";
case cut_op:
return "cut";
case cutexit_op:
return "cutexit";
case allocate_op:
return "allocate";
case deallocate_op:
return "deallocate";
case tryme_op:
return "try_me_else\t\t%l\t%x";
case jump_op:
return "jump\t\t%l";
case jumpi_op:
return "jump_in_indexing\t\t%i";
case procceed_op:
return "proceed";
case call_op:
return "call\t\t%p,%d,%z";
case execute_op:
return "execute\t\t%p";
case safe_call_op:
return "sys\t\t%p";
case label_op:
return "%l:";
case name_op:
return "name\t\t%m,%d";
case pop_op:
return "pop\t\t%l";
case retryme_op:
return "retry_me_else\t\t%l\t%x";
case trustme_op:
return "trust_me_else_fail\t%x";
case either_op:
return "either_me\t\t%l,%d,%z";
case orelse_op:
return "or_else\t\t%l,%z";
case orlast_op:
return "or_last";
case push_or_op:
return "push_or";
case pop_or_op:
return "pop_or";
case pushpop_or_op:
return "pushpop_or";
case save_b_op:
return "save_by\t\t%v";
case commit_b_op:
return "commit_by\t\t%v";
case patch_b_op:
return "patch_by\t\t%v";
case try_op:
return "try\t\t%g\t%x";
case retry_op:
return "retry\t\t%g\t%x";
case trust_op:
return "trust\t\t%g\t%x";
case try_in_op:
return "try_in\t\t%g\t%x";
case jump_v_op:
return "jump_if_var\t\t%g";
case jump_nv_op:
return "jump_if_nonvar\t\t%g";
case cache_arg_op:
return "cache_arg\t%r";
case cache_sub_arg_op:
return "cache_sub_arg\t%d";
case user_switch_op:
return "user_switch";
case switch_on_type_op:
return "switch_on_type\t%h\t%h\t%h\t%h";
case switch_c_op:
return "switch_on_constant\t%i\n%c";
case if_c_op:
return "if_constant\t%i\n%c";
case switch_f_op:
return "switch_on_functor\t%i\n%e";
case if_f_op:
return "if_functor\t%i\n%e";
case if_not_op:
return "if_not_then\t%i\t%h\t%h\t%h";
case index_dbref_op:
return "index_on_dbref";
case index_blob_op:
return "index_on_blob";
case index_long_op:
return "index_on_blob";
case index_string_op:
return "index_on_string";
case if_nonvar_op:
return "check_var\t %r";
case save_pair_op:
return "save_pair\t%v";
case save_appl_op:
return "save_appl\t%v";
case mark_initialised_pvars_op:
return "pvar_bitmap\t%l,%b";
case mark_live_regs_op:
return "pvar_live_regs\t%l,%b";
case fetch_args_vv_op:
return "fetch_reg1_reg2\t%N,%N";
case fetch_args_cv_op:
return "fetch_constant_reg\t%l,%N";
case fetch_args_vc_op:
return "fetch_reg_constant\t%l,%N";
case fetch_args_iv_op:
return "fetch_integer_reg\t%d,%N";
case fetch_args_vi_op:
return "fetch_reg_integer\t%d,%N";
case enter_profiling_op:
return "enter_profiling\t\t%g";
case retry_profiled_op:
return "retry_profiled\t\t%g";
case count_call_op:
return "count_call_op\t\t%g";
case count_retry_op:
return "count_retry_op\t\t%g";
case restore_tmps_op:
return "restore_temps\t\t%l";
case restore_tmps_and_skip_op:
return "restore_temps_and_skip\t\t%l";
case enter_lu_op:
return "enter_lu";
case empty_call_op:
return "empty_call\t\t%l,%d";
#ifdef YAPOR
case sync_op:
return "sync";
#endif /* YAPOR */
#ifdef TABLING
case table_new_answer_op:
return "table_new_answer";
case table_try_single_op:
return "table_try_single\t%g\t%x";
#endif /* TABLING */
#ifdef TABLING_INNER_CUTS
case "clause_with_cut":
return clause_with_cut_op;
#endif /* TABLING_INNER_CUTS */
#ifdef BEAM
"run_op %1,%4",
"body_op %1",
"endgoal_op",
"try_me_op %1,%4",
"retry_me_op %1,%4",
"trust_me_op %1,%4",
"only_1_clause_op %1,%4",
"create_first_box_op %1,%4",
"create_box_op %1,%4",
"create_last_box_op %1,%4",
"remove_box_op %1,%4",
"remove_last_box_op %1,%4",
"prepare_tries",
"std_base_op %1,%4",
"direct_safe_call",
"skip_while_var_op",
"wait_while_var_op",
"force_wait_op",
"write_op",
"is_op",
"equal_op",
"exit",
#endif
case fetch_args_for_bccall_op:
return "fetch_args_for_bccall\t%v";
case bccall_op:
return "binary_cfunc\t\t%v,%P";
case blob_op:
return "blob\t%O";
case string_op:
return "string\t%O";
case label_ctl_op:
return "label_control\t";
#ifdef SFUNC
,
"get_s_f_op\t%f,%r",
"put_s_f_op\t%f,%r",
"unify_s_f_op\t%f",
"write_s_f_op\t%f",
"unify_s_var\t%v,%r",
"write_s_var\t%v,%r",
"unify_s_val\t%v,%r",
"write_s_val\t%v,%r",
"unify_s_a\t%a,%r",
"write_s_a\t%a,%r",
"get_s_end",
"put_s_end",
"unify_s_end",
"write_s_end"
#endif
}
return NULL;
}
void
Yap_ShowCode (struct intermediates *cint)
{
@ -1015,8 +782,8 @@ Yap_ShowCode (struct intermediates *cint)
while (cpc) {
compiler_vm_op ic = cpc->op;
if (ic != nop_op) {
}
ShowOp (getFormat(ic), cpc);
ShowOp (ic, opDesc[ic], cpc);
}
cpc = cpc->nextInst;
}
Yap_DebugErrorPutc ('\n');

133
C/dbase.c
View File

@ -2117,6 +2117,14 @@ p_rcdap( USES_REGS1 )
}
/* recorda_at(+DBRef,+Term,-Ref) */
/** @pred recorda_at(+ _R0_, _T_,- _R_)
Makes term _T_ the record preceding record with reference
_R0_, and unifies _R_ with its reference.
*/
static Int
p_rcda_at( USES_REGS1 )
{
@ -2159,6 +2167,12 @@ p_rcda_at( USES_REGS1 )
}
/* recordz(+Functor,+Term,-Ref) */
/** @pred recordz(+ _K_, _T_,- _R_)
Makes term _T_ the last record under key _K_ and unifies _R_
with its reference.
*/
static Int
p_rcdz( USES_REGS1 )
{
@ -2255,6 +2269,14 @@ p_rcdzp( USES_REGS1 )
}
/* recordz_at(+Functor,+Term,-Ref) */
/** @pred recordz_at(+ _R0_, _T_,- _R_)
Makes term _T_ the record following record with reference
_R0_, and unifies _R_ with its reference.
*/
static Int
p_rcdz_at( USES_REGS1 )
{
@ -3747,7 +3769,16 @@ lu_statistics(PredEntry *pe USES_REGS)
Yap_unify(ARG4,MkIntegerTerm(isz));
}
/** @pred key_statistics(+ _K_,- _Entries_,- _Size_,- _IndexSize_)
Returns several statistics for a key _K_. Currently, it says how
many entries we have for that key, _Entries_, what is the
total size spent on entries, _Size_, and what is the amount of
space spent in indices.
*/
static Int
p_key_statistics( USES_REGS1 )
{
@ -4434,6 +4465,14 @@ p_decrease_reference_counter( USES_REGS1 )
}
/* erase(+Ref) */
/** @pred erase(+ _R_)
The term referred to by _R_ is erased from the internal database. If
reference _R_ does not exist in the database, `erase` just fails.
*/
static Int
p_current_reference_counter( USES_REGS1 )
{
@ -4487,6 +4526,12 @@ p_erase_clause( USES_REGS1 )
}
/* eraseall(+Key) */
/** @pred eraseall(+ _K_)
All terms belonging to the key `K` are erased from the internal
database. The predicate always succeeds.
*/
static Int
p_eraseall( USES_REGS1 )
{
@ -4549,6 +4594,14 @@ p_eraseall( USES_REGS1 )
/* erased(+Ref) */
/** @pred erased(+ _R_)
Succeeds if the object whose database reference is _R_ has been
erased.
*/
static Int
p_erased( USES_REGS1 )
{
@ -4678,6 +4731,17 @@ mega_instance(yamop *code, PredEntry *ap USES_REGS)
}
/* instance(+Ref,?Term) */
/** @pred instance(+ _R_,- _T_)
If _R_ refers to a clause or a recorded term, _T_ is unified
with its most general instance. If _R_ refers to an unit clause
_C_, then _T_ is unified with ` _C_ :- true`. When
_R_ is not a reference to an existing clause or to a recorded term,
this goal fails.
*/
static Int
p_instance( USES_REGS1 )
{
@ -5581,81 +5645,22 @@ with its reference.
*/
Yap_InitCPred("recordz", 3, p_rcdz, SyncPredFlag);
/** @pred recordz(+ _K_, _T_,- _R_)
Makes term _T_ the last record under key _K_ and unifies _R_
with its reference.
*/
Yap_InitCPred("$still_variant", 2, p_still_variant, SyncPredFlag);
Yap_InitCPred("recorda_at", 3, p_rcda_at, SyncPredFlag);
/** @pred recorda_at(+ _R0_, _T_,- _R_)
Makes term _T_ the record preceding record with reference
_R0_, and unifies _R_ with its reference.
*/
Yap_InitCPred("recordz_at", 3, p_rcdz_at, SyncPredFlag);
/** @pred recordz_at(+ _R0_, _T_,- _R_)
Makes term _T_ the record following record with reference
_R0_, and unifies _R_ with its reference.
*/
Yap_InitCPred("$recordap", 3, p_rcdap, SyncPredFlag);
Yap_InitCPred("$recordzp", 3, p_rcdzp, SyncPredFlag);
Yap_InitCPred("$recordap", 4, p_drcdap, SyncPredFlag);
Yap_InitCPred("$recordzp", 4, p_drcdzp, SyncPredFlag);
Yap_InitCPred("erase", 1, p_erase, SafePredFlag|SyncPredFlag);
/** @pred erase(+ _R_)
The term referred to by _R_ is erased from the internal database. If
reference _R_ does not exist in the database, `erase` just fails.
*/
Yap_InitCPred("$erase_clause", 2, p_erase_clause, SafePredFlag|SyncPredFlag);
Yap_InitCPred("increase_reference_count", 1, p_increase_reference_counter, SafePredFlag|SyncPredFlag);
Yap_InitCPred("decrease_reference_count", 1, p_decrease_reference_counter, SafePredFlag|SyncPredFlag);
Yap_InitCPred("current_reference_count", 2, p_current_reference_counter, SafePredFlag|SyncPredFlag);
Yap_InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag);
/** @pred erased(+ _R_)
Succeeds if the object whose database reference is _R_ has been
erased.
*/
Yap_InitCPred("instance", 2, p_instance, SyncPredFlag);
/** @pred instance(+ _R_,- _T_)
If _R_ refers to a clause or a recorded term, _T_ is unified
with its most general instance. If _R_ refers to an unit clause
_C_, then _T_ is unified with ` _C_ :- true`. When
_R_ is not a reference to an existing clause or to a recorded term,
this goal fails.
*/
Yap_InitCPred("$instance_module", 2, p_instance_module, SyncPredFlag);
Yap_InitCPred("eraseall", 1, p_eraseall, SafePredFlag|SyncPredFlag);
/** @pred eraseall(+ _K_)
All terms belonging to the key `K` are erased from the internal
database. The predicate always succeeds.
*/
Yap_InitCPred("$record_stat_source", 4, p_rcdstatp, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$some_recordedp", 1, p_somercdedp, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$first_instance", 3, p_first_instance, SafePredFlag|SyncPredFlag);
@ -5673,16 +5678,6 @@ database. The predicate always succeeds.
Yap_InitCPred("$fetch_reference_from_index", 3, p_fetch_reference_from_index, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$resize_int_keys", 1, p_resize_int_keys, SafePredFlag|SyncPredFlag);
Yap_InitCPred("key_statistics", 4, p_key_statistics, SyncPredFlag);
/** @pred key_statistics(+ _K_,- _Entries_,- _Size_,- _IndexSize_)
Returns several statistics for a key _K_. Currently, it says how
many entries we have for that key, _Entries_, what is the
total size spent on entries, _Size_, and what is the amount of
space spent in indices.
*/
Yap_InitCPred("$lu_statistics", 5, p_lu_statistics, SyncPredFlag);
Yap_InitCPred("total_erased", 4, p_total_erased, SyncPredFlag);
Yap_InitCPred("key_erased_statistics", 5, p_key_erased_statistics, SyncPredFlag);

10
C/globals.c
View File

@ -1370,7 +1370,15 @@ p_nb_getval( USES_REGS1 )
}
ge = FindGlobalEntry(AtomOfTerm(t) PASS_REGS);
if (!ge) {
return Yap_unify(TermNil, ARG3);
Term t3 = Deref(ARG3);
if (IsVarTerm(t3))
return FALSE;
if (IsApplTerm(t3)) {
if (FunctorOfTerm(t3) == FunctorEq)
return Yap_unify( ArgOfTerm(1, t3) , ArgOfTerm(2, t3) );
return FALSE;
}
return Yap_unify(t3, MkAtomTerm(AtomTrue));
}
READ_LOCK(ge->GRWLock);
to = ge->global;

6
C/grow.c
View File

@ -1079,8 +1079,6 @@ fix_compiler_instructions(PInstr *pcpc USES_REGS)
case write_local_op:
case f_var_op:
case f_val_op:
case fetch_args_for_bccall_op:
case bccall_op:
case save_pair_op:
case save_appl_op:
case save_b_op:
@ -1090,6 +1088,10 @@ fix_compiler_instructions(PInstr *pcpc USES_REGS)
case fetch_args_vc_op:
pcpc->rnd1 = GlobalAdjust(pcpc->rnd1);
break;
case bccall_op:
pcpc->rnd1 = GlobalAdjust(pcpc->rnd1);
pcpc->rnd3 = GlobalAdjust(pcpc->rnd3);
break;
case get_float_op:
case put_float_op:
case get_longint_op:

5
C/init.c
View File

@ -627,7 +627,7 @@ Yap_InitCmpPred(const char *Name, UInt Arity, CmpPredicate cmp_code, UInt flags)
return;
}
}
if (pe->PredFlags & CPredFlag) {
if (pe->PredFlags & BinaryPredFlag) {
flags = update_flags_from_prolog(flags, pe);
p_code = pe->CodeOfPred;
/* already exists */
@ -651,7 +651,7 @@ Yap_InitCmpPred(const char *Name, UInt Arity, CmpPredicate cmp_code, UInt flags)
}
}
}
pe->PredFlags = flags | StandardPredFlag | CPredFlag;
//pe->PredFlags = flags | StandardPredFlag;
pe->CodeOfPred = p_code;
pe->cs.d_code = cmp_code;
pe->ModuleOfPred = CurrentModule;
@ -1054,6 +1054,7 @@ InitSWIAtoms(void)
int j=0;
MaxAtomTranslations = 2*N_SWI_ATOMS ;
SWI_Atoms = (Atom *)malloc(sizeof(Atom)*MaxAtomTranslations);
SWI_Functors = (Functor *)malloc(sizeof(Functor)*2*N_SWI_ATOMS);
#include "iswiatoms.h"
Yap_InitSWIHash();
ATOM_ = PL_new_atom("");

15
C/iopreds.c
View File

@ -199,6 +199,14 @@ Yap_DebugPutc(int sno, wchar_t ch)
return (Sputc(ch, GLOBAL_stderr));
}
static int
Yap_DebugPuts(int sno, const char * s)
{
if (GLOBAL_Option['l' - 96])
(void) fputs(s, GLOBAL_logfile);
return (Sfputs(s, GLOBAL_stderr));
}
void
Yap_DebugPlWrite(Term t)
{
@ -212,6 +220,13 @@ Yap_DebugErrorPutc(int c)
Yap_DebugPutc (LOCAL_c_error_stream, c);
}
void
Yap_DebugErrorPuts(const char *s)
{
CACHE_REGS
Yap_DebugPuts (LOCAL_c_error_stream, s);
}
#endif

81
C/qlyr.c
View File

@ -44,7 +44,8 @@ typedef enum {
BAD_ATOM = 8,
MISMATCH = 9,
INCONSISTENT_CPRED = 10,
BAD_READ = 11
BAD_READ = 11,
BAD_HEADER = 12
} qlfr_err_t;
static char *
@ -77,7 +78,7 @@ static void
QLYR_ERROR(qlfr_err_t my_err)
{
Yap_Error(SAVED_STATE_ERROR,TermNil,"error %s in saved state %s",GLOBAL_RestoreFile, qlyr_error[my_err]);
exit(1);
Yap_exit(1);
}
static Atom
@ -691,11 +692,56 @@ read_tag(IOSTREAM *stream)
return ch;
}
static void
read_header(IOSTREAM *stream)
static bool
checkChars(IOSTREAM *stream, char s[])
{
int ch;
int ch, c;
char *p = s;
while ((ch = *p++)) {
if ((c = read_byte(stream)) != ch ) {
return false;
}
}
return TRUE;
}
static Atom
get_header(IOSTREAM *stream)
{
char s[256], *p = s, ch;
Atom at;
if (!checkChars( stream, "#!/bin/sh\nexec_dir=${YAPBINDIR:-" ))
return NIL;
while ((ch = read_byte(stream)) != '\n');
if (!checkChars( stream, "exec $exec_dir/yap $0 \"$@\"\nsaved " ))
return NIL;
while ((ch = read_byte(stream)) != ',')
*p++ = ch;
*p++ = '\0';
at = Yap_LookupAtom( s );
while ((ch = read_byte(stream)));
return at;
}
static Int
p_get_header( USES_REGS1 )
{
IOSTREAM *stream;
Term t1 = Deref(ARG1);
Atom at;
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR,t1,"read_program/3");
return FALSE;
}
if (!(stream = Yap_GetInputStream(AtomOfTerm(t1))) ) {
return FALSE;
}
if ((at = get_header( stream )) == NIL)
return FALSE;
return Yap_unify( ARG2, MkAtomTerm( at ) );
}
static void
@ -801,6 +847,7 @@ ReadHash(IOSTREAM *stream)
pe = RepPredProp(PredPropByAtomAndMod(a,mod));
}
} else {
/* IDB */
if (arity == (UInt)-1) {
UInt i = read_UInt(stream);
pe = Yap_FindLUIntKey(i);
@ -808,12 +855,18 @@ ReadHash(IOSTREAM *stream)
Atom oa = (Atom)read_UInt(stream);
Atom a = LookupAtom(oa);
pe = RepPredProp(PredPropByAtomAndMod(a,mod));
pe->PredFlags |= AtomDBPredFlag;
} else {
Functor of = (Functor)read_UInt(stream);
Functor f = LookupFunctor(of);
pe = RepPredProp(PredPropByFuncAndMod(f,mod));
}
pe->PredFlags |= LogUpdatePredFlag;
pe->ArityOfPE = 3;
if (pe->OpcodeOfPred == UNDEF_OPCODE) {
pe->OpcodeOfPred = Yap_opcode(_op_fail);
pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = FAILCODE;
}
}
InsertPredEntry(ope, pe);
}
@ -959,7 +1012,10 @@ read_pred(IOSTREAM *stream, Term mod) {
if (ap->PredFlags & IndexedPredFlag) {
Yap_RemoveIndexation(ap);
}
//if (ap->ArityOfPE && ap->ModuleOfPred != IDB_MODULE)
// printf(" %s/%ld\n", NameOfFunctor(ap->FunctorOfPred)->StrOfAE, ap->ArityOfPE);
//else if (ap->ModuleOfPred != IDB_MODULE)
// printf(" %s/%ld\n", ((Atom)(ap->FunctorOfPred))->StrOfAE, ap->ArityOfPE);
#if SIZEOF_INT_P==4
fl1 = flags & ((UInt)STATIC_PRED_FLAGS);
ap->PredFlags &= ~((UInt)STATIC_PRED_FLAGS);
@ -1013,7 +1069,6 @@ static void
read_module(IOSTREAM *stream) {
qlf_tag_t x;
read_header(stream);
InitHash();
ReadHash(stream);
while ((x = read_tag(stream)) == QLY_START_MODULE) {
@ -1070,14 +1125,12 @@ p_read_program( USES_REGS1 )
Yap_Error(INSTANTIATION_ERROR,t1,"read_program/3");
return FALSE;
}
if (!IsAtomTerm(t1)) {
Yap_Error(TYPE_ERROR_ATOM,t1,"read_program/3");
return(FALSE);
}
if (!(stream = Yap_GetInputStream(AtomOfTerm(t1))) ) {
if ((stream = Yap_GetInputStream(AtomOfTerm(t1))) ) {
return FALSE;
}
YAP_Reset( YAP_RESET_FROM_RESTORE );
if (get_header( stream ) == NIL)
return FALSE;
read_module(stream);
Sclose( stream );
/* back to the top level we go */
@ -1092,6 +1145,8 @@ Yap_Restore(char *s, char *lib_dir)
if (!stream)
return -1;
GLOBAL_RestoreFile = s;
if (get_header( stream ) == NIL)
return FALSE;
read_module(stream);
Sclose( stream );
GLOBAL_RestoreFile = NULL;
@ -1102,7 +1157,9 @@ Yap_Restore(char *s, char *lib_dir)
void Yap_InitQLYR(void)
{
Yap_InitCPred("$qload_module_preds", 1, p_read_module_preds, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$qload_file_preds", 1, p_read_module_preds, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$qload_program", 1, p_read_program, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$q_header", 2, p_get_header, SyncPredFlag|UserCPredFlag);
if (FALSE) {
restore_codes();
}

24
C/qlyw.c
View File

@ -771,18 +771,18 @@ save_ops(IOSTREAM *stream, Term mod) {
}
static int
save_header(IOSTREAM *stream)
save_header(IOSTREAM *stream, char type[])
{
char msg[256];
sprintf(msg, "#!/bin/sh\nexec_dir=${YAPBINDIR:-%s}\nexec $exec_dir/yap $0 \"$@\"\n%s", YAP_BINDIR, YAP_FULL_VERSION);
sprintf(msg, "#!/bin/sh\nexec_dir=${YAPBINDIR:-%s}\nexec $exec_dir/yap $0 \"$@\"\n%s %s\n", YAP_BINDIR, type, YAP_FULL_VERSION);
return save_bytes(stream, msg, strlen(msg)+1);
}
static size_t
save_module(IOSTREAM *stream, Term mod) {
PredEntry *ap = Yap_ModulePred(mod);
save_header( stream );
save_header( stream, "saved module," );
InitHash();
ModuleAdjust(mod);
while (ap) {
@ -813,7 +813,7 @@ save_program(IOSTREAM *stream) {
ModEntry *me = CurrentModules;
InitHash();
save_header( stream );
save_header( stream, "saved state," );
/* should we allow the user to see hidden predicates? */
while (me) {
PredEntry *pp;
@ -855,7 +855,7 @@ save_file(IOSTREAM *stream, Atom FileName) {
ModEntry *me = CurrentModules;
InitHash();
save_header( stream );
save_header( stream, "saved file," );
/* should we allow the user to see hidden predicates? */
while (me) {
PredEntry *pp;
@ -865,6 +865,7 @@ save_file(IOSTREAM *stream, Atom FileName) {
pp = PredEntryAdjust(pp);
if (pp &&
!(pp->PredFlags & (MultiFileFlag|NumberDBPredFlag|AtomDBPredFlag|CPredFlag|AsmPredFlag|UserCPredFlag)) &&
pp->ModuleOfPred != IDB_MODULE &&
pp->src.OwnerFile == FileName) {
CHECK(mark_pred(pp));
}
@ -883,8 +884,12 @@ save_file(IOSTREAM *stream, Atom FileName) {
CHECK(save_tag(stream, QLY_START_MODULE));
CHECK(save_UInt(stream, (UInt)MkAtomTerm(me->AtomOfME)));
while (pp != NULL) {
CHECK(save_tag(stream, QLY_START_PREDICATE));
CHECK(save_pred(stream, pp));
if (pp &&
!(pp->PredFlags & (MultiFileFlag|NumberDBPredFlag|AtomDBPredFlag|CPredFlag|AsmPredFlag|UserCPredFlag)) &&
pp->src.OwnerFile == FileName) {
CHECK(save_tag(stream, QLY_START_PREDICATE));
CHECK(save_pred(stream, pp));
}
pp = pp->NextPredOfModule;
}
CHECK(save_tag(stream, QLY_END_PREDICATES));
@ -966,9 +971,6 @@ p_save_file( USES_REGS1 )
if (!(stream = Yap_GetOutputStream(AtomOfTerm(t1))) ) {
return FALSE;
}
if (!(stream = Yap_GetOutputStream(AtomOfTerm(t1))) ) {
return FALSE;
}
if (IsVarTerm(tfile)) {
Yap_Error(INSTANTIATION_ERROR,tfile,"save_file/2");
return FALSE;
@ -984,7 +986,7 @@ void Yap_InitQLY(void)
{
Yap_InitCPred("$qsave_module_preds", 2, p_save_module_preds, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$qsave_program", 1, p_save_program, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$qsave_file", 2, p_save_file, SyncPredFlag|UserCPredFlag);
Yap_InitCPred("$qsave_file_preds", 2, p_save_file, SyncPredFlag|UserCPredFlag);
if (FALSE) {
restore_codes();
}

3
CXX/yapi.cpp
View File

@ -509,9 +509,8 @@ bool YAPQuery::next()
if (q_state == 0) {
// extern void toggle_low_level_trace(void);
//toggle_low_level_trace();
{ CACHE_REGS __android_log_print(ANDROID_LOG_ERROR, __FUNCTION__, "next %p", HR) ; }
result = (bool)YAP_EnterGoal((YAP_PredEntryPtr)ap, q_g, &q_h);
{ CACHE_REGS __android_log_print(ANDROID_LOG_ERROR, __FUNCTION__, "done") ; }
} else {
LOCAL_AllowRestart = this->q_open;
result = (bool)YAP_RetryGoal(&q_h);

1
H/Yapproto.h
View File

@ -283,6 +283,7 @@ void *Yap_GetOutputStream(Atom at);
#ifdef DEBUG
extern void Yap_DebugPlWrite (Term t);
extern void Yap_DebugErrorPutc (int n);
extern void Yap_DebugErrorPuts (const char *s);
#endif
void Yap_PlWriteToStream(Term, int, int);
/* depth_lim.c */

396
H/compile.h
View File

@ -18,197 +18,222 @@
/* consult stack management */
/* virtual machine instruction op-codes */
typedef enum compiler_op {
nop_op,
get_var_op,
put_var_op,
get_val_op,
put_val_op,
get_atom_op,
put_atom_op,
get_num_op,
put_num_op,
get_float_op,
put_float_op,
get_dbterm_op,
put_dbterm_op,
get_longint_op,
put_longint_op,
get_string_op,
put_string_op,
get_bigint_op,
put_bigint_op,
get_list_op,
put_list_op,
get_struct_op,
put_struct_op,
put_unsafe_op,
unify_var_op,
write_var_op,
unify_val_op,
write_val_op,
unify_atom_op,
write_atom_op,
unify_num_op,
write_num_op,
unify_float_op,
write_float_op,
unify_dbterm_op,
write_dbterm_op,
unify_longint_op,
write_longint_op,
unify_string_op,
write_string_op,
unify_bigint_op,
write_bigint_op,
unify_list_op,
write_list_op,
unify_struct_op,
write_struct_op,
write_unsafe_op,
unify_local_op,
write_local_op,
unify_last_list_op,
write_last_list_op,
unify_last_struct_op,
write_last_struct_op,
unify_last_var_op,
unify_last_val_op,
unify_last_local_op,
unify_last_atom_op,
unify_last_num_op,
unify_last_float_op,
unify_last_dbterm_op,
unify_last_longint_op,
unify_last_string_op,
unify_last_bigint_op,
ensure_space_op,
native_op,
f_var_op,
f_val_op,
f_0_op,
align_float_op,
fail_op,
cut_op,
cutexit_op,
allocate_op,
deallocate_op,
tryme_op,
jump_op,
jumpi_op,
procceed_op,
call_op,
execute_op,
safe_call_op,
label_op,
name_op,
pop_op,
retryme_op,
trustme_op,
either_op,
orelse_op,
orlast_op,
push_or_op,
pushpop_or_op,
pop_or_op,
save_b_op,
commit_b_op,
patch_b_op,
try_op,
retry_op,
trust_op,
try_in_op,
jump_v_op,
jump_nv_op,
cache_arg_op,
cache_sub_arg_op,
user_switch_op,
switch_on_type_op,
switch_c_op,
if_c_op,
switch_f_op,
if_f_op,
if_not_op,
index_dbref_op,
index_blob_op,
index_string_op,
index_long_op,
if_nonvar_op,
save_pair_op,
save_appl_op,
mark_initialised_pvars_op,
mark_live_regs_op,
fetch_args_vv_op,
fetch_args_cv_op,
fetch_args_vc_op,
fetch_args_iv_op,
fetch_args_vi_op,
enter_profiling_op,
retry_profiled_op,
count_call_op,
count_retry_op,
restore_tmps_op,
restore_tmps_and_skip_op,
enter_lu_op,
empty_call_op,
#define mklist0(f) \
f( nop_op, "nop") \
f( get_var_op, "get_var\t\t%v,%r") \
f( put_var_op, "put_var\t\t%v,%r") \
f( get_val_op, "get_val\t\t%v,%r") \
f( put_val_op, "put_val\t\t%v,%r") \
f( get_atom_op, "get_atom\t%a,%r") \
f( put_atom_op, "put_atom\t%a,%r") \
f( get_num_op, "get_num\t\t%n,%r") \
f( put_num_op, "put_num\t\t%n,%r") \
f( get_float_op,"get_float\t\t%w,%r" ) \
f( put_float_op, "put_float\t\t%w,%r") \
f( get_dbterm_op, "get_dbterm\t%w,%r") \
f( put_dbterm_op, "put_dbterm\t%w,%r") \
f( get_longint_op, "get_longint\t\t%w,%r") \
f( put_longint_op, "put_longint\t\t%w,%r") \
f( get_string_op, "get_string\t\t%w,%S") \
f( put_string_op, "put_string\t\t%w,%S") \
f( get_bigint_op, "get_bigint\t\t%l,%r") \
f( put_bigint_op, "put_bigint\t\t%l,%r") \
f( get_list_op, "get_list\t%r") \
f( put_list_op, "put_list\t%r") \
f( get_struct_op, "get_struct\t%f,%r") \
f( put_struct_op, "put_struct\t%f,%r") \
f( put_unsafe_op, "put_unsafe\t%v,%r") \
f( unify_var_op, "unify_var\t%v") \
f( write_var_op, "write_var\t%v") \
f( unify_val_op, "unify_val\t%v") \
f( write_val_op, "write_val\t%v") \
f( unify_atom_op, "unify_atom\t%a") \
f( write_atom_op, "write_atom\t%a") \
f( unify_num_op, "unify_num\t%n") \
f( write_num_op, "write_num\t%n") \
f( unify_float_op, "unify_float\t%w") \
f( write_float_op, "write_float\t%w") \
f( unify_dbterm_op, "unify_dbterm\t%w") \
f( write_dbterm_op, "write_dbterm\t%w") \
f( unify_longint_op, "unify_longint\t%w") \
f( write_longint_op, "write_longint\t%w") \
f( unify_string_op, "unify_string\t%S") \
f( write_string_op, "write_string\t%S") \
f( unify_bigint_op, "unify_bigint\t%l") \
f( write_bigint_op, "write_bigint\t%l") \
f( unify_list_op, "unify_list") \
f( write_list_op, "write_list") \
f( unify_struct_op, "unify_struct\t%f") \
f( write_struct_op, "write_struct\t%f") \
f( write_unsafe_op, "write_unsafe\t%v") \
f( unify_local_op, "unify_local\t%v") \
f( write_local_op, "write local\t%v") \
f( unify_last_list_op, "unify_last_list") \
f( write_last_list_op, "write_last_list") \
f( unify_last_struct_op, "unify_last_struct\t%f") \
f( write_last_struct_op, "write_last_struct\t%f") \
f( unify_last_var_op, "unify_last_var\t%v") \
f( unify_last_val_op, "unify_last_val\t%v") \
f( unify_last_local_op, "unify_last_local\t%v") \
f( unify_last_atom_op, "unify_last_atom\t%a") \
f( unify_last_num_op, "unify_last_num\t%n") \
f( unify_last_float_op, "unify_last_float\t%w") \
f( unify_last_dbterm_op, "unify_last_dbterm\t%w") \
f( unify_last_longint_op, "unify_last_longint\t%w") \
f( unify_last_string_op, "unify_last_string\t%S") \
f( unify_last_bigint_op, "unify_last_bigint\t%l") \
f( ensure_space_op, "ensure_space") \
f( native_op, "native_code") \
f( f_var_op, "function_to_var\t%v,%B") \
f( f_val_op, "function_to_val\t%v,%B") \
f( f_0_op, "function_to_0\t%B") \
f( align_float_op, "align_float") \
f( fail_op, "fail") \
f( cut_op, "cut") \
f( cutexit_op, "cutexit") \
f( allocate_op, "allocate") \
f( deallocate_op, "deallocate") \
f( tryme_op, "try_me_else\t\t%l\t%x") \
f( jump_op, "jump\t\t%l") \
f( jumpi_op, "jump_in_indexing\t\t%i") \
f( procceed_op, "proceed") \
f( call_op, "call\t\t%p,%d,%z") \
f( execute_op, "execute\t\t%p") \
f( safe_call_op, "sys\t\t%p") \
f( label_op, "%l:") \
f( name_op, "name\t\t%m,%d") \
f( pop_op, "pop\t\t%l") \
f( retryme_op, "retry_me_else\t\t%l\t%x") \
f( trustme_op, "trust_me_else_fail\t%x") \
f( either_op, "either_me\t\t%l,%d,%z") \
f( orelse_op, "or_else\t\t%l,%z") \
f( orlast_op, "or_last") \
f( push_or_op, "push_or") \
f( pushpop_or_op, "pushpop_or") \
f( pop_or_op, "pop_or") \
f( save_b_op, "save_by\t\t%v") \
f( commit_b_op, "commit_by\t\t%v") \
f( patch_b_op, "patch_by\t\t%v") \
f( try_op, "try\t\t%g\t%x") \
f( retry_op, "retry\t\t%g\t%x") \
f( trust_op, "trust\t\t%g\t%x") \
f( try_in_op, "try_in\t\t%g\t%x") \
f( jump_v_op, "jump_if_var\t\t%g") \
f( jump_nv_op, "jump_if_nonvar\t\t%g") \
f( cache_arg_op, "cache_arg\t%r") \
f( cache_sub_arg_op, "cache_sub_arg\t%d") \
f( user_switch_op, "user_switch") \
f( switch_on_type_op, "switch_on_type\t%h\t%h\t%h\t%h") \
f( switch_c_op, "switch_on_constant\t%i\n%c") \
f( if_c_op, "if_constant\t%i\n%c") \
f( switch_f_op, "switch_on_functor\t%i\n%e") \
f( if_f_op, "if_functor\t%i\n%e") \
f( if_not_op, "if_not_then\t%i\t%h\t%h\t%h") \
f( index_dbref_op, "index_on_dbref") \
f( index_blob_op, "index_on_blob") \
f( index_string_op, "index_on_string") \
f( index_long_op, "index_on_blob") \
f( if_nonvar_op, "check_var\t %r") \
f( save_pair_op, "save_pair\t%v") \
f( save_appl_op, "save_appl\t%v") \
f( mark_initialised_pvars_op, "pvar_bitmap\t%l,%b") \
f( mark_live_regs_op, "pvar_live_regs\t%l,%b") \
f( fetch_args_vv_op, "fetch_reg1_reg2\t%N,%N") \
f( fetch_args_cv_op, "fetch_constant_reg\t%l,%N") \
f( fetch_args_vc_op, "fetch_reg_constant\t%l,%N") \
f( fetch_args_iv_op, "fetch_integer_reg\t%d,%N") \
f( fetch_args_vi_op, "fetch_reg_integer\t%d,%N") \
f( enter_profiling_op, "enter_profiling\t\t%g") \
f( retry_profiled_op, "retry_profiled\t\t%g") \
f( count_call_op, "count_call_op\t\t%g") \
f( count_retry_op, "count_retry_op\t\t%g") \
f( restore_tmps_op, "restore_temps\t\t%l") \
f( restore_tmps_and_skip_op, "restore_temps_and_skip\t\t%l") \
f( enter_lu_op, "enter_lu") \
f( empty_call_op, "empty_call\t\t%l,%d") \
f( bccall_op, "binary_cfunc\t\t%v,%r,%2") \
f( blob_op, "blob\t%O") \
f( string_op, "string\t%O") \
f( label_ctl_op, "label_control\t")
#ifdef YAPOR
sync_op,
#define mklist1(f) \
mklist0(f) \
f( sync_op, "sync")
#else
#define mklist1(f) mklist0(f)
#endif /* YAPOR */
#ifdef TABLING
table_new_answer_op,
table_try_single_op,
#define mklist2(f) \
mklist1(f) \
f( table_new_answer_op, "table_new_answer") \
f( table_try_single_op, "table_try_single\t%g\t%x")
#else
#define mklist2(f) mklist1(f)
#endif /* TABLING */
#ifdef TABLING_INNER_CUTS
clause_with_cut_op,
#define mklist3(f) \
mklist2(f) \
f( clause_with_cut_op, "clause_with_cut")
#else
#define mklist3(f) mklist2(f)
#endif /* TABLING_INNER_CUTS */
#ifdef BEAM
run_op,
body_op,
endgoal_op,
try_me_op,
retry_me_op,
trust_me_op,
only_1_clause_op,
create_first_box_op,
create_box_op,
create_last_box_op,
remove_box_op,
remove_last_box_op,
prepare_tries,
std_base_op,
direct_safe_call_op,
commit_op,
skip_while_var_op,
wait_while_var_op,
force_wait_op,
write_op,
equal_op,
exit_op,
#define mklist4(f) \
mklist3(f) \
f( run_op, "run_op %1,%4") \
f( body_op, "body_op %1") \
f( endgoal_op, "endgoal_op") \
f( try_me_op, "try_me_op %1,%4") \
f( retry_me_op, "retry_me_op %1,%4") \
f( trust_me_op, "trust_me_op %1,%4") \
f( only_1_clause_op, "only_1_clause_op %1,%4") \
f( create_first_box_op, "create_first_box_op %1,%4") \
f( create_box_op, "create_box_op %1,%4") \
f( create_last_box_op, "create_last_box_op %1,%4") \
f( remove_box_op, "remove_box_op %1,%4") \
f( remove_last_box_op, "remove_last_box_op %1,%4" ) \
f( prepare_tries, "prepare_tries") \
f( std_base_op, "std_base_op %1,%4") \
f( direct_safe_call_op, "direct_safe_call") \
f( commit_op, ) \
f( skip_while_var_op, "skip_while_var_op") \
f( wait_while_var_op, "wait_while_var_op") \
f( force_wait_op, "force_wait_op") \
f( is_op, "is_op") \
f( write_op, "write_op") \
f( equal_op, "equal_op") \
f( exit_op, "exit")
#else
#define mklist4(f) mklist3(f)
#endif
fetch_args_for_bccall_op,
bccall_op,
blob_op,
string_op,
label_ctl_op
#ifdef SFUNC
,
get_s_f_op,
put_s_f_op,
unify_s_f_op,
write_s_f_op,
unify_s_var_op,
write_s_var_op,
unify_s_val_op,
write_s_val_op,
unify_s_a_op,
write_s_a_op,
get_s_end_op,
put_s_end_op,
unify_s_end_op,
write_s_end_op,
#define mklist(f) \
mklist4(f) \
f( get_s_f_op, "get_s_f_op\t%f,%r") \
f( put_s_f_op, "put_s_f_op\t%f,%r") \
f( unify_s_f_op, "unify_s_f_op\t%f") \
f( write_s_f_op, "write_s_f_op\t%f") \
f( unify_s_var_op, "unify_s_var\t%v,%r") \
f( write_s_var_op, "write_s_var\t%v,%r") \
f( unify_s_val_op, "unify_s_val\t%v,%r") \
f( write_s_val_op, "write_s_val\t%v,%r") \
f( unify_s_a_op, "unify_s_a\t%a,%r") \
f( write_s_a_op, "write_s_a\t%a,%r") \
f( get_s_end_op, "get_s_end") \
f( put_s_end_op, "put_s_end") \
f( unify_s_end_op, "unify_s_end") \
f( write_s_end_op, "write_s_end")
#else
#define mklist(f) mklist4(f)
#endif
} compiler_vm_op;
#define f_enum(x, y) x,
#define f_arr(x, y) y,
enum compiler_op { mklist(f_enum) };
typedef enum compiler_op compiler_vm_op;
typedef struct PSEUDO {
struct PSEUDO *nextInst;
@ -228,6 +253,10 @@ typedef struct PSEUDO {
#define rnd2 ops.oprnd2
#define rnd3 ops.opseqt[1]
#define rnd4 ops.opseqt[2]
#define rnd5 ops.opseqt[3]
#define rnd6 ops.opseqt[4]
#define rnd7 ops.opseqt[5]
#define rnd8 ops.opseqt[6]
typedef struct VENTRY {
CELL SelfOfVE;
@ -325,8 +354,8 @@ typedef enum special_label_op_enum {
#define save_appl_flag 0x10002
#define save_pair_flag 0x10004
#define f_flag 0x10008
#define bt1_flag 0x10010
#define bt2_flag 0x10020
#define bt_flag 0x10010
#define bt2_flag 0x10020 // unused
#define patch_b_flag 0x10040
#define init_v_flag 0x10080
@ -340,6 +369,9 @@ yamop *Yap_assemble(int,Term,struct pred_entry *,int, struct intermediates *, U
void Yap_emit(compiler_vm_op,Int,CELL, struct intermediates *);
void Yap_emit_3ops(compiler_vm_op,CELL,CELL,CELL, struct intermediates *);
void Yap_emit_4ops(compiler_vm_op,CELL,CELL,CELL,CELL, struct intermediates *);
void Yap_emit_5ops(compiler_vm_op,CELL,CELL,CELL,CELL,CELL, struct intermediates *);
void Yap_emit_6ops(compiler_vm_op,CELL,CELL,CELL,CELL,CELL,CELL, struct intermediates *);
void Yap_emit_7ops(compiler_vm_op,CELL,CELL,CELL,CELL,CELL,CELL,CELL, struct intermediates *);
CELL *Yap_emit_extra_size(compiler_vm_op,CELL,int, struct intermediates *);
char *Yap_AllocCMem(UInt, struct intermediates *);
void Yap_ReleaseCMem(struct intermediates *);

2
H/hstruct.h
View File

@ -288,7 +288,7 @@
struct record_list *yap_records;
Atom *swi_atoms;
Functor swi_functors[N_SWI_FUNCTORS];
Functor *swi_functors;
struct swi_reverse_hash swi_reverse_hash[N_SWI_HASH];
Int atom_translations;

425
library/expand_macros.yap
View File

@ -5,429 +5,16 @@
%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(expand_macros, []).
:- use_module(library(lists), [append/3]).
:- use_module(library(charsio), [format_to_chars/3, read_from_chars/2]).
:- use_module(library(error), [must_be/2]).
:- use_module(library(occurs), [sub_term/2]).
:- multifile user:goal_expansion/3.
:- dynamic number_of_expansions/1.
number_of_expansions(0).
user:goal_expansion(checklist(Meta, List), Mod, Goal) :-
goal_expansion_allowed(checklist(Meta, List), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(checklist, 2, Proto, GoalName),
append(MetaVars, [List], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[]], Base),
append_args(HeadPrefix, [[In|Ins]], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, List), Mod, Goal) :-
goal_expansion_allowed(maplist(Meta, List), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 2, Proto, GoalName),
append(MetaVars, [List], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[]], Base),
append_args(HeadPrefix, [[In|Ins]], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed(maplist(Meta, ListIn, ListOut), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], [Out|Outs]], RecursionHead),
append_args(Pred, [In, Out], Apply),
append_args(HeadPrefix, [Ins, Outs], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, L1, L2, L3), Mod, Goal) :-
goal_expansion_allowed(maplist(Meta, L1, L2, L3), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 4, Proto, GoalName),
append(MetaVars, [L1, L2, L3], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], []], Base),
append_args(HeadPrefix, [[A1|A1s], [A2|A2s], [A3|A3s]], RecursionHead),
append_args(Pred, [A1, A2, A3], Apply),
append_args(HeadPrefix, [A1s, A2s, A3s], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, L1, L2, L3, L4), Mod, Goal) :-
goal_expansion_allowed(maplist(Meta, L1, L2, L3, L4), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 5, Proto, GoalName),
append(MetaVars, [L1, L2, L3, L4], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], [], []], Base),
append_args(HeadPrefix, [[A1|A1s], [A2|A2s], [A3|A3s], [A4|A4s]], RecursionHead),
append_args(Pred, [A1, A2, A3, A4], Apply),
append_args(HeadPrefix, [A1s, A2s, A3s, A4s], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(selectlist(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed(selectlist(Meta, ListIn, ListOut), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(selectlist, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [In|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
% same as selectlist
user:goal_expansion(include(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed(include(Meta, ListIn, ListOut), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(include, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [In|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
user:goal_expansion(exclude(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed(exclude(Meta, ListIn, ListOut), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(exclude, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [In|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
user:goal_expansion(partition(Meta, ListIn, List1, List2), Mod, Goal) :-
goal_expansion_allowed(partition(Meta, ListIn, List1, List2), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(partition, 4, Proto, GoalName),
append(MetaVars, [ListIn, List1, List2], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs1, Outs2], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts1, NOuts2], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs1 = [In|NOuts1], Outs2 = NOuts2; Outs1 = NOuts1, Outs2 = [In|NOuts2]),
RecursiveCall)
], Module).
user:goal_expansion(partition(Meta, ListIn, List1, List2, List3), Mod, Goal) :-
goal_expansion_allowed(partition(Meta, ListIn, List1, List2, List3), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(partition2, 5, Proto, GoalName),
append(MetaVars, [ListIn, List1, List2, List3], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], [], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs1, Outs2, Outs3], RecursionHead),
append_args(Pred, [In,Diff], Apply),
append_args(HeadPrefix, [Ins, NOuts1, NOuts2, NOuts3], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(Diff == (<) ->
Outs1 = [In|NOuts1],
Outs2 = NOuts2,
Outs3 = NOuts3
;
Diff == (=) ->
Outs1 = NOuts1,
Outs2 = [In|NOuts2],
Outs3 = NOuts3
;
Diff == (>) ->
Outs1 = NOuts1,
Outs2 = NOuts2,
Outs3 = [In|NOuts3]
;
error:must_be(oneof([<,=,>]), Diff)
),
RecursiveCall)
], Module).
user:goal_expansion(convlist(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed(convlist(Meta, ListIn, ListOut), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(convlist, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In, Out], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [Out|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
user:goal_expansion(sumlist(Meta, List, AccIn, AccOut), Mod, Goal) :-
goal_expansion_allowed(sumlist(Meta, List, AccIn, AccOut), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(sumlist, 4, Proto, GoalName),
append(MetaVars, [List, AccIn, AccOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], Acc, Acc], Base),
append_args(HeadPrefix, [[In|Ins], Acc1, Acc2], RecursionHead),
append_args(Pred, [In, Acc1, Acc3], Apply),
append_args(HeadPrefix, [Ins, Acc3, Acc2], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(mapargs(Meta, In, Out), Module, NewGoal) :-
goal_expansion_allowed(mapargs(Meta, In, Out), Module),
( var(Out)
->
NewGoal = (
In =.. [F|InArgs],
maplist(Meta, InArgs, OutArgs),
Out =.. [F|OutArgs]
)
;
NewGoal = (
Out =.. [F|OutArgs],
maplist(Meta, InArgs, OutArgs),
In =.. [F|InArgs]
)
).
user:goal_expansion(sumargs(Meta, Term, AccIn, AccOut), Module, Goal) :-
goal_expansion_allowed(sumargs(Meta, Term, AccIn, AccOut), Module),
Goal = (
Term =.. [_|TermArgs],
sumlist(Meta, TermArgs, AccIn, AccOut)
).
user:goal_expansion(mapnodes(Meta, InTerm, OutTerm), Mod, Goal) :-
goal_expansion_allowed(mapnodes(Meta, InTerm, OutTerm), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(mapnodes, 3, Proto, GoalName),
append(MetaVars, [[InTerm], [OutTerm]], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], [Out|Outs]], RecursionHead),
append_args(Pred, [In, Temp], Apply),
append_args(HeadPrefix, [InArgs, OutArgs], SubRecursiveCall),
append_args(HeadPrefix, [Ins, Outs], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(compound(Temp)
->
Temp =.. [F|InArgs],
SubRecursiveCall,
Out =.. [F|OutArgs]
;
Out = Temp
),
RecursiveCall)
], Module).
user:goal_expansion(checknodes(Meta, Term), Mod, Goal) :-
goal_expansion_allowed(checknodes(Meta, Term), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(checknodes, 2, Proto, GoalName),
append(MetaVars, [[Term]], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[]], Base),
append_args(HeadPrefix, [[In|Ins]], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Args], SubRecursiveCall),
append_args(HeadPrefix, [Ins], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(compound(In)
->
In =.. [_|Args],SubRecursiveCall
;
true
),
RecursiveCall)
], Module).
user:goal_expansion(sumnodes(Meta, Term, AccIn, AccOut), Mod, Goal) :-
goal_expansion_allowed(sumnodes(Meta, Term, AccIn, AccOut), Mod),
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(sumnodes, 4, Proto, GoalName),
append(MetaVars, [[Term], AccIn, AccOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], Acc, Acc], Base),
append_args(HeadPrefix, [[In|Ins], Acc1, Acc2], RecursionHead),
append_args(Pred, [In, Acc1, Acc3], Apply),
append_args(HeadPrefix, [Args, Acc3, Acc4], SubRecursiveCall),
append_args(HeadPrefix, [Ins, Acc4, Acc2], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(compound(In)
->
In =.. [_|Args],SubRecursiveCall
;
Acc3 = Acc4
),
RecursiveCall)
], Module).
:- unhide('$translate_rule').
% stolen from SWI-Prolog
user:goal_expansion(phrase(NT,Xs), Mod, NTXsNil) :-
user:goal_expansion(phrase(NT,Xs,[]), Mod, NTXsNil).
user:goal_expansion(phrase(NT,Xs0,Xs), Mod, NewGoal) :-
goal_expansion_allowed(phrase(NT,Xs0,Xs), Mod),
Goal = phrase(NT,Xs0,Xs),
nonvar(NT),
catch('$translate_rule'((pseudo_nt --> NT), Rule),
error(Pat,ImplDep),
( \+ harmless_dcgexception(Pat),
throw(error(Pat,ImplDep))
)),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Goal \== NewGoal0,
% apply translation only if we are safe
\+ contains_illegal_dcgnt(NT), !,
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal
).
:- hide('$translate_rule').
%%%%%%%%%%%%%%%%%%%%
% utilities
@ -487,18 +74,6 @@ harmless_dcgexception(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
harmless_dcgexception(type_error(callable,_)). % ex: phrase(27,L)
%% contains_illegal_dcgnt(+Term) is semidet.
%
% True if Term contains a non-terminal we cannot deal with using
% goal-expansion. The test is too general approximation, but safe.
contains_illegal_dcgnt(NT) :-
sub_term(I, NT),
nonvar(I),
( I = ! ; I = phrase(_,_,_) ), !.
% write(contains_illegal_nt(NT)), % JW: we do not want to write
% nl.
'$expand':allowed_expansion(QExpand) :-
strip_module(QExpand, Mod, Pred),
goal_expansion_allowed(Pred, Mod).

2
library/lineutils.yap
View File

@ -32,7 +32,7 @@ available by loading the
:- meta_predicate
filter(+,+,2),
file_filter(+,+,2),
file_filter_with_init(+,+,2,+,:),
file_filter_with_initialization(+,+,2,+,:),
process(+,1).
:- use_module(library(lists),

30
library/maplist.yap
View File

@ -1248,36 +1248,6 @@ goal_expansion(sumnodes(Meta, Term, AccIn, AccOut), Mod:Goal) :-
RecursiveCall)
], Mod).
/*
:- unhide('$translate_rule').
% stolen from SWI-Prolog
user:goal_expansion(phrase(NT,Xs), Mod, NTXsNil) :-
user:goal_expansion(phrase(NT,Xs,[]), Mod, NTXsNil).
user:goal_expansion(phrase(NT,Xs0,Xs), Mod, NewGoal) :-
goal_expansion_allowed,
Goal = phrase(NT,Xs0,Xs),
nonvar(NT),
catch('$translate_rule'((pseudo_nt --> NT), Rule),
error(Pat,ImplDep),
( \+ harmless_dcgexception(Pat),
throw(error(Pat,ImplDep))
)),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Goal \== NewGoal0,
% apply translation only if we are safe
\+ contains_illegal_dcgnt(NT), !,
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal
).
:- hide('$translate_rule').
*/
/**
@}
*/

19
library/maputils.yap
View File

@ -24,6 +24,9 @@
number_of_expansions(0).
%
% compile auxiliary routines for term expansion
%
compile_aux([Clause|Clauses], Module) :-
% compile the predicate declaration if needed
( Clause = (Head :- _)
@ -83,22 +86,6 @@ transformation_id(Id) :-
Id1 is Id+1,
assert(number_of_expansions(Id1)).
harmless_dcgexception(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
harmless_dcgexception(type_error(callable,_)). % ex: phrase(27,L)
%% contains_illegal_dcgnt(+ Term) is semidet.
%
% `True` if _Term_ contains a non-terminal we cannot deal with using
% goal-expansion. The test is too general approximation, but safe.
contains_illegal_dcgnt(NT) :-
sub_term(I, NT),
nonvar(I),
( I = ! ; I = phrase(_,_,_) ), !.
% write(contains_illegal_nt(NT)), % JW: we do not want to write
% nl.
%% goal_expansion_allowed is semidet.
%
% `True` if we can use

2
misc/HEAPFIELDS
View File

@ -325,7 +325,7 @@ struct record_list *yap_records Yap_Records =NULL RestoreYapRecords()
/* SWI atoms and functors */
Atom *swi_atoms SWI_Atoms InitSWIAtoms() RestoreSWIAtoms()
Functor swi_functors[N_SWI_FUNCTORS] SWI_Functors void void
Functor *swi_functors SWI_Functors void void
struct swi_reverse_hash swi_reverse_hash[N_SWI_HASH] SWI_ReverseHash void void

26
misc/buildheap
View File

@ -1,6 +1,6 @@
:- use_module(library(lineutils),
[file_filter_with_init/5,
[file_filter_with_initialization/5,
split/3,
glue/3]).
@ -18,18 +18,18 @@
main :-
warning(Warning),
file_filter_with_init('misc/HEAPFIELDS','H/hstruct.h',gen_struct,Warning,['hstruct.h','HEAPFIELDS']),
file_filter_with_init('misc/HEAPFIELDS','H/dhstruct.h',gen_dstruct,Warning,['dhstruct.h','HEAPFIELDS']),
file_filter_with_init('misc/HEAPFIELDS','H/rhstruct.h',gen_hstruct,Warning,['rhstruct.h','HEAPFIELDS']),
file_filter_with_init('misc/HEAPFIELDS','H/ihstruct.h',gen_init,Warning,['ihstruct.h','HEAPFIELDS']).
%file_filter_with_init('misc/GLOBALS','H/hglobals.h',gen_struct,Warning,['hglobals.h','GLOBALS']),
%file_filter_with_init('misc/GLOBALS','H/dglobals.h',gen_dstruct,Warning,['dglobals.h','GLOBALS']),
%file_filter_with_init('misc/GLOBALS','H/rglobals.h',gen_hstruct,Warning,['rglobals.h','GLOBALS']),
%file_filter_with_init('misc/GLOBALS','H/iglobals.h',gen_init,Warning,['iglobals.h','GLOBALS']),
%file_filter_with_init('misc/LOCALS','H/hlocals.h',gen_struct,Warning,['hlocals.h','LOCALS']),
%file_filter_with_init('misc/LOCALS','H/dlocals.h',gen_dstruct,Warning,['dlocals.h','LOCALS']),
%file_filter_with_init('misc/LOCALS','H/rlocals.h',gen_hstruct,Warning,['rlocals.h','LOCALS']),
%file_filter_with_init('misc/LOCALS','H/ilocals.h',gen_init,Warning,['ilocals.h','LOCALS']).
file_filter_with_initialization('misc/HEAPFIELDS','H/hstruct.h',gen_struct,Warning,['hstruct.h','HEAPFIELDS']),
file_filter_with_initialization('misc/HEAPFIELDS','H/dhstruct.h',gen_dstruct,Warning,['dhstruct.h','HEAPFIELDS']),
file_filter_with_initialization('misc/HEAPFIELDS','H/rhstruct.h',gen_hstruct,Warning,['rhstruct.h','HEAPFIELDS']),
file_filter_with_initialization('misc/HEAPFIELDS','H/ihstruct.h',gen_init,Warning,['ihstruct.h','HEAPFIELDS']).
%file_filter_with_initialization('misc/GLOBALS','H/hglobals.h',gen_struct,Warning,['hglobals.h','GLOBALS']),
%file_filter_with_initialization('misc/GLOBALS','H/dglobals.h',gen_dstruct,Warning,['dglobals.h','GLOBALS']),
%file_filter_with_initialization('misc/GLOBALS','H/rglobals.h',gen_hstruct,Warning,['rglobals.h','GLOBALS']),
%file_filter_with_initialization('misc/GLOBALS','H/iglobals.h',gen_init,Warning,['iglobals.h','GLOBALS']),
%file_filter_with_initialization('misc/LOCALS','H/hlocals.h',gen_struct,Warning,['hlocals.h','LOCALS']),
%file_filter_with_initialization('misc/LOCALS','H/dlocals.h',gen_dstruct,Warning,['dlocals.h','LOCALS']),
%file_filter_with_initialization('misc/LOCALS','H/rlocals.h',gen_hstruct,Warning,['rlocals.h','LOCALS']),
%file_filter_with_initialization('misc/LOCALS','H/ilocals.h',gen_init,Warning,['ilocals.h','LOCALS']).
warning('~n /* This file, ~a, was generated automatically by \"yap -L misc/buildheap\"~n please do not update, update misc/~a instead */~n~n').

4
os/SWI-Stream.h
View File

@ -112,8 +112,8 @@ typedef struct io_functions
typedef struct io_position
{ int64_t byteno; /* byte-position in file */
int64_t charno; /* character position in file */
int lineno; /* lineno in file */
int linepos; /* position in line */
long int lineno; /* lineno in file */
long int linepos; /* position in line */
intptr_t reserved[2]; /* future extensions */
} IOPOS;

19
os/pl-read.c
View File

@ -1570,6 +1570,24 @@ PRED_IMPL("term_to_atom", 2, term_to_atom, 0)
{ return atom_to_term(A2, A1, 0);
}
static
PRED_IMPL("$set_source", 2, set_source, 0)
{
GET_LD
atom_t at;
term_t a = PL_new_term_ref();
if (!PL_get_atom(A1, &at))
return FALSE;
source_file_name = at;
if (!PL_get_arg(1, A2, a) || !PL_get_int64(a, &source_char_no) ||
!PL_get_arg(2, A2, a) || !PL_get_long(a, &source_line_no) ||
!PL_get_arg(3, A2, a) || !PL_get_long(a, &source_line_pos) ||
!PL_get_arg(4, A2, a) || !PL_get_int64(a, &source_byte_no) ) {
return FALSE;
}
return TRUE;
}
int
PL_chars_to_term(const char *s, term_t t)
@ -1600,6 +1618,7 @@ PRED_DEF("read_term", 2, read_term, PL_FA_ISO)
PRED_DEF("read_clause", 3, read_clause, 0)
PRED_DEF("atom_to_term", 3, atom_to_term, 0)
PRED_DEF("term_to_atom", 2, term_to_atom, 0)
PRED_DEF("$set_source", 2, set_source, 0)
#ifdef O_QUASIQUOTATIONS
PRED_DEF("$qq_open", 2, qq_open, 0)
#endif

8
pl/absf.yap
View File

@ -30,7 +30,6 @@
remove_from_path/1], ['$full_filename'/3,
'$system_library_directories'/2]).
:- use_system_module( '$_boot', ['$system_catch'/4]).
:- use_system_module( '$_errors', ['$do_error'/2]).
@ -134,10 +133,8 @@ absolute_file_name(user,user) :- !.
absolute_file_name(File0,File) :-
'$absolute_file_name'(File0,[access(none),file_type(txt),file_errors(fail),solutions(first)],File,absolute_file_name(File0,File)).
'$full_filename'(F0,F,G) :-
'$absolute_file_name'(F0,[access(read),file_type(source),file_errors(fail),solutions(first),expand(true)],F,G).
'$full_filename'(F0, F, G) :-
'$absolute_file_name'(F0,[access(read),file_type(prolog),file_errors(fail),solutions(first),expand(true)],F,G).
'$absolute_file_name'(File, _Opts, _TrueFileName, G) :- var(File), !,
'$do_error'(instantiation_error, G).
@ -591,7 +588,6 @@ user:prolog_file_type(A, prolog) :-
A \== prolog,
A \==pl,
A \== yap.
user:prolog_file_type(qly, prolog).
user:prolog_file_type(qly, qly).
user:prolog_file_type(A, executable) :-
current_prolog_flag(shared_object_extension, A).

78
pl/arith.yap
View File

@ -28,7 +28,6 @@
expand_expr/5,
expand_expr/6] ).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_modules', ['$clean_cuts'/2]).
@ -60,8 +59,7 @@
*/
/**
@pred expand_exprs(- _O_,+ _N_)
/** @pred expand_exprs(- _O_,+ _N_)
Control term expansion during compilation.
Enables low-level optimizations. It reports the current state by
@ -86,6 +84,7 @@ expand_exprs(Old,New) :-
After a call to this predicate, arithmetical expressions will be compiled.
(see example below). This is the default behavior.
*/
compile_expressions :- set_value('$c_arith',true).
/** @pred do_not_compile_expressions
@ -198,6 +197,31 @@ do_c_built_in(Comp0, _, R) :- % now, do it for comparisons
expand_expr(F, Q, V),
'$do_and'(P, Q, R0),
'$do_and'(R0, Comp, R).
do_c_built_in(phrase(NT,Xs), NTXsNil) :-
'$_arith':do_c_built_in(phrase(NT,Xs,[]), NTXsNil).
do_c_built_in(phrase(NT,Xs0,Xs), Mod, NewGoal) :-
'$goal_expansion_allowed'(phrase(NT,Xs0,Xs), Mod),
Goal = phrase(NT,Xs0,Xs),
callable(NT),
catch('$translate_rule'((pseudo_nt --> NT), Rule),
error(Pat,ImplDep),
( \+ '$harmless_dcgexception'(Pat),
throw(error(Pat,ImplDep))
)),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Goal \== NewGoal0,
% apply translation only if we are safe
\+ '$contains_illegal_dcgnt'(NT), !,
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal
).
do_c_built_in(P, _, P).
do_c_built_metacall(G1, Mod, '$execute_wo_mod'(G1,Mod)) :-
@ -369,6 +393,54 @@ expand_expr(Op, X, Y, O, Q, P) :-
'$preprocess_args_for_non_commutative'(X, Y, Z, W, E) :-
'$do_and'(Z = X, Y = W, E).
do_c_built_in(phrase(NT,Xs), NTXsNil) :-
'$_arith':do_c_built_in(phrase(NT,Xs,[]), NTXsNil).
do_c_built_in(phrase(NT,Xs0,Xs), Mod, NewGoal) :-
'$goal_expansion_allowed'(phrase(NT,Xs0,Xs), Mod),
Goal = phrase(NT,Xs0,Xs),
callable(NT),
catch('$translate_rule'((pseudo_nt --> NT), Rule),
error(Pat,ImplDep),
( \+ '$harmless_dcgexception'(Pat),
throw(error(Pat,ImplDep))
)),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Goal \== NewGoal0,
% apply translation only if we are safe
\+ '$contains_illegal_dcgnt'(NT), !,
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal
).
'$goal_expansion_allowed'(phrase(_NT,_Xs0,_Xs), _Mod).
%% contains_illegal_dcgnt(+Term) is semidet.
%
% True if Term contains a non-terminal we cannot deal with using
% goal-expansion. The test is too general approximation, but safe.
'$contains_illegal_dcgnt'(NT) :-
functor(NT, _, A),
between(1, A, I),
arg(I, NT),
nonvar(I),
( I = ! ; I = phrase(_,_,_) ), !.
% write(contains_illegal_nt(NT)), % JW: we do not want to write
% nl.
'$harmless_dcgexception'(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
'$harmless_dcgexception'(type_error(callable,_)). % ex: phrase(27,L)
/**
@}

13
pl/boot.yap
View File

@ -688,8 +688,17 @@ number of steps.
%
% but YAP and SICStus does.
%
'$process_directive'(G, _, M, VL, Pos) :-
( '$execute'(M:G) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ).
'$process_directive'(G, Mode, M, VL, Pos) :-
( '$undefined'('$save_directive'(G, Mode, M, VL, Pos),prolog) ->
true
;
'$save_directive'(G, Mode, M, VL, Pos)
->
true
;
true
),
( '$execute'(M:G) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ).
'$continue_with_command'(Where,V,'$stream_position'(C,_P,A1,A2,A3),'$source_location'(_F,L):G,Source) :- !,
'$continue_with_command'(Where,V,'$stream_position'(C,L,A1,A2,A3),G,Source).

239
pl/consult.yap
View File

@ -157,6 +157,23 @@ following flags:
If true, raise an error if the file is not a module file. Used by
` use_module/1 and use_module/2.
+ qcompile(+ _Value_)
SWI-Prolog flag that controls whether loaded files should be also
compiled into `qly` files. The default value is obtained from the flag
`qcompile`:
`never`, no `qly` file is generated unless the user calls
qsave_file/1 and friends, or sets the qcompile option in
load_files/2;
`auto`, all files are qcompiled.
`large`, files above 100KB are qcompiled.
`part`, not supported in YAP.
+ autoload(+ _Autoload_)
SWI-compatible option where if _Autoload_ is `true` undefined
@ -175,7 +192,7 @@ following flags:
% expand(true,false)
% if(changed,true,not_loaded) => implemented
% imports(all,List) => implemented
% qcompile(true,false)
% qcompile() => implemented
% silent(true,false) => implemented
% stream(Stream) => implemented
% consult(consult,reconsult,exo,db) => implemented
@ -191,7 +208,8 @@ load_files(Files,Opts) :-
'$lf_option'(expand, 4, false).
'$lf_option'(if, 5, true).
'$lf_option'(imports, 6, all).
'$lf_option'(qcompile, 7, never).
'$lf_option'(qcompile, 7, Current) :-
'$nb_getval'('$qcompile', Current, Current = never).
'$lf_option'(silent, 8, _).
'$lf_option'(skip_unix_header, 9, false).
'$lf_option'(compilation_mode, 10, source).
@ -315,9 +333,11 @@ load_files(Files,Opts) :-
is_list(Val) -> ( ground(Val) -> true ; '$do_error'(instantiation_error,Call) ) ;
'$do_error'(domain_error(unimplemented_option,imports(Val)),Call) ).
'$process_lf_opt'(qcompile, Val,Call) :-
( Val == true -> '$do_error'(domain_error(unimplemented_option,expand),Call) ;
Val == false -> true ;
'$do_error'(domain_error(unimplemented_option,expand(Val)),Call) ).
( Val == part -> '$do_error'(domain_error(unimplemented_option,expand),Call) ;
Val == never -> true ;
Val == auto -> true ;
Val == large -> true ;
'$do_error'(domain_error(unknown_option,qcompile(Val)),Call) ).
'$process_lf_opt'(silent, Val, Call) :-
( Val == false -> true ;
Val == true -> true ;
@ -327,19 +347,19 @@ load_files(Files,Opts) :-
Val == true -> true ;
'$do_error'(domain_error(unimplemented_option,skip_unix_header(Val)),Call) ).
'$process_lf_opt'(compilation_mode, Val, Call) :-
( Val == source -> true ;
Val == compact -> true ;
Val == assert_all -> true ;
'$do_error'(domain_error(unimplemented_option,compilation_mode(Val)),Call) ).
( Val == source -> true ;
Val == compact -> true ;
Val == assert_all -> true ;
'$do_error'(domain_error(unimplemented_option,compilation_mode(Val)),Call) ).
'$process_lf_opt'(consult, Val , Call) :-
( Val == reconsult -> true ;
Val == consult -> true ;
Val == exo -> true ;
Val == db -> true ;
'$do_error'(domain_error(unimplemented_option,consult(Val)),Call) ).
( Val == reconsult -> true ;
Val == consult -> true ;
Val == exo -> true ;
Val == db -> true ;
'$do_error'(domain_error(unimplemented_option,consult(Val)),Call) ).
'$process_lf_opt'(reexport, Val , Call) :-
( Val == true -> true ;
Val == false -> true ;
Val == false -> true ;
'$do_error'(domain_error(unimplemented_option,reexport(Val)),Call) ).
'$process_lf_opt'(must_be_module, Val , Call) :-
( Val == true -> true ;
@ -396,23 +416,54 @@ load_files(Files,Opts) :-
b_setval('$source_file', user_input),
'$do_lf'(Mod, user_input, user_input, TOpts).
'$lf'(File, Mod, Call, TOpts) :-
'$lf_opt'(stream, TOpts, Stream),
b_setval('$source_file', File),
( var(Stream) ->
'$lf_opt'(stream, TOpts, Stream),
var( Stream ),
H0 is heapused, '$cputime'(T0,_),
% check if there is a qly files
'$absolute_file_name'(File,[access(read),file_type(qly),file_errors(fail),solutions(first),expand(true)],F,load_files(File)),
open( F, read, Stream , [type(binary)] ),
( '$q_header'( Stream, Type ),
Type == file
->
time_file64(F, T0F),
'$absolute_file_name'(File,[access(read),file_type(prolog),file_errors(fail),solutions(first),expand(true)],FilePl,load_files(File)),
time_file64(FilePl, T0Fl),
T0F >= T0Fl,
!,
file_directory_name(F, Dir),
working_directory(OldD, Dir),
'$msg_level'( TOpts, Verbosity),
'$lf_opt'(imports, TOpts, ImportList),
'$qload_file'(Stream, Mod, F, FilePl, File, ImportList),
close( Stream ),
H is heapused-H0, '$cputime'(TF,_), T is TF-T0,
'$current_module'(M, Mod),
working_directory( _, OldD),
print_message(Verbosity, loaded( loaded, F, M, T, H)),
'$exec_initialisation_goals'
;
close( Stream),
fail
).
'$lf'(File, Mod, Call, TOpts) :-
'$lf_opt'(stream, TOpts, Stream),
b_setval('$source_file', File),
( var(Stream) ->
/* need_to_open_file */
'$full_filename'(File, Y, Call),
open(Y, read, Stream)
;
true
), !,
'$lf_opt'(reexport, TOpts, Reexport),
'$lf_opt'(if, TOpts, If),
( var(If) -> If = true ; true ),
'$lf_opt'(imports, TOpts, Imports),
'$start_lf'(If, Mod, Stream, TOpts, File, Reexport, Imports),
close(Stream).
stream_property(Stream, file_name(Y))
), !,
'$lf_opt'(reexport, TOpts, Reexport),
'$lf_opt'(if, TOpts, If),
( var(If) -> If = true ; true ),
'$lf_opt'(imports, TOpts, Imports),
'$start_lf'(If, Mod, Stream, TOpts, File, Reexport, Imports),
character_count(Stream, Pos),
close(Stream).
'$lf'(X, _, Call, _) :-
'$do_error'(permission_error(input,stream,X),Call).
'$do_error'(permission_error(input,stream,X),Call).
'$start_lf'(not_loaded, Mod, Stream, TOpts, UserFile, Reexport,Imports) :-
'$file_loaded'(Stream, Mod, Imports, TOpts), !,
@ -587,6 +638,9 @@ db_files(Fs) :-
'$lf_opt'('$context_module', TOpts, ContextModule),
'$lf_opt'(reexport, TOpts, Reexport),
'$msg_level'( TOpts, Verbosity),
'$lf_opt'(qcompile, TOpts, QCompiling),
'$nb_getval'('$qcompile', ContextQCompiling, ContextQCompiling = never),
nb_setval('$qcompile', QCompiling),
% format( 'I=~w~n', [Verbosity=UserFile] ),
'$lf_opt'(encoding, TOpts, Encoding),
'$set_encoding'(Stream, Encoding),
@ -618,18 +672,22 @@ db_files(Fs) :-
StartMsg = consulting,
EndMsg = consulted
),
print_message(Verbosity, loading(StartMsg, File)),
print_message(Verbosity, loading(StartMsg, UserFile)),
'$lf_opt'(skip_unix_header , TOpts, SkipUnixHeader),
( SkipUnixHeader == true->
( SkipUnixHeader == true
->
'$skip_unix_header'(Stream)
;
;
true
),
'$loop'(Stream,Reconsult),
),
'$loop'(Stream,Reconsult),
'$lf_opt'(imports, TOpts, Imports),
'$import_to_current_module'(File, ContextModule, Imports, _, TOpts),
'$end_consult',
'$q_do_save_file'(File, UserFile, ContextModule, TOpts ),
H is heapused-H0, '$cputime'(TF,_), T is TF-T0,
'$current_module'(Mod, SourceModule),
print_message(Verbosity, loaded(EndMsg, File, Mod, T, H)),
'$end_consult',
(
Reconsult = reconsult ->
'$clear_reconsulting'
@ -646,14 +704,21 @@ db_files(Fs) :-
nb_setval('$if_level',OldIfLevel),
'$lf_opt'('$use_module', TOpts, UseModule),
'$bind_module'(Mod, UseModule),
'$lf_opt'(imports, TOpts, Imports),
'$import_to_current_module'(File, ContextModule, Imports, _, TOpts),
'$reexport'( TOpts, ParentF, Reexport, Imports, File ),
nb_setval('$qcompile', ContextQCompiling),
( LC == 0 -> prompt(_,' |: ') ; true),
'$exec_initialisation_goals',
% format( 'O=~w~n', [Mod=UserFile] ),
!.
'$q_do_save_file'(File, UserF, ContextModule, TOpts ) :-
'$lf_opt'(qcompile, TOpts, QComp),
( QComp == auto ; QComp == large, Pos > 100*1024),
'$absolute_file_name'(UserF,[file_type(qly),solutions(first),expand(true)],F,load_files(File)),
!,
'$qsave_file_'( File, UserF, F ).
'$q_do_save_file'(_File, _, _ContextModule, _TOpts ).
% are we in autoload and autoload_flag is false?
'$msg_level'( TOpts, Verbosity) :-
'$lf_opt'(autoload, TOpts, AutoLoad),
@ -687,12 +752,11 @@ db_files(Fs) :-
'$bind_module'(Mod, use_module(Mod)).
'$import_to_current_module'(File, ContextModule, Imports, RemainingImports, TOpts) :-
\+ recorded('$module','$module'(File, _Module, _, _ModExports, _),_),
\+ recorded('$module','$module'(File, _Module, _, _ModExports, _),_),
% enable loading C-predicates from a different file
recorded( '$load_foreign_done', [File, M0], _),
'$import_foreign'(File, M0, ContextModule ),
fail.
'$import_to_current_module'(File, ContextModule, Imports, RemainingImports, TOpts) :-
recorded('$module','$module'(File, Module, _Source, ModExports, _),_),
Module \= ContextModule, !,
@ -836,59 +900,50 @@ source_file(Mod:Pred, FileName) :-
Obtain information on what is going on in the compilation process. The
following keys are available:
+ directory (prolog_load_context/2 option)
+ directory
Full name for the directory where YAP is currently consulting the
Full name for the directory where YAP is currently consulting the
file.
+ file
+ file (prolog_load_context/2 option)
Full name for the file currently being consulted. Notice that included
Full name for the file currently being consulted. Notice that included
filed are ignored.
+ module
+ module (prolog_load_context/2 option)
Current source module.
Current source module.
+ `source` (prolog_load_context/2 option)
Full name for the file currently being read in, which may be consulted,
reconsulted, or included.
+ `stream`
+ `stream` (prolog_load_context/2 option)
Stream currently being read in.
+ `term_position`
+ `term_position` (prolog_load_context/2 option)
Stream position at the stream currently being read in. For SWI
compatibility, it is a term of the form
'$stream_position'(0,Line,0,0,0).
'$stream_position'(0,Line,0,0).
+ `source_location(? _FileName_, ? _Line_)`
+ `source_location(? _FileName_, ? _Line_)` (prolog_load_context/2 option)
SWI-compatible predicate. If the last term has been read from a physical file (i.e., not from the file user or a string), unify File with an absolute path to the file and Line with the line-number in the file. Please use prolog_load_context/2.
+ `source_file(? _File_)`
+ `source_file(? _File_)` (prolog_load_context/2 option)
SWI-compatible predicate. True if _File_ is a loaded Prolog source file.
+ `source_file(? _ModuleAndPred_,? _File_)`
+ `source_file(? _ModuleAndPred_,? _File_)` (prolog_load_context/2 option)
SWI-compatible predicate. True if the predicate specified by _ModuleAndPred_ was loaded from file _File_, where _File_ is an absolute path name (see `absolute_file_name/2`).
*/
@section YAPLibraries Library Predicates
/** @addgroup YAPLibraries Library Predicates
Library files reside in the library_directory path (set by the
`LIBDIR` variable in the Makefile for YAP). Currently,
@ -919,7 +974,14 @@ prolog_load_context(term_position, Position) :-
% if the file exports a module, then we can
% be imported from any module.
'$file_loaded'(Stream, M, Imports, TOpts) :-
'$file_name'(Stream, F),
'$file_name'(Stream, F0),
(
atom_concat(Prefix, '.qly', F0 )
->
'$absolute_file_name'(Prefix,[access(read),file_type(prolog),file_errors(fail),solutions(first),expand(true)],F,load_files(Prefix))
;
F0 = F
),
'$ensure_file_loaded'(F, M, F1),
% format( 'IL=~w~n', [(F1:Imports->M)] ),
'$import_to_current_module'(F1, M, Imports, _, TOpts).
@ -960,7 +1022,8 @@ prolog_load_context(term_position, Position) :-
% inform the file has been loaded and is now available.
'$loaded'(Stream, UserFile, M, OldF, Line, Reconsult, F, Dir, Opts) :-
'$file_name'(Stream, F0),
( F0 == user_input, nonvar(UserFile) -> UserFile = F ; F = F0 ),
( F0 == user_input, nonvar(UserFile) -> UserFile = F
; F = F0 ),
( F == user_input -> working_directory(Dir,Dir) ; file_directory_name(F, Dir) ),
nb_setval('$consulting_file', F ),
( Reconsult \== consult, Reconsult \== not_loaded, Reconsult \== changed, recorded('$lf_loaded','$lf_loaded'(F, _,_),R), erase(R), fail ; var(Reconsult) -> Reconsult = consult ; true ),
@ -1071,6 +1134,52 @@ source_file_property( File0, Prop) :-
'$source_file_property'( F, module(M)) :-
recorded('$module','$module'(F,M,_,_,_),_).
unload_file( F0 ) :-
absolute_file_name( F0, F1, [expand(true),file_type(prolog)] ),
'$unload_file'( F1, F0 ).
% eliminate multi-files;
% get rid of file-only predicataes.
'$unload_file'( FileName, _F0 ) :-
'$current_predicate_var'(A,Mod,P).
'$owner_file'(P,Mod,FileName),
\+ '$is_multifile'(P,Mod),
functor( P, Na, Ar),
abolish(Mod:Na/Ar),
fail.
%next multi-file.
'$unload_file'( FileName, _F0 ) :-
recorded('$lf_loaded','$lf_loaded'( F, Age, _), R),
erase(R),
fail.
'$unload_file'( FileName, _F0 ) :-
recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef), R),
erase(R),
erase(ClauseRef),
fail.
'$unload_file'( FileName, _F0 ) :-
recorded('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,FFileName,R), R1),
erase(R1),
erase(R),
fail.
'$unload_file'( FileName, _F0 ) :-
recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), R),
erase(R),
fail.
'$unload_file'( FileName, _F0 ) :-
recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), R),
erase(R),
fail.
'$unload_file'( FileName, _F0 ) :-
recorded('$module','$module'( FileName, Mod, _SourceF, _, _), R),
erase( R ),
unload_module(Mod),
fail.
'$unload_file'( FileName, _F0 ) :-
recorded('$directive','$d'( FileName, _M:_G, _Mode, _VL, _Pos ), R),
erase(R),
fail.
/**
@ -1370,12 +1479,6 @@ part of the code due to different capabilities.
Realise different configuration options for your software.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
:- if(test1).
section_1.

2
pl/dbload.yap
View File

@ -87,7 +87,7 @@ dbload(F, _, G) :-
'$do_error'(type_error(atom,F),G).
do_dbload(F0, M0, G) :-
'$full_filename'(F0,F,G),
'$full_filename'(F0, F, G),
assert(dbprocess(F, M0)),
open(F, read, R),
check_dbload_stream(R, M0),

9
pl/directives.yap
View File

@ -93,16 +93,17 @@
'$directive'(use_module(_,_,_)).
'$directive'(wait(_)).
'$exec_directives'((G1,G2), Mode, M, VL, Pos) :- !,
'$exec_directives'(G1, Mode, M, VL, Pos),
'$exec_directives'(G2, Mode, M, VL, Pos).
'$exec_directives'((G1,G2), Mode, M, VL, Pos) :-
!,
'$exec_directives'(G1, Mode, M, VL, Pos),
'$exec_directives'(G2, Mode, M, VL, Pos).
'$exec_directives'(G, Mode, M, VL, Pos) :-
'$save_directive'(G, Mode, M, VL, Pos),
'$exec_directive'(G, Mode, M, VL, Pos).
'$save_directive'(G, Mode, M, VL, Pos) :-
prolog_load_context(file, FileName), !,
recorda('$directive', directive(File,M:G, Mode, VL, Pos),_).
recordz('$directive', directive(FileName,M:G, Mode, VL, Pos),_).
'$exec_directive'(multifile(D), _, M, _, _) :-
'$system_catch'('$multifile'(D, M), M,

30
pl/flags.yap
View File

@ -279,6 +279,21 @@ profile_data/3 built-in.
SWI-Compatible option, determines prompting for alternatives in the Prolog toplevel. Default is <tt>groundness</tt>, YAP prompts for alternatives if and only if the query contains variables. The alternative, default in SWI-Prolog is <tt>determinism</tt> which implies the system prompts for alternatives if the goal succeeded while leaving choicepoints.
+ `qcompile(+{never, auto, large, part}, changeable)`
SWI-Prolog flag that controls whether loaded files should be also
compiled into qfiles. The default value is `never`.
`never`, no qcompile file is generated unless the user calls
qsave_file/1 and friends, or sets the qcompile option in
load_files/2;
`auto`, all files are qcompiled.
`large`, files above 100KB are qcompiled.
`part`, not supported in YAP.
+ `redefine_warnings `
If _Value_ is unbound, tell whether warnings for procedures defined
@ -873,13 +888,22 @@ yap_flag(chr_toplevel_show_store,X) :-
yap_flag(chr_toplevel_show_store,X) :-
'$do_error'(domain_error(flag_value,chr_toplevel_show_store+X),yap_flag(chr_toplevel_show_store,X)).
yap_flag(qcompile,X) :-
var(X), !,
'$nb_getval'('$qcompile', X, X=never).
yap_flag(qcompile,X) :-
(X == never ; X == auto ; X == large ; X == part), !,
nb_setval('$qcompile',X).
yap_flag(qcompile,X) :-
'$do_error'(domain_error(flag_value,qcompile+X),yap_flag(qcompile,X)).
yap_flag(source,X) :-
var(X), !,
source_mode( X, X ).
yap_flag(source,X) :-
(X == off -> true ; X == on), !,
source_mode( _, X ).
yap_flag(chr_toplevel_show_store,X) :-
yap_flag(source,X) :-
'$do_error'(domain_error(flag_value,source+X),yap_flag(source,X)).
yap_flag(open_expands_filename,Expand) :-
@ -1375,8 +1399,8 @@ create_prolog_flag(Name, Value, Options) :-
'$flag_domain_from_value'(_, term).
/**
@pred source_mode(- _O_,+ _N_)
/**
@pred source_mode(- _O_,+ _N_)
The state of source mode can either be on or off. When the source mode
is on, all clauses are kept both as compiled code and in a "hidden"

218
pl/grammar.yap
View File

@ -61,19 +61,19 @@ Grammar related built-in predicates:
*/
:- system_module( '$_grammar', [!/2,
(',')/4,
(->)/4,
('.')/4,
(;)/4,
'C'/3,
[]/2,
[]/4,
(\+)/3,
phrase/2,
phrase/3,
{}/3,
('|')/4], ['$translate_rule'/2]).
:- module( '$_grammar', [!/2,
- (',')/4,
- (->)/4,
- ('.')/4,
- (;)/4,
- 'C'/3,
- []/2,
- []/4,
- (\+)/3,
- phrase/2,
- phrase/3,
- {}/3,
- ('|')/4]).
:- use_system_module( '$_errors', ['$do_error'/2]).
@ -89,41 +89,41 @@ Grammar related built-in predicates:
Also, phrase/2-3 check their first argument.
*/
'$translate_rule'((LP-->RP), (NH:-B)) :-
'$t_head'(LP, NH, NGs, S, SR, (LP-->RP)),
prolog:'$translate_rule'((LP-->RP), (NH:-B)) :-
t_head(LP, NH, NGs, S, SR, (LP-->RP)),
(var(NGs) ->
'$t_body'(RP, _, last, S, SR, B1)
t_body(RP, _, last, S, SR, B1)
;
'$t_body'((RP,{NGs}), _, last, S, SR, B1)
t_body((RP,{NGs}), _, last, S, SR, B1)
),
'$t_tidy'(B1, B).
t_tidy(B1, B).
'$t_head'(V, _, _, _, _, G0) :- var(V), !,
t_head(V, _, _, _, _, G0) :- var(V), !,
'$do_error'(instantiation_error,G0).
'$t_head'((H,List), NH, NGs, S, S1, G0) :- !,
'$t_hgoal'(H, NH, S, SR, G0),
'$t_hlist'(List, S1, SR, NGs, G0).
'$t_head'(H, NH, _, S, SR, G0) :-
'$t_hgoal'(H, NH, S, SR, G0).
t_head((H,List), NH, NGs, S, S1, G0) :- !,
t_hgoal(H, NH, S, SR, G0),
t_hlist(List, S1, SR, NGs, G0).
t_head(H, NH, _, S, SR, G0) :-
t_hgoal(H, NH, S, SR, G0).
'$t_hgoal'(V, _, _, _, G0) :- var(V), !,
t_hgoal(V, _, _, _, G0) :- var(V), !,
'$do_error'(instantiation_error,G0).
'$t_hgoal'(M:H, M:NH, S, SR, G0) :- !,
'$t_hgoal'(H, NH, S, SR, G0).
'$t_hgoal'(H, NH, S, SR, _) :-
'$extend'([S,SR],H,NH).
t_hgoal(M:H, M:NH, S, SR, G0) :- !,
t_hgoal(H, NH, S, SR, G0).
t_hgoal(H, NH, S, SR, _) :-
extend([S,SR],H,NH).
'$t_hlist'(V, _, _, _, G0) :- var(V), !,
t_hlist(V, _, _, _, G0) :- var(V), !,
'$do_error'(instantiation_error,G0).
'$t_hlist'([], _, _, true, _).
'$t_hlist'(String, S0, SR, SF, G0) :- string(String), !,
t_hlist([], _, _, true, _).
t_hlist(String, S0, SR, SF, G0) :- string(String), !,
string_codes( String, X ),
'$t_hlist'( X, S0, SR, SF, G0).
'$t_hlist'([H], S0, SR, ('C'(SR,H,S0)), _) :- !.
'$t_hlist'([H|List], S0, SR, ('C'(SR,H,S1),G0), Goal) :- !,
'$t_hlist'(List, S0, S1, G0, Goal).
'$t_hlist'(T, _, _, _, Goal) :-
t_hlist( X, S0, SR, SF, G0).
t_hlist([H], S0, SR, ('C'(SR,H,S0)), _) :- !.
t_hlist([H|List], S0, SR, ('C'(SR,H,S1),G0), Goal) :- !,
t_hlist(List, S0, S1, G0, Goal).
t_hlist(T, _, _, _, Goal) :-
'$do_error'(type_error(list,T),Goal).
@ -133,77 +133,73 @@ Grammar related built-in predicates:
% variables.
% Last tells whether we are the ones who should close that chain.
%
'$t_body'(Var, filled_in, _, S, S1, phrase(Var,S,S1)) :-
t_body(Var, filled_in, _, S, S1, phrase(Var,S,S1)) :-
var(Var),
!.
'$t_body'(!, to_fill, last, S, S1, (!, S1 = S)) :- !.
'$t_body'(!, _, _, S, S, !) :- !.
'$t_body'([], to_fill, last, S, S1, S1=S) :- !.
'$t_body'([], _, _, S, S, true) :- !.
'$t_body'(X, FilledIn, Last, S, SR, OS) :- string(X), !,
t_body(!, to_fill, last, S, S1, (!, S1 = S)) :- !.
t_body(!, _, _, S, S, !) :- !.
t_body([], to_fill, last, S, S1, S1=S) :- !.
t_body([], _, _, S, S, true) :- !.
t_body(X, FilledIn, Last, S, SR, OS) :- string(X), !,
string_codes( X, Codes),
'$t_body'(Codes, FilledIn, Last, S, SR, OS).
'$t_body'([X], filled_in, _, S, SR, 'C'(S,X,SR)) :- !.
'$t_body'([X|R], filled_in, Last, S, SR, ('C'(S,X,SR1),RB)) :- !,
'$t_body'(R, filled_in, Last, SR1, SR, RB).
'$t_body'({T}, to_fill, last, S, S1, (T, S1=S)) :- !.
'$t_body'({T}, _, _, S, S, T) :- !.
'$t_body'((T,R), ToFill, Last, S, SR, (Tt,Rt)) :- !,
'$t_body'(T, ToFill, not_last, S, SR1, Tt),
'$t_body'(R, ToFill, Last, SR1, SR, Rt).
'$t_body'((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !,
'$t_body'(T, ToFill, not_last, S, SR1, Tt),
'$t_body'(R, ToFill, Last, SR1, SR, Rt).
'$t_body'(\+T, ToFill, _, S, SR, (Tt->fail ; S=SR)) :- !,
'$t_body'(T, ToFill, not_last, S, _, Tt).
'$t_body'((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
'$t_body'(T, _, last, S, SR, Tt),
'$t_body'(R, _, last, S, SR, Rt).
'$t_body'((T|R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
'$t_body'(T, _, last, S, SR, Tt),
'$t_body'(R, _, last, S, SR, Rt).
'$t_body'(M:G, ToFill, Last, S, SR, M:NG) :- !,
'$t_body'(G, ToFill, Last, S, SR, NG).
'$t_body'(T, filled_in, _, S, SR, Tt) :-
'$extend'([S,SR], T, Tt).
t_body(Codes, FilledIn, Last, S, SR, OS).
t_body([X], filled_in, _, S, SR, 'C'(S,X,SR)) :- !.
t_body([X|R], filled_in, Last, S, SR, ('C'(S,X,SR1),RB)) :- !,
t_body(R, filled_in, Last, SR1, SR, RB).
t_body({T}, to_fill, last, S, S1, (T, S1=S)) :- !.
t_body({T}, _, _, S, S, T) :- !.
t_body((T,R), ToFill, Last, S, SR, (Tt,Rt)) :- !,
t_body(T, ToFill, not_last, S, SR1, Tt),
t_body(R, ToFill, Last, SR1, SR, Rt).
t_body((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !,
t_body(T, ToFill, not_last, S, SR1, Tt),
t_body(R, ToFill, Last, SR1, SR, Rt).
t_body(\+T, ToFill, _, S, SR, (Tt->fail ; S=SR)) :- !,
t_body(T, ToFill, not_last, S, _, Tt).
t_body((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
t_body(T, _, last, S, SR, Tt),
t_body(R, _, last, S, SR, Rt).
t_body((T|R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
t_body(T, _, last, S, SR, Tt),
t_body(R, _, last, S, SR, Rt).
t_body(M:G, ToFill, Last, S, SR, M:NG) :- !,
t_body(G, ToFill, Last, S, SR, NG).
t_body(T, filled_in, _, S, SR, Tt) :-
extend([S,SR], T, Tt).
'$extend'(More, OldT, NewT) :-
extend(More, OldT, NewT) :-
OldT =.. OldL,
lists:append(OldL, More, NewL),
NewT =.. NewL.
'$t_tidy'(P,P) :- var(P), !.
'$t_tidy'((P1;P2), (Q1;Q2)) :- !,
'$t_tidy'(P1, Q1),
'$t_tidy'(P2, Q2).
'$t_tidy'((P1->P2), (Q1->Q2)) :- !,
'$t_tidy'(P1, Q1),
'$t_tidy'(P2, Q2).
'$t_tidy'(((P1,P2),P3), Q) :-
'$t_tidy'((P1,(P2,P3)), Q).
'$t_tidy'((true,P1), Q1) :- !,
'$t_tidy'(P1, Q1).
'$t_tidy'((P1,true), Q1) :- !,
'$t_tidy'(P1, Q1).
'$t_tidy'((P1,P2), (Q1,Q2)) :- !,
'$t_tidy'(P1, Q1),
'$t_tidy'(P2, Q2).
'$t_tidy'(A, A).
t_tidy(P,P) :- var(P), !.
t_tidy((P1;P2), (Q1;Q2)) :- !,
t_tidy(P1, Q1),
t_tidy(P2, Q2).
t_tidy((P1->P2), (Q1->Q2)) :- !,
t_tidy(P1, Q1),
t_tidy(P2, Q2).
t_tidy(((P1,P2),P3), Q) :-
t_tidy((P1,(P2,P3)), Q).
t_tidy((true,P1), Q1) :- !,
t_tidy(P1, Q1).
t_tidy((P1,true), Q1) :- !,
t_tidy(P1, Q1).
t_tidy((P1,P2), (Q1,Q2)) :- !,
t_tidy(P1, Q1),
t_tidy(P2, Q2).
t_tidy(A, A).
/** @pred `C`( _S1_, _T_, _S2_)
This predicate is used by the grammar rules compiler and is defined as
`C`([H|T],H,T)`.
*/
'C'([X|S],X,S).
prolog:'C'([X|S],X,S).
/** @pred phrase(+ _P_, _L_)
@ -213,10 +209,8 @@ same as `phrase(P,L,[])`.
Both this predicate and the previous are used as a convenient way to
start execution of grammar rules.
*/
phrase(PhraseDef, WordList) :-
prolog:phrase(PhraseDef, WordList) :-
phrase(PhraseDef, WordList, []).
/** @pred phrase(+ _P_, _L_, _R_)
@ -224,45 +218,47 @@ phrase(PhraseDef, WordList) :-
This predicate succeeds when the difference list ` _L_- _R_`
is a phrase of type _P_.
*/
phrase(P, S0, S) :-
prolog:phrase(P, S0, S) :-
call(P, S0, S).
!(S, S).
prolog:!(S, S).
[](S, S).
prolog:[](S, S).
[](H, T, S0, S) :- lists:append([H|T], S, S0).
prolog:[](H, T, S0, S) :- lists:append([H|T], S, S0).
'.'(H,T, S0, S) :-
prolog:'.'(H,T, S0, S) :-
lists:append([H|T], S, S0).
{}(Goal, S0, S) :-
prolog:{}(Goal, S0, S) :-
Goal,
S0 = S.
','(A,B, S0, S) :-
'$t_body'((A,B), _, last, S0, S, Goal),
prolog:','(A,B, S0, S) :-
t_body((A,B), _, last, S0, S, Goal),
'$execute'(Goal).
;(A,B, S0, S) :-
'$t_body'((A;B), _, last, S0, S, Goal),
prolog:;(A,B, S0, S) :-
t_body((A;B), _, last, S0, S, Goal),
'$execute'(Goal).
'|'(A,B, S0, S) :-
'$t_body'((A|B), _, last, S0, S, Goal),
prolog:'|'(A,B, S0, S) :-
t_body((A|B), _, last, S0, S, Goal),
'$execute'(Goal).
->(A,B, S0, S) :-
'$t_body'((A->B), _, last, S0, S, Goal),
prolog:->(A,B, S0, S) :-
t_body((A->B), _, last, S0, S, Goal),
'$execute'(Goal).
\+(A, S0, S) :-
'$t_body'(\+ A, _, last, S0, S, Goal),
prolog:\+(A, S0, S) :-
t_body(\+ A, _, last, S0, S, Goal),
'$execute'(Goal).
% stolen from SWI-Prolog
/**
@}
*/

4
pl/init.yap
View File

@ -118,10 +118,10 @@ otherwise.
:- bootstrap('os.yap').
:- bootstrap('absf.yap').
:- [ 'utils.yap',
:- [ 'directives.yap',
'utils.yap',
'control.yap',
'arith.yap',
'directives.yap',
'flags.yap'
].

10
pl/load_foreign.yap
View File

@ -61,15 +61,15 @@ load_foreign_files(Objs,Libs,Entry) :-
'$check_objs_for_load_foreign_files'(Objs,NewObjs,load_foreign_files(Objs,Libs,Entry)),
'$check_libs_for_load_foreign_files'(Libs,NewLibs,load_foreign_files(Objs,Libs,Entry)),
'$check_entry_for_load_foreign_files'(Entry,load_foreign_files(Objs,Libs,Entry)),
'$current_module'( M ),
'$load_foreign_files'(NewObjs,NewLibs,Entry),
ignore( recordzifnot( '$foreign', M:'$foreign'(Objs,Libs,Entry), _) ),
(
prolog_load_context(file, F),
prolog_load_context(module, M)
prolog_load_context(file, F)
->
ignore( recordzifnot( '$load_foreign_done', [F, M], _) )
;
true
ignore( recordzifnot( '$load_foreign_done', [F, M], _) )
;
true
), !.
'$check_objs_for_load_foreign_files'(V,_,G) :- var(V), !,

4
pl/messages.yap
View File

@ -97,8 +97,8 @@ generate_message('$abort') --> !,
generate_message(abort(user)) --> !,
['YAP execution aborted'].
generate_message(loading(_,F)) --> F == user, !.
generate_message(loading(What,AbsoluteFileName)) --> !,
[ '~a ~a...' - [What, AbsoluteFileName] ].
generate_message(loading(What,FileName)) --> !,
[ '~a ~w...' - [What, FileName] ].
generate_message(loaded(_,user,_,_,_)) --> !.
generate_message(loaded(included,AbsoluteFileName,Mod,Time,Space)) --> !,
[ '~a included in module ~a, ~d msec ~d bytes' - [AbsoluteFileName,Mod,Time,Space] ].

3
pl/modules.yap
View File

@ -705,8 +705,10 @@ expand_goal(G, G).
'$do_expand'(G, _, _, _, G) :- var(G), !.
'$do_expand'(M:G, _CurMod, SM, HVars, M:GI) :- !,
nonvar(M),
'$do_expand'(G, M, SM, HVars, GI).
'$do_expand'(G, CurMod, _SM, _HVars, GI) :-
nonvar(G),
(
'$pred_exists'(goal_expansion(G,GI), CurMod),
call(CurMod:goal_expansion(G, GI))
@ -1567,7 +1569,6 @@ unload_module(Mod) :-
op(X, 0, Mod:Op),
fail.
unload_module(Mod) :-
fail,
current_predicate(Mod:P),
abolish(P),
fail.

188
pl/qly.yap
View File

@ -387,46 +387,54 @@ save_program(File, _Goal) :-
call(db_import(myddas,Table,Table)),
fail.
'$myddas_import_all'.
qsave_file(F0) :-
ensure_loaded( F0 ),
absolute_file_name( F0, File, [expand(true),file_type(prolog),access(read),file_errors(fail),solutions(first)]),
absolute_file_name( F0, State, [expand(true),file_type(qly)]),
'$qsave_file_'(File, State).
/** @pred qsave_file(+ _File_, +_State_)
Saves an image of all the information compiled by the system from file _F_ to _State_.
This includes modules and predicatees eventually including multi-predicates.
This includes modules and predicates eventually including multi-predicates.
**/
qsave_file(F0, State) :-
absolute_file_name( F0, File, [expand(true),file_type(qly)]),
ensure_loaded( F0 ),
absolute_file_name( F0, File, [expand(true),file_type(prolog),access(read),file_errors(fail),solutions(first)]),
'$qsave_file_'(File, State).
'$qsave_file_'(File, _State) :-
'$recorded'('$directive','$d'( File, M:G, Mode, VL, Pos ), _),
assert(prolog:'$file_property'( directive( M:G, Mode, VL, Pos ) ) ),
'$set_owner_file'(prolog:'$file_property'( _ ), File ),
'$qsave_file_'(File, UserF, _State) :-
( File == user_input -> Age = 0 ; time_file64(File, Age) ),
assert(user:'$file_property'( '$lf_loaded'( UserF, Age, M) ) ),
'$set_owner_file'( '$file_property'( _ ), user, File ),
fail.
'$qsave_file_'(File, _State) :-
recorded('$module', '$module'(F,Mod,Source,Exps,L), _),
'$fetch_parents_module'(Mod, Parents),
'$fetch_imports_module'(Mod, Imps),
assert(prolog:'$file_property'( module( Mod, Exps, L, Parents, Imps ) ) ),
'$set_owner_file'(prolog:'$file_property'( _ ), File ),
'$qsave_file_'(File, UserF, State) :-
recorded('$lf_loaded','$lf_loaded'( File, M, Reconsult, UserFile, OldF, Line, Opts), _),
assert(user:'$file_property'( '$lf_loaded'( UserF, M, Reconsult, UserFile, OldF, Line, Opts) ) ),
'$set_owner_file'( '$file_property'( _ ), user, File ),
fail.
'$qsave_file_'(File, _State) :-
'$qsave_file_'(File, _UserF, _State) :-
recorded('$directive',directive( File, M:G, Mode, VL, Pos ), _),
assert(user:'$file_property'( directive( M:G, Mode, VL, Pos ) ) ),
'$set_owner_file'('$file_property'( _ ), user, File ),
fail.
'$qsave_file_'(File, _UserF, _State) :-
'$fetch_multi_files_file'(File, MultiFiles),
assert(prolog:'$file_property'( multifile(MultiFiles ) ) ),
'$set_owner_file'(prolog:'$file_property'( _ ), File ),
assert(user:'$file_property'( multifile(MultiFiles ) ) ),
'$set_owner_file'('$file_property'( _ ), user, File ),
fail.
'$qsave_file_'( File, State ) :-
'$qsave_file_'( File, _UserF, State ) :-
(
is_stream( State )
->
stream_property(Stream, file_name(File)),
S = Stream,
'$qsave_file_preds'(S, File)
'$qsave_file_preds'(State, File)
;
absolute_file_name( F0, File, [expand(true),file_type(qly)]),
open(State, write, S, [type(binary)]),
'$qsave_file_preds'(S, File),
close(S)
), abolish(prolog:'$file_property'/2).
),
abolish(user:'$file_property'/1).
'$fetch_multi_files_file'(File, Multi_Files) :-
setof(Info, '$fetch_multi_file_module'(File, Info), Multi_Files).
@ -443,7 +451,7 @@ Saves an image of all the information compiled by the systemm on module _F_ to _
**/
qsave_module(Mod, OF) :-
recorded('$module', '$module'(F,Mod,S,Exps,L), _),
recorded('$module', '$module'(F,Mod,Source,Exps,L), _),
'$fetch_parents_module'(Mod, Parents),
'$fetch_imports_module'(Mod, Imps),
'$fetch_multi_files_module'(Mod, MFs),
@ -451,11 +459,11 @@ qsave_module(Mod, OF) :-
'$fetch_module_transparents_module'(Mod, ModTransps),
'$fetch_term_expansions_module'(Mod, TEs),
'$fetch_foreigns_module'(Mod, Foreigns),
asserta(Mod:'@mod_info'(S, Exps, MFs, L, Parents, Imps, Metas, ModTransps, Foreigns, TEs)),
asserta(Mod:'@mod_info'(Source, Exps, MFs, L, Parents, Imps, Metas, ModTransps, Foreigns, TEs)),
open(OF, write, S, [type(binary)]),
'$qsave_module_preds'(S, Mod),
close(S),
abolish(Mod:'@mod_info'/8),
abolish(Mod:'@mod_info'/10),
fail.
qsave_module(_, _).
@ -512,20 +520,34 @@ qload_module(Mod) :-
'$current_module'(_, SourceModule),
working_directory(_, OldD).
'$qload_module'(Mod, File, _SourceModule) :-
unload_module( Mod ),
fail.
'$qload_module'(Mod, File, _SourceModule) :-
open(File, read, S, [type(binary)]),
'$qload_module_preds'(S),
close(S),
fail.
'$qload_module'(Mod, S, SourceModule) :-
is_stream( S ), !,
'$q_header'( S, Type ),
stream_property( S, file_name( File )),
( Type == module ->
'$qload_module'(S , Mod, File, SourceModule)
;
Type == file ->
'$qload_file'(S, File)
).
'$qload_module'(Mod, File, SourceModule) :-
'$complete_read_module'(Mod, File, SourceModule).
open(File, read, S, [type(binary)]),
'$q_header'( S, Type ),
( Type == module ->
'$qload_module'(S , Mod, File, SourceModule)
;
Type == file ->
'$qload_file'(S, File)
),
close(S).
'$complete_read_module'(Mod, File, CurrentModule) :-
'$qload_module'(_S, Mod, _File, _SourceModule) :-
unload_module( Mod ), fail.
'$qload_module'(S, _Mod, _File, _SourceModule) :-
'$qload_module_preds'(S), fail.
'$qload_module'(_S, Mod, File, SourceModule) :-
Mod:'@mod_info'(F, Exps, MFs, Line,Parents, Imps, Metas, ModTransps, Foreigns, TEs),
abolish(Mod:'@mod_info'/9),
abolish(Mod:'@mod_info'/10),
recorda('$module', '$module'(File, Mod, F, Exps, Line), _),
'$install_parents_module'(Mod, Parents),
'$install_imports_module'(Mod, Imps, []),
@ -536,8 +558,8 @@ qload_module(Mod) :-
'$install_term_expansions_module'(Mod, TEs),
% last, export everything to the host: if the loading crashed you didn't actually do
% no evil.
'$convert_for_export'(all, Exps, Mod, CurrentModule, TranslationTab, AllExports0, qload_module),
'$add_to_imports'(TranslationTab, Mod, CurrentModule), % insert ops, at least for now
'$convert_for_export'(all, Exps, Mod, SourceModule, TranslationTab, AllExports0, qload_module),
'$add_to_imports'(TranslationTab, Mod, SourceModule), % insert ops, at least for now
sort( AllExports0, AllExports ).
'$fetch_imports_module'(Mod, Imports) :-
@ -551,7 +573,7 @@ qload_module(Mod) :-
'$fetch_parents_module'(Mod, Parents) :-
findall(Parent, prolog:'$parent_module'(Mod,Parent), Parents).
'$fetch_module_transparents_module'(Mod, Module_Transparents) :-
'$fetch_module_transparents_module'(Mod, Mmodule_Transparents) :-
findall(Info, '$fetch_module_transparent_module'(Mod, Info), Module_Transparents).
% detect an module_transparenterator that is local to the module.
@ -571,9 +593,12 @@ qload_module(Mod) :-
% detect an multi_file that is local to the module.
'$fetch_multi_file_module'(Mod, '$defined'(FileName,Name,Arity,Mod)) :-
recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), _).
'$fetch_multi_file_module'(Mod, '$mf_clause'(FileName,_Name,_Arity,_Module,Clause), _) :-
recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef), _),
instance(R, Clause ).
'$fetch_term_expansions_module'(Mod, Term_Expansions) :-
findall(Info, '$fetch_term_expansion_module'(Mod, Info), Term_Expansions).
'$fetch_term_expansions_module'(Mod, TEs) :-
findall(Info, '$fetch_term_expansion_module'(Mod, Info), TEs).
% detect an term_expansionerator that is local to the module.
'$fetch_term_expansion_module'(Mod, ( user:term_expansion(G, GI) :- Bd )) :-
@ -673,41 +698,78 @@ qload_module(Mod) :-
Restores a previously saved state of YAP contaianing a qly file _F_.
*/
qload_file(F0) :-
H0 is heapused, '$cputime'(T0,_),
( is_strean( F0 )
qload_file( F0 ) :-
( '$swi_current_prolog_flag'(verbose_load, false)
->
Verbosity = silent
;
Verbosity = informational
),
StartMsg = loading_module,
'$current_module'( SourceModule ),
H0 is heapused,
'$cputime'(T0,_),
( is_stream( F0 )
->
stream_property(F0, file_name(File) ),
S = F0
File = FilePl,
S = File
;
absolute_file_name( F0, File, [expand(true),file_type(qly)]),
absolute_file_name( F0, FilePl, [expand(true),file_type(prolog)]),
unload_file( FilePl ),
open(File, read, S, [type(binary)])
),
'$qload_file_preds'(S, File),
close(S),
fail
;
'$complete_read_file'(File).
'$complete_read_file'(File) :-
print_message(Verbosity, loading(StartMsg, File)),
file_directory_name(File, DirName),
working_directory(OldD, Dir),
'$process_directives'( File ),
working_directory(OldD, DirName),
'$q_header'( S, Type ),
( Type == module ->
'$qload_module'(S , Mod, File, SourceModule)
;
Type == file ->
'$qload_file'(S, SourceModule, File, FilePl, F0, all)
),
close(S),
working_directory( _, OldD),
H is heapused-H0, '$cputime'(TF,_), T is TF-T0,
'$current_module'(Mod, SourceModule),
fail.
'$current_module'(Mod, Mod ),
print_message(Verbosity, loaded(EndMsg, File, Mod, T, H)),
'$exec_initialisation_goals'.
'$process_directives' :-
prolog:'$file_property'( multifile( List ) ),
'$qload_file'(S, SourceModule, F, FilePl, _F0, _ImportList) :-
recorded('$lf_loaded','$lf_loaded'( F, _Age, SourceModule), _),
!.
'$qload_file'(S, _SourceModule, _File, _FilePl, _F0, _ImportList) :-
'$qload_file_preds'(S),
fail.
'$qload_file'(S, SourceModule, F, FilePl, _F0, _ImportList) :-
user:'$file_property'( '$lf_loaded'( _, Age, _ ) ),
recordaifnot('$lf_loaded','$lf_loaded'( F, Age, SourceModule), _),
fail.
'$qload_file'(_S, SourceModule, _File, FilePl, F0, _ImportList) :-
b_setval('$source_file', F0 ),
'$process_directives'( FilePl ),
fail.
'$qload_file'(_S, SourceModule, _File, FilePl, _F0, ImportList) :-
'$import_to_current_module'(FilePl, SourceModule, ImportList, _, _TOpts).
'$process_directives'( FilePl ) :-
user:'$file_property'( '$lf_loaded'( FilePl, M, Reconsult, UserFile, OldF, Line, Opts) ),
recorda('$lf_loaded','$lf_loaded'( FilePl, M, Reconsult, UserFile, OldF, Line, Opts), _),
fail.
'$process_directives'( _FilePl ) :-
user:'$file_property'( multifile( List ) ),
lists:member( Clause, List ),
assert( Clause ),
fail.
'$process_directives' :-
prolog:'$file_property'( directive( M:G, Mode, VL, Pos ) ),
'$exec_directive'(G, Mode, M, VL, Pos),
'$process_directives'( FilePl ) :-
user:'$file_property'( directive( MG, Mode, VL, Pos ) ),
'$set_source'( FilePl, Pos ),
strip_module(MG, M, G),
'$process_directive'(G, reconsult, M, VL, Pos),
fail.
'$process_directives' :-
abolish(prolog:'$file_property'/1).
'$process_directives'( _FilePl ) :-
abolish(user:'$file_property'/1).