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

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

Browse Source
This commit is contained in:
João Santos
2012-02-27 17:22:37 +00:00
parent 553fbc505f 04ef859158
commit 430147f310
99 changed files with 8038 additions and 1749 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
BEAM/eam_am.c
View File

@@ -140,7 +140,7 @@ int showTime(void);
struct AND_BOX *choose_leftmost(void);
extern Cell BEAM_is(void);
extern void do_eam_indexing(struct Predicates *);
extern void Yap_plwrite(Term, int (*mywrite) (int, int), int, int);
extern void Yap_plwrite(Term, void *, int, int);
#if Debug_Dump_State
void dump_eam_state(void);
@@ -2511,7 +2511,7 @@ break_debug(contador);
#endif
#ifdef DEBUG
Yap_plwrite ((Term) beam_X[1], Yap_DebugPutc, 0, 1200);
Yap_plwrite ((Term) beam_X[1], NULL, 0, 1200);
#else
extern int beam_write (void);
beam_write();

4
BEAM/toeam.c
View File

@@ -742,10 +742,10 @@ void ShowCode_new2(int op, int new1,CELL new4)
switch (ch = *f++)
{
case '1':
Yap_plwrite(MkIntTerm(new1), Yap_DebugPutc, 0, 1200);
Yap_plwrite(MkIntTerm(new1), NULL, 30, 0, 1200);
break;
case '4':
Yap_plwrite(MkIntTerm(new4), Yap_DebugPutc, 0, 1200);
Yap_plwrite(MkIntTerm(new4), NULL, 20, 0, 1200);
break;
default:
Yap_DebugPutc (LOCAL_c_error_stream,'%');

4
C/absmi.c
View File

@@ -9151,7 +9151,7 @@ Yap_absmi(int inp)
BEGP(pt0);
deref_body(d0, pt0, plus_vc_unk, plus_vc_nvar);
saveregs();
Yap_NilError(INSTANTIATION_ERROR, "X is A+ " Int_FORMAT, PREG->u.xxn.c);
Yap_NilError(INSTANTIATION_ERROR, "X is A + " Int_FORMAT, PREG->u.xxn.c);
setregs();
FAIL();
ENDP(pt0);
@@ -9243,7 +9243,7 @@ Yap_absmi(int inp)
BEGP(pt0);
deref_body(d0, pt0, plus_y_vc_unk, plus_y_vc_nvar);
saveregs();
Yap_NilError(INSTANTIATION_ERROR, "X is A+ " Int_FORMAT, PREG->u.yxn.c);
Yap_NilError(INSTANTIATION_ERROR, "X is A + " Int_FORMAT, PREG->u.yxn.c);
setregs();
FAIL();
ENDP(pt0);

8
C/c_interface.c
View File

@@ -2704,11 +2704,11 @@ YAP_TermToStream(Term t)
{
CACHE_REGS
IOSTREAM *s;
int rc;
extern int PL_get_stream_handle(Int t, IOSTREAM **s);
BACKUP_MACHINE_REGS();
if ( (rc=PL_get_stream_handle(Yap_InitSlot(t PASS_REGS), &s)) ) {
if (IsVarTerm(t) || !IsAtomTerm(t))
return NULL;
if ( (s=Yap_GetStreamHandle(AtomOfTerm(t))) ) {
RECOVER_MACHINE_REGS();
return s;
}
@@ -2761,7 +2761,7 @@ YAP_Write(Term t, IOSTREAM *stream, int flags)
{
BACKUP_MACHINE_REGS();
Yap_dowrite (t, stream, flags, 1200);
Yap_plwrite (t, stream, 0, flags, 1200);
RECOVER_MACHINE_REGS();
}

2
C/heapgc.c
View File

@@ -4136,7 +4136,7 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop USES_REGS)
}
/*
* debug for(save_total=1; save_total<=N; ++save_total)
* plwrite(XREGS[save_total],Yap_DebugPutc,0);
* plwrite(XREGS[save_total],NULL,30,0,0);
*/
return TRUE;
}

127
C/index.c
View File

@@ -496,6 +496,12 @@ static char SccsId[] = "%W% %G%";
#include "cut_c.h"
#endif
#if defined(YAPOR) || defined(THREADS)
#define SET_JLBL(X) jlbl = &(ipc->u.X)
#else
#define SET_JLBL(X)
#endif
UInt STATIC_PROTO(do_index, (ClauseDef *,ClauseDef *,struct intermediates *,UInt,UInt,int,int,CELL *));
UInt STATIC_PROTO(do_compound_index, (ClauseDef *,ClauseDef *,Term *t,struct intermediates *,UInt,UInt,UInt,UInt,int,int,int,CELL *,int));
UInt STATIC_PROTO(do_dbref_index, (ClauseDef *,ClauseDef *,Term,struct intermediates *,UInt,UInt,int,int,CELL *));
@@ -3029,10 +3035,7 @@ reinstall_clauses(ClauseDef *cls, ClauseDef *end, PredEntry *ap, istack_entry *s
static istack_entry *
install_log_upd_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack)
{
int last_arg = TRUE;
istack_entry *sp = stack;
last_arg = TRUE;
while (sp->pos) {
if ((Int)(sp->pos) > 0) {
add_head_info(cls, sp->pos);
@@ -3067,20 +3070,8 @@ install_log_upd_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack)
move_next(cls, sp->pos);
} else if (sp->pos) {
UInt argno = -sp->pos;
UInt arity;
skip_to_arg(cls, ap, argno, FALSE);
if (IsPairTerm(sp[-1].val))
arity = 2;
else {
Functor f = (Functor)RepAppl(sp[-1].val);
if (IsExtensionFunctor(f))
arity = 0;
else
arity = ArityOfFunctor((Functor)f);
}
if (arity != argno+1) {
last_arg = FALSE;
}
}
}
sp++;
@@ -3331,7 +3322,6 @@ expand_index(struct intermediates *cint) {
UInt arity = 0;
UInt lab, fail_l, clleft, i = 0;
int is_lu = ap->PredFlags & LogUpdatePredFlag;
yamop *eblk = NULL;
yamop *e_code = (yamop *)&(ap->cs.p_code.ExpandCode);
ipc = ap->cs.p_code.TrueCodeOfPred;
@@ -3479,6 +3469,7 @@ expand_index(struct intermediates *cint) {
labp = &(ipc->u.xll.l1);
ipc = ipc->u.xll.l1;
parentcl = index_jmp(parentcl, parentcl, ipc, is_lu, e_code);
} else {
ipc = NEXTOP(ipc,xll);
}
@@ -3744,7 +3735,7 @@ expand_index(struct intermediates *cint) {
COUNT nclauses = ipc->u.sssllp.s1;
yamop **clp = (yamop **)NEXTOP(ipc,sssllp);
eblk = cint->expand_block = ipc;
cint->expand_block = ipc;
#if USE_SYSTEM_MALLOC
if (!cint->cls) {
cint->cls = (ClauseDef *)Yap_AllocCodeSpace(nclauses*sizeof(ClauseDef));
@@ -3906,7 +3897,7 @@ ExpandIndex(PredEntry *ap, int ExtraArgs, yamop *nextop USES_REGS) {
StaticIndex *cl;
cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
Yap_kill_iblock((ClauseUnion *)ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred),NULL, ap);
Yap_kill_iblock((ClauseUnion *)cl,NULL, ap);
}
#if defined(YAPOR) || defined(THREADS)
if (ap->PredFlags & LogUpdatePredFlag &&
@@ -4954,7 +4945,6 @@ add_to_index(struct intermediates *cint, int first, path_stack_entry *sp, Clause
int group1 = TRUE;
yamop *alt = NULL;
UInt current_arity = 0;
int last_arg = TRUE;
LogUpdIndex *icl = NULL;
sp = init_block_stack(sp, ipc, ap);
@@ -5214,9 +5204,6 @@ add_to_index(struct intermediates *cint, int first, path_stack_entry *sp, Clause
yamop *nipc = ipc->u.sllll.l1;
current_arity = 2;
skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity);
if (current_arity != ipc->u.sllll.s+1) {
last_arg = FALSE;
}
if (nipc == FAILCODE) {
/* jump straight to clause */
if (ap->PredFlags & LogUpdatePredFlag) {
@@ -5233,9 +5220,6 @@ add_to_index(struct intermediates *cint, int first, path_stack_entry *sp, Clause
} else if (IsAtomOrIntTerm(cls->Tag)) {
yamop *nipc = ipc->u.sllll.l2;
skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity);
if (current_arity != ipc->u.sllll.s+1) {
last_arg = FALSE;
}
if (nipc == FAILCODE) {
/* need to expand the block */
sp = kill_block(sp, ap);
@@ -5247,9 +5231,6 @@ add_to_index(struct intermediates *cint, int first, path_stack_entry *sp, Clause
} else if (IsApplTerm(cls->Tag)) {
yamop *nipc = ipc->u.sllll.l3;
skip_to_arg(cls, ap, ipc->u.sllll.s, current_arity);
if (current_arity != ipc->u.sllll.s+1) {
last_arg = FALSE;
}
if (nipc == FAILCODE) {
/* need to expand the block */
sp = kill_block(sp, ap);
@@ -5508,7 +5489,6 @@ static void
remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg, yamop *lt, struct intermediates *cint) {
/* last clause to experiment with */
yamop *ipc = ap->cs.p_code.TrueCodeOfPred;
UInt current_arity = 0;
if (ap->cs.p_code.NOfClauses == 1) {
if (ap->PredFlags & IndexedPredFlag) {
@@ -5639,7 +5619,6 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
}
if (IsPairTerm(cls->Tag)) {
yamop *nipc = ipc->u.llll.l1;
current_arity = 2;
if (IN_BETWEEN(bg,nipc,lt)) {
/* jump straight to clause */
ipc->u.llll.l1 = FAILCODE;
@@ -5683,7 +5662,6 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
break;
case _switch_on_arg_type:
sp = push_path(sp, &(ipc->u.xllll.l4), cls, cint);
current_arity = 2;
if (ap->PredFlags & LogUpdatePredFlag) {
add_head_info(cls, Yap_regtoregno(ipc->u.xllll.x));
} else {
@@ -5730,7 +5708,6 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
break;
case _switch_on_sub_arg_type:
sp = push_path(sp, &(ipc->u.sllll.l4), cls, cint);
current_arity = 2;
add_arg_info(cls, ap, ipc->u.sllll.s+1);
if (IsPairTerm(cls->Tag)) {
yamop *nipc = ipc->u.sllll.l1;
@@ -5788,9 +5765,6 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
} else {
fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s);
}
if (!IsExtensionFunctor(f)) {
current_arity = ArityOfFunctor(f);
}
newpc = fe->u.labp;
if (newpc == (yamop *)&(ap->cs.p_code.ExpandCode)) {
@@ -6046,9 +6020,10 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
CELL *s_reg = NULL;
Term t = TermNil;
int blob_term = FALSE;
yamop *start_pc = ipc;
choiceptr b0 = NULL;
#if defined(YAPOR) || defined(THREADS)
yamop **jlbl = NULL;
#endif
int lu_pred = ap->PredFlags & LogUpdatePredFlag;
int unbounded = TRUE;
@@ -6340,7 +6315,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
{
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
jlbl = &(ipc->u.l.l);
SET_JLBL(l.l);
ipc = ipc->u.l.l;
} else {
ipc = NEXTOP(ipc,l);
@@ -6351,7 +6326,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
{
Term t = Deref(XREGS[arg_from_x(ipc->u.xll.x)]);
if (!IsVarTerm(t)) {
jlbl = &(ipc->u.xll.l1);
SET_JLBL(xll.l1);
ipc = ipc->u.xll.l1;
} else {
ipc = NEXTOP(ipc,xll);
@@ -6366,18 +6341,18 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
t = Deref(ARG1);
blob_term = FALSE;
if (IsVarTerm(t)) {
jlbl = &(ipc->u.llll.l4);
SET_JLBL(llll.l4);
ipc = ipc->u.llll.l4;
} else if (IsPairTerm(t)) {
unbounded = FALSE;
jlbl = &(ipc->u.llll.l1);
SET_JLBL(llll.l1);
ipc = ipc->u.llll.l1;
S = s_reg = RepPair(t);
} else if (IsAtomOrIntTerm(t)) {
jlbl = &(ipc->u.llll.l2);
SET_JLBL(llll.l2);
ipc = ipc->u.llll.l2;
} else {
jlbl = &(ipc->u.llll.l3);
SET_JLBL(llll.l3);
ipc = ipc->u.llll.l3;
S = RepAppl(t);
}
@@ -6386,19 +6361,19 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
t = Deref(ARG1);
blob_term = FALSE;
if (IsVarTerm(t)) {
jlbl = &(ipc->u.ollll.l4);
SET_JLBL(ollll.l4);
ipc = ipc->u.ollll.l4;
} else if (IsPairTerm(t)) {
unbounded = FALSE;
jlbl = &(ipc->u.ollll.l1);
SET_JLBL(ollll.l1);
ipc = ipc->u.ollll.l1;
S = s_reg = RepPair(t);
} else if (t == TermNil) {
unbounded = FALSE;
jlbl = &(ipc->u.ollll.l2);
SET_JLBL(ollll.l2);
ipc = ipc->u.ollll.l2;
} else {
jlbl = &(ipc->u.ollll.l3);
SET_JLBL(ollll.l3);
ipc = ipc->u.ollll.l3;
S = RepAppl(t);
}
@@ -6407,18 +6382,18 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
t = Deref(XREGS[arg_from_x(ipc->u.xllll.x)]);
blob_term = FALSE;
if (IsVarTerm(t)) {
jlbl = &(ipc->u.xllll.l4);
SET_JLBL(xllll.l4);
ipc = ipc->u.xllll.l4;
} else if (IsPairTerm(t)) {
unbounded = FALSE;
jlbl = &(ipc->u.xllll.l1);
SET_JLBL(xllll.l1);
ipc = ipc->u.xllll.l1;
S = s_reg = RepPair(t);
} else if (IsAtomOrIntTerm(t)) {
jlbl = &(ipc->u.xllll.l1);
SET_JLBL(xllll.l2);
ipc = ipc->u.xllll.l2;
} else {
jlbl = &(ipc->u.xllll.l3);
SET_JLBL(xllll.l3);
ipc = ipc->u.xllll.l3;
S = RepAppl(t);
}
@@ -6427,18 +6402,17 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
t = Deref(s_reg[ipc->u.sllll.s]);
blob_term = FALSE;
if (IsVarTerm(t)) {
jlbl = &(ipc->u.sllll.l4);
SET_JLBL(sllll.l4);
ipc = ipc->u.sllll.l4;
} else if (IsPairTerm(t)) {
unbounded = FALSE;
jlbl = &(ipc->u.sllll.l1);
ipc = ipc->u.sllll.l1;
SET_JLBL(sllll.l1);
S = s_reg = RepPair(t);
} else if (IsAtomOrIntTerm(t)) {
jlbl = &(ipc->u.sllll.l2);
SET_JLBL(sllll.l2);
ipc = ipc->u.sllll.l2;
} else {
jlbl = &(ipc->u.sllll.l3);
SET_JLBL(sllll.l3);
ipc = ipc->u.sllll.l3;
S = RepAppl(t);
}
@@ -6447,13 +6421,13 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
t = Deref(ARG1);
blob_term = FALSE;
if (IsVarTerm(t)) {
jlbl = &(ipc->u.clll.l3);
SET_JLBL(clll.l3);
ipc = ipc->u.clll.l3;
} else if (!IsVarTerm(t) && t != ipc->u.clll.c) {
jlbl = &(ipc->u.clll.l1);
SET_JLBL(clll.l1);
ipc = ipc->u.clll.l1;
} else {
jlbl = &(ipc->u.clll.l2);
SET_JLBL(clll.l2);
ipc = ipc->u.clll.l2;
}
break;
@@ -6475,7 +6449,9 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
} else {
fe = lookup_f(f, ipc->u.sssl.l, ipc->u.sssl.s);
}
#if defined(YAPOR) || defined(THREADS)
jlbl = &(fe->u.labp);
#endif
ipc = fe->u.labp;
}
break;
@@ -6506,7 +6482,9 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
} else {
ae = lookup_c(t, ipc->u.sssl.l, ipc->u.sssl.s);
}
#if defined(YAPOR) || defined(THREADS)
jlbl = &(ae->u.labp);
#endif
ipc = ae->u.labp;
}
break;
@@ -6568,7 +6546,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
XREGS[ap->ArityOfPE+4] = Terms[1];
XREGS[ap->ArityOfPE+5] = Terms[2];
Yap_IPred(ap, 5, cp_pc);
start_pc = ipc = ap->cs.p_code.TrueCodeOfPred;
ipc = ap->cs.p_code.TrueCodeOfPred;
if (!blob_term) { /* protect garbage collector */
s_reg = (CELL *)XREGS[ap->ArityOfPE+1];
t = XREGS[ap->ArityOfPE+2];
@@ -6641,16 +6619,22 @@ Yap_NthClause(PredEntry *ap, Int ncls)
yamop
*ipc = ap->cs.p_code.TrueCodeOfPred,
*alt = NULL;
#if defined(YAPOR) || defined(THREADS)
yamop **jlbl = NULL;
#endif
/* search every clause */
if (ncls > ap->cs.p_code.NOfClauses)
return NULL;
else if (ncls == 1)
return to_clause(ap->cs.p_code.FirstClause,ap);
else if (ncls == ap->cs.p_code.NOfClauses)
else if (ap->PredFlags & MegaClausePredFlag) {
MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
/* fast access to nth element, all have same size */
return (LogUpdClause *)((char *)mcl->ClCode+(ncls-1)*mcl->ClItemSize);
} else if (ncls == ap->cs.p_code.NOfClauses) {
return to_clause(ap->cs.p_code.LastClause,ap);
else if (ncls < 0)
} else if (ncls < 0)
return NULL;
if (ap->ModuleOfPred != IDB_MODULE) {
@@ -6766,44 +6750,46 @@ Yap_NthClause(PredEntry *ap, Int ncls)
}
return NULL;
case _enter_lu_pred:
SET_JLBL(Illss.l1);
ipc = ipc->u.Illss.l1;
break;
case _lock_lu:
ipc = NEXTOP(ipc,p);
break;
case _jump:
jlbl = &(ipc->u.l.l);
SET_JLBL(l.l);
ipc = ipc->u.l.l;
break;
case _jump_if_var:
jlbl = &(ipc->u.l.l);
SET_JLBL(l.l);
ipc = ipc->u.l.l;
break;
case _jump_if_nonvar:
ipc = NEXTOP(ipc,xll);
break;
case _user_switch:
SET_JLBL(l.l);
ipc = ipc->u.lp.l;
break;
/* instructions type e */
case _switch_on_type:
jlbl = &(ipc->u.llll.l4);
SET_JLBL(llll.l4);
ipc = ipc->u.llll.l4;
break;
case _switch_list_nl:
jlbl = &(ipc->u.ollll.l4);
SET_JLBL(ollll.l4);
ipc = ipc->u.ollll.l4;
break;
case _switch_on_arg_type:
jlbl = &(ipc->u.xllll.l4);
SET_JLBL(xllll.l4);
ipc = ipc->u.xllll.l4;
break;
case _switch_on_sub_arg_type:
jlbl = &(ipc->u.sllll.l4);
SET_JLBL(sllll.l4);
ipc = ipc->u.sllll.l4;
break;
case _if_not_then:
jlbl = &(ipc->u.clll.l3);
SET_JLBL(clll.l3);
ipc = ipc->u.clll.l3;
break;
case _expand_index:
@@ -6837,7 +6823,7 @@ void
Yap_CleanUpIndex(LogUpdIndex *blk)
{
/* just compact the code */
yamop *start = blk->ClCode, *codep;
yamop *start = blk->ClCode;
op_numbers op = Yap_op_from_opcode(start->opc);
blk->ClFlags &= ~DirtyMask;
@@ -6849,7 +6835,6 @@ Yap_CleanUpIndex(LogUpdIndex *blk)
start = NEXTOP(start, xll);
op = Yap_op_from_opcode(start->opc);
}
codep = start->u.Illss.l1;
remove_dirty_clauses_from_index(start);
}

1
C/init.c
View File

@@ -307,6 +307,7 @@ static Opdef Ops[] = {
{"#", yfx, 500},
{"rdiv", yfx, 400},
{"div", yfx, 400},
{"xor", yfx, 400},
{"*", yfx, 400},
{"/", yfx, 400},
{"//", yfx, 400},

19
C/iopreds.c
View File

@@ -199,7 +199,7 @@ Yap_DebugPutc(int sno, wchar_t ch)
void
Yap_DebugPlWrite(Term t)
{
Yap_plwrite(t, Yap_DebugPutc, 0, 1200);
Yap_plwrite(t, NULL, 15, 0, 1200);
}
void
@@ -238,7 +238,7 @@ typedef struct stream_ref
int beam_write (void)
{
Yap_StartSlots();
Yap_plwrite (ARG1, Stream[LOCAL_c_output_stream].stream_wputc, 0, 1200);
Yap_plwrite (ARG1, NULL, 0, 0, 1200);
Yap_CloseSlots();
if (EX != 0L) {
Term ball = Yap_PopTermFromDB(EX);
@@ -745,19 +745,24 @@ p_read ( USES_REGS1 )
return do_read(Yap_Scurin(), 7 PASS_REGS);
}
extern int Yap_getInputStream(Int, IOSTREAM **);
static Int
p_read2 ( USES_REGS1 )
{ /* '$read2'(+Flag,?Term,?Module,?Vars,-Pos,-Err,+Stream) */
IOSTREAM *inp_stream;
Int out;
Term t8 = Deref(ARG8);
if (!Yap_getInputStream(Yap_InitSlot(Deref(ARG8) PASS_REGS), &inp_stream)) {
Yap_RecoverSlots(1 PASS_REGS);
if (IsVarTerm(t8)) {
Yap_Error(INSTANTIATION_ERROR,t8,"read_term/3");
return FALSE;
}
if (!IsAtomTerm(t8)) {
Yap_Error(TYPE_ERROR_LIST,t8,"read_term/3");
return(FALSE);
}
if (!(inp_stream = Yap_GetInputStream(AtomOfTerm(t8))) ) {
return(FALSE);
}
Yap_RecoverSlots(1 PASS_REGS);
out = do_read(inp_stream, 8 PASS_REGS);
return out;
}

12
C/parser.c
View File

@@ -580,11 +580,23 @@ ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS)
break;
case '[':
NextToken;
if (LOCAL_tokptr->Tok == Ponctuation_tok &&
(int) LOCAL_tokptr->TokInfo == ']') {
t = TermNil;
NextToken;
break;
}
t = ParseList(FailBuff PASS_REGS);
checkfor((Term) ']', FailBuff PASS_REGS);
break;
case '{':
NextToken;
if (LOCAL_tokptr->Tok == Ponctuation_tok &&
(int) LOCAL_tokptr->TokInfo == '}') {
t = MkAtomTerm(AtomBraces);
NextToken;
break;
}
t = ParseTerm(1200, FailBuff PASS_REGS);
t = Yap_MkApplTerm(FunctorBraces, 1, &t);
/* check for possible overflow against local stack */

42
C/pl-yap.c
View File

@@ -989,21 +989,6 @@ int PL_unify_integer__LD(term_t t, intptr_t i ARG_LD)
return Yap_unify(Yap_GetFromSlot(t PASS_REGS),iterm);
}
extern int Yap_getInputStream(term_t t, IOSTREAM **s);
int Yap_getInputStream(term_t t, IOSTREAM **s)
{
GET_LD
return getInputStream(t, s);
}
extern int Yap_getOutputStream(term_t t, IOSTREAM **s);
int Yap_getOutputStream(term_t t, IOSTREAM **s)
{
GET_LD
return getOutputStream(t, s);
}
#ifdef _WIN32
@@ -1134,7 +1119,6 @@ Yap_StreamPosition(IOSTREAM *st)
}
IOSTREAM *STD_PROTO(Yap_Scurin, (void));
int STD_PROTO(Yap_dowrite, (Term, IOSTREAM *, int, int));
IOSTREAM *
Yap_Scurin(void)
@@ -1143,32 +1127,6 @@ Yap_Scurin(void)
return Scurin;
}
int
Yap_dowrite(Term t, IOSTREAM *stream, int flags, int priority)
/* term to be written */
/* consumer */
/* write options */
{
CACHE_REGS
int swi_flags;
int res;
Int slot = Yap_InitSlot(t PASS_REGS);
swi_flags = 0;
if (flags & Quote_illegal_f)
swi_flags |= PL_WRT_QUOTED;
if (flags & Handle_vars_f)
swi_flags |= PL_WRT_NUMBERVARS;
if (flags & Use_portray_f)
swi_flags |= PL_WRT_PORTRAY;
if (flags & Ignore_ops_f)
swi_flags |= PL_WRT_IGNOREOPS;
res = PL_write_term(stream, slot, priority, swi_flags);
Yap_RecoverSlots(1 PASS_REGS);
return res;
}
int
isWideAtom(atom_t atom)
{

22
C/qlyr.c
View File

@@ -976,8 +976,17 @@ static Int
p_read_module_preds( USES_REGS1 )
{
IOSTREAM *stream;
Term t1 = Deref(ARG1);
if (!Yap_getInputStream(Yap_InitSlot(Deref(ARG1) PASS_REGS), &stream)) {
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR,t1,"read_qly/3");
return FALSE;
}
if (!IsAtomTerm(t1)) {
Yap_Error(TYPE_ERROR_ATOM,t1,"read_qly/3");
return(FALSE);
}
if (!(stream = Yap_GetInputStream(AtomOfTerm(t1))) ) {
return FALSE;
}
read_module(stream);
@@ -989,8 +998,17 @@ p_read_program( USES_REGS1 )
{
IOSTREAM *stream;
void YAP_Reset(void);
Term t1 = Deref(ARG1);
if (!Yap_getInputStream(Yap_InitSlot(Deref(ARG1) PASS_REGS), &stream)) {
if (IsVarTerm(t1)) {
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))) ) {
return FALSE;
}
YAP_Reset();

22
C/qlyw.c
View File

@@ -701,8 +701,17 @@ p_save_module_preds( USES_REGS1 )
{
IOSTREAM *stream;
Term tmod = Deref(ARG2);
Term t1 = Deref(ARG1);
if (!Yap_getOutputStream(Yap_InitSlot(Deref(ARG1) PASS_REGS), &stream)) {
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR,t1,"save_module/3");
return FALSE;
}
if (!IsAtomTerm(t1)) {
Yap_Error(TYPE_ERROR_ATOM,t1,"save_module/3");
return(FALSE);
}
if (!(stream = Yap_GetOutputStream(AtomOfTerm(t1))) ) {
return FALSE;
}
if (IsVarTerm(tmod)) {
@@ -720,8 +729,17 @@ static Int
p_save_program( USES_REGS1 )
{
IOSTREAM *stream;
Term t1 = Deref(ARG1);
if (!Yap_getOutputStream(Yap_InitSlot(Deref(ARG1) PASS_REGS), &stream)) {
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR,t1,"save_program/3");
return FALSE;
}
if (!IsAtomTerm(t1)) {
Yap_Error(TYPE_ERROR_ATOM,t1,"save_program/3");
return(FALSE);
}
if (!(stream = Yap_GetOutputStream(AtomOfTerm(t1))) ) {
return FALSE;
}
return save_program(stream) != 0;

4
C/stdpreds.c
View File

@@ -2550,14 +2550,14 @@ p_atom_number( USES_REGS1 )
if (IsVarTerm(t)) {
char *String; /* alloc temp space on Trail */
char *s;
if (IsVarTerm(t2)) {
Yap_Error(INSTANTIATION_ERROR, t2, "atom_number/2");
return FALSE;
}
String = Yap_PreAllocCodeSpace();
if (String+1024 > (char *)AuxSp) {
s = String = Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE);
String = Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE);
if (String + 1024 > (char *)AuxSp) {
/* crash in flames */
Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "allocating temp space in number_codes/2");

11
C/tracer.c
View File

@@ -26,17 +26,8 @@
#include "clause.h"
#include "tracer.h"
STATIC_PROTO(int TracePutchar, (int, int));
STATIC_PROTO(void send_tracer_message, (char *, char *, Int, char *, CELL *));
static int
TracePutchar(int sno, int ch)
{
return(putc(ch, GLOBAL_stderr)); /* use standard error stream, which is supposed to be 2*/
}
static void
send_tracer_message(char *start, char *name, Int arity, char *mname, CELL *args)
{
@@ -66,7 +57,7 @@ send_tracer_message(char *start, char *name, Int arity, char *mname, CELL *args)
Yap_Portray_delays = TRUE;
#endif
#endif
Yap_plwrite(args[i], TracePutchar, Handle_vars_f, 1200);
Yap_plwrite(args[i], NULL, 15, Handle_vars_f, 1200);
#if DEBUG
#if COROUTINING
Yap_Portray_delays = FALSE;

535
C/write.c
View File

File diff suppressed because it is too large Load Diff

2
H/Yap.h
View File

@@ -87,7 +87,7 @@
#undef USE_THREADED_CODE
#endif /* USE_THREADED_CODE */
#define inline __inline
#define YAP_VERSION "YAP-6.3.1"
#define YAP_VERSION "YAP-6.3.2"
#define BIN_DIR "c:\\Yap\\bin"
#define LIB_DIR "c:\\Yap\\lib\\Yap"
#define SHARE_DIR "c:\\Yap\\share\\Yap"

10
H/Yapproto.h
View File

@@ -257,11 +257,13 @@ int STD_PROTO(Yap_eq,(Term, Term));
/* iopreds.c */
void STD_PROTO(Yap_InitBackIO,(void));
void STD_PROTO(Yap_InitIOPreds,(void));
void *Yap_GetStreamHandle(Atom at);
void *Yap_GetInputStream(Atom at);
void *Yap_GetOutputStream(Atom at);
#ifdef DEBUG
extern void Yap_DebugPlWrite (Term t);
extern void Yap_DebugErrorPutc (int n);
#endif
int STD_PROTO(Yap_LookupSWIStream,(void *));
int STD_PROTO(Yap_readTerm, (void *, Term *, Term *, Term *, Term *));
void STD_PROTO(Yap_PlWriteToStream, (Term, int, int));
/* depth_lim.c */
@@ -406,7 +408,7 @@ Int STD_PROTO(Yap_SkipList,(Term *, Term **));
/* write.c */
void STD_PROTO(Yap_plwrite,(Term,int (*)(int, wchar_t), int, int));
void STD_PROTO(Yap_plwrite,(Term, void *, int, int, int));
/* MYDDAS */
@@ -502,8 +504,4 @@ gc_P(yamop *p, yamop *cp)
return (p->opc == Yap_opcode(_execute_cpred) ? cp : p);
}
#ifdef _PL_STREAM_H
extern int Yap_getInputStream(Int t, IOSTREAM **s);
extern int Yap_getOutputStream(Int t, IOSTREAM **s);
#endif

1
H/iatoms.h
View File

@@ -272,6 +272,7 @@
AtomStaticClause = Yap_FullLookupAtom("$static_clause");
AtomStaticProcedure = Yap_LookupAtom("static_procedure");
AtomStream = Yap_FullLookupAtom("$stream");
AtomSWIStream = Yap_FullLookupAtom("<stream>");
AtomVStream = Yap_LookupAtom("stream");
AtomStreams = Yap_LookupAtom("streams");
AtomStreamOrAlias = Yap_LookupAtom("stream_or_alias");

5
H/pl-yap.h
View File

@@ -31,11 +31,12 @@ typedef YAP_Term (*Func)(term_t); /* foreign functions */
extern const char *Yap_GetCurrentPredName(void);
extern YAP_Int Yap_GetCurrentPredArity(void);
extern int Yap_read_term(term_t t, IOSTREAM *st, term_t *exc, term_t vs);
extern int Yap_LookupSWIStream(void *swi_s);
extern term_t Yap_fetch_module_for_format(term_t args, YAP_Term *modp);
extern IOENC Yap_DefaultEncoding(void);
extern void Yap_SetDefaultEncoding(IOENC);
extern void *Yap_GetStreamHandle(Atom at);
extern atom_t codeToAtom(int chrcode);
#define valTermRef(t) ((Word)YAP_AddressFromSlot(t))
@@ -148,7 +149,7 @@ atomLength(Atom atom)
#define MODULE_user YAP_ModuleUser()
#define _PL_predicate(A,B,C,D) PL_predicate(A,B,C)
#define predicateHasClauses(A) (YAP_NumberOfClausesForPredicate((YAP_PredEntryPtr)A) != 0)
#define lookupModule(A) ((Module)PL_new_module(A))
#define lookupModule(A) Yap_Module(MkAtomTerm(YAP_AtomFromSWIAtom(A)))
#define charEscapeWriteOption(A) FALSE // VSC: to implement
#define wordToTermRef(A) YAP_InitSlot(*(A))
#define isTaggedInt(A) IsIntegerTerm(A)

1
H/ratoms.h
View File

@@ -272,6 +272,7 @@
AtomStaticClause = AtomAdjust(AtomStaticClause);
AtomStaticProcedure = AtomAdjust(AtomStaticProcedure);
AtomStream = AtomAdjust(AtomStream);
AtomSWIStream = AtomAdjust(AtomSWIStream);
AtomVStream = AtomAdjust(AtomVStream);
AtomStreams = AtomAdjust(AtomStreams);
AtomStreamOrAlias = AtomAdjust(AtomStreamOrAlias);

2
H/tatoms.h
View File

@@ -542,6 +542,8 @@
#define AtomStaticProcedure Yap_heap_regs->AtomStaticProcedure_
Atom AtomStream_;
#define AtomStream Yap_heap_regs->AtomStream_
Atom AtomSWIStream_;
#define AtomSWIStream Yap_heap_regs->AtomSWIStream_
Atom AtomVStream_;
#define AtomVStream Yap_heap_regs->AtomVStream_
Atom AtomStreams_;

9
H/yapio.h
View File

@@ -67,7 +67,6 @@
#define YP_FILE FILE
int STD_PROTO(YP_putc,(int, int));
void STD_PROTO(Yap_dowrite, (Term, IOSTREAM *, int, int));
#else
@@ -194,6 +193,8 @@ typedef struct VARSTRUCT {
} VarEntry;
*/
#ifndef _PL_WRITE_
/* Character types for tokenizer and write.c */
#define UC 1 /* Upper case */
@@ -211,6 +212,7 @@ typedef struct VARSTRUCT {
#define EOFCHAR EOF
#endif
/* info on aliases */
typedef struct AliasDescS {
@@ -300,6 +302,11 @@ Atom STD_PROTO(Yap_LookupWideAtom,(wchar_t *));
#define To_heap_f 0x10
#define Unfold_cyclics_f 0x20
#define Use_SWI_Stream_f 0x40
#define BackQuote_String_f 0x80
#define AttVar_None_f 0x100
#define AttVar_Dots_f 0x200
#define AttVar_Portray_f 0x400
#define Blob_Portray_f 0x800

5
LGPL/Makefile.in
View File

@@ -33,6 +33,11 @@ PROGRAMS= $(srcdir)/base64.pl \
$(srcdir)/nb_set.pl \
$(srcdir)/operators.pl \
$(srcdir)/option.pl \
$(srcdir)/pairs.pl \
$(srcdir)/predicate_options.pl \
$(srcdir)/predopts.pl \
$(srcdir)/prolog_clause.pl \
$(srcdir)/prolog_colour.pl \
$(srcdir)/prolog_source.pl \
$(srcdir)/prolog_xref.pl \
$(srcdir)/quintus.pl \

9
LGPL/README
View File

@@ -4,14 +4,11 @@ LGPL. We would like to thank the authors of the packages and the
developers of the ciao and swi-prolog systems for their help and
kindness in supporting us in distributing this software with YAP.
The packages we include is currently:
The packages we include:
The Pillow web library versio 1.1 developed by the CLIP group.
SWI-Prolog's JPL Prolog/Java interface and Java/Prolog interface
developed by Paul Singleton, Fred Dushin and Jan Wielemaker: only the
Prolog/Java is currently experimented with.
SWI-Prolog's library utilities, developed by Jan Wielemaker and others.
SWI-Prolog's clpr implementation, developed by Leslie De Koninck, Tom
Schrijvers, Bart Demoen, and based on CLP(Q,R) by Christian Holzbaur.

165
LGPL/pairs.pl Normal file
View File

@@ -0,0 +1,165 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2006, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(pairs,
[ pairs_keys_values/3,
pairs_values/2,
pairs_keys/2,
group_pairs_by_key/2,
transpose_pairs/2,
map_list_to_pairs/3
]).
/** <module> Operations on key-value lists
This module implements common operations on Key-Value lists, also known
as _Pairs_. Pairs have great practical value, especially due to
keysort/2 and the library assoc.pl.
This library is based on disussion in the SWI-Prolog mailinglist,
including specifications from Quintus and a library proposal by Richard
O'Keefe.
@see keysort/2, library(assoc)
@author Jan Wielemaker
*/
%% pairs_keys_values(?Pairs, ?Keys, ?Values) is det.
%
% True if Keys holds the keys of Pairs and Values the values.
%
% Deterministic if any argument is instantiated to a finite list
% and the others are either free or finite lists. All three lists
% are in the same order.
%
% @see pairs_values/2 and pairs_keys/2.
pairs_keys_values(Pairs, Keys, Values) :-
( nonvar(Pairs) ->
pairs_keys_values_(Pairs, Keys, Values)
; nonvar(Keys) ->
keys_values_pairs(Keys, Values, Pairs)
; values_keys_pairs(Values, Keys, Pairs)
).
pairs_keys_values_([], [], []).
pairs_keys_values_([K-V|Pairs], [K|Keys], [V|Values]) :-
pairs_keys_values_(Pairs, Keys, Values).
keys_values_pairs([], [], []).
keys_values_pairs([K|Ks], [V|Vs], [K-V|Pairs]) :-
keys_values_pairs(Ks, Vs, Pairs).
values_keys_pairs([], [], []).
values_keys_pairs([V|Vs], [K|Ks], [K-V|Pairs]) :-
values_keys_pairs(Vs, Ks, Pairs).
%% pairs_values(+Pairs, -Values) is det.
%
% Remove the keys from a list of Key-Value pairs. Same as
% pairs_keys_values(Pairs, _, Values)
pairs_values([], []).
pairs_values([_-V|T0], [V|T]) :-
pairs_values(T0, T).
%% pairs_keys(+Pairs, -Keys) is det.
%
% Remove the values from a list of Key-Value pairs. Same as
% pairs_keys_values(Pairs, Keys, _)
pairs_keys([], []).
pairs_keys([K-_|T0], [K|T]) :-
pairs_keys(T0, T).
%% group_pairs_by_key(+Pairs, -Joined:list(Key-Values)) is det.
%
% Group values with the same key. Pairs must be a key-sorted list.
% For example:
%
% ==
% ?- group_pairs_by_key([a-2, a-1, b-4], X).
%
% X = [a-[2,1], b-[4]]
% ==
%
% @param Pairs Key-Value list, sorted to the standard order
% of terms (as keysort/2 does)
% @param Joined List of Key-Group, where Group is the
% list of Values associated with Key.
group_pairs_by_key([], []).
group_pairs_by_key([M-N|T0], [M-[N|TN]|T]) :-
same_key(M, T0, TN, T1),
group_pairs_by_key(T1, T).
same_key(M, [M-N|T0], [N|TN], T) :- !,
same_key(M, T0, TN, T).
same_key(_, L, [], L).
%% transpose_pairs(+Pairs, -Transposed) is det.
%
% Swap Key-Value to Value-Key and sort the result on Value
% (the new key) using keysort/2.
transpose_pairs(Pairs, Transposed) :-
flip_pairs(Pairs, Flipped),
keysort(Flipped, Transposed).
flip_pairs([], []).
flip_pairs([Key-Val|Pairs], [Val-Key|Flipped]) :-
flip_pairs(Pairs, Flipped).
%% map_list_to_pairs(:Function, +List, -Keyed)
%
% Create a key-value list by mapping each element of List.
% For example, if we have a list of lists we can create a
% list of Length-List using
%
% ==
% map_list_to_pairs(length, ListOfLists, Pairs),
% ==
:- meta_predicate
map_list_to_pairs(2, +, -).
map_list_to_pairs(Function, List, Pairs) :-
map_list_to_pairs2(List, Function, Pairs).
map_list_to_pairs2([], _, []).
map_list_to_pairs2([H|T0], Pred, [K-H|T]) :-
call(Pred, H, K),
map_list_to_pairs2(T0, Pred, T).

912
LGPL/predicate_options.pl Normal file
View File

@@ -0,0 +1,912 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2011, VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(predicate_options,
[ predicate_options/3, % +PI, +Arg, +Options
assert_predicate_options/4, % +PI, +Arg, +Options, ?New
current_option_arg/2, % ?PI, ?Arg
current_predicate_option/3, % ?PI, ?Arg, ?Option
check_predicate_option/3, % +PI, +Arg, +Option
% Create declarations
current_predicate_options/3, % ?PI, ?Arg, ?Options
retractall_predicate_options/0,
derived_predicate_options/3, % :PI, ?Arg, ?Options
derived_predicate_options/1, % +Module
% Checking
check_predicate_options/0,
derive_predicate_options/0,
check_predicate_options/1 % :PredicateIndicator
]).
:- use_module(library(lists)).
:- use_module(library(pairs)).
:- use_module(library(error)).
:- use_module(library(lists)).
:- use_module(library(debug)).
:- use_module(library(prolog_clause)).
:- meta_predicate
predicate_options(:, +, +),
assert_predicate_options(:, +, +, ?),
current_predicate_option(:, ?, ?),
check_predicate_option(:, ?, ?),
current_predicate_options(:, ?, ?),
current_option_arg(:, ?),
pred_option(:,-),
derived_predicate_options(:,?,?),
check_predicate_options(:).
/** <module> Access and analyse predicate options
This module provides the developers interface for the directive
predicate_options/3. This directive allows us to specify that e.g.,
open/4 processes options using the 4th argument and supports the option
=type= using the values =text= and =binary=. Declaring options that are
processed allows for more reliable handling of predicate options and
simplifies porting applications. This libarry provides the following
functionality:
* Query supported options through current_predicate_option/3
or current_predicate_options/3. This is intended to support
conditional compilation and an IDE.
* Derive additional declarations through dataflow analysis using
derive_predicate_options/0.
* Perform a compile-time analysis of the entire loaded program using
check_predicate_options/0.
Below, we describe some use-cases.
$ Quick check of a program :
This scenario is useful as an occasional check or to assess problems
with option-handling for porting an application to SWI-Prolog. It
consists of three steps: loading the program (1 and 2), deriving
option handling for application predicates (3) and running the
checker (4).
==
1 ?- [load].
2 ?- autoload.
3 ?- derive_predicate_options.
4 ?- check_predicate_options.
==
$ Add declaations to your program :
Adding declarations about option processes improves the quality of
the checking. The analysis of derive_predicate_options/0 may miss
options and does not derive the types for options that are processed
in Prolog code. The process is similar to the above. In steps 4 and
further, the inferred declarations are listed, inspected and added to
the source-code of the module.
==
1 ?- [load].
2 ?- autoload.
3 ?- derive_predicate_options.
4 ?- derived_predicate_options(module_1).
5 ?- derived_predicate_options(module_2).
6 ?- ...
==
$ Declare option processing requirements :
If an application requires that open/4 needs to support lock(write),
it may do so using the derective below. This directive raises an
exception when loaded on a Prolog implementation that does not support
this option.
==
:- current_predicate_option(open/4, 4, lock(write)).
==
@see library(option) for accessing options in Prolog code.
*/
:- multifile option_decl/3, pred_option/3.
:- dynamic dyn_option_decl/3.
%% predicate_options(:PI, +Arg, +Options) is det.
%
% Declare that the predicate PI processes options on Arg. Options
% is a list of options processed. Each element is one of:
%
% * Option(ModeAndType)
% PI processes Option. The option-value must comply to
% ModeAndType. Mode is one of + or - and Type is a type as
% accepted by must_be/2.
%
% * pass_to(:PI,Arg)
% The option-list is passed to the indicated predicate.
%
% Below is an example that processes the option header(boolean)
% and passes all options to open/4:
%
% ==
% :- predicate_options(write_xml_file/3, 3,
% [ header(boolean),
% pass_to(open/4, 4)
% ]).
%
% write_xml_file(File, XMLTerm, Options) :-
% open(File, write, Out, Options),
% ( option(header(true), Option, true)
% -> write_xml_header(Out)
% ; true
% ),
% ...
% ==
%
% This predicate may only be used as a _directive_ and is
% processed by expand_term/2. Option processing can be be
% specified at runtime using assert_predicate_options/3, which is
% intended to support program analysis.
predicate_options(PI, Arg, Options) :-
throw(error(context_error(nodirective,
predicate_options(PI, Arg, Options)), _)).
%% assert_predicate_options(:PI, +Arg, +Options, ?New) is semidet.
%
% As predicate_options(:PI, +Arg, +Options). New is a boolean
% indicating whether the declarations have changed. If new is
% provided and =false=, the predicate becomes semidet and fails
% without modifications if modifications are required.
assert_predicate_options(PI, Arg, Options, New) :-
canonical_pi(PI, M:Name/Arity),
functor(Head, Name, Arity),
( dyn_option_decl(Head, M, Arg)
-> true
; New = true,
assertz(dyn_option_decl(Head, M, Arg))
),
phrase('$predopts':option_clauses(Options, Head, M, Arg),
OptionClauses),
forall(member(Clause, OptionClauses),
assert_option_clause(Clause, New)),
( var(New)
-> New = false
; true
).
assert_option_clause(Clause, New) :-
rename_clause(Clause, NewClause,
'$pred_option'(A,B,C,D), '$dyn_pred_option'(A,B,C,D)),
clause_head(NewClause, NewHead),
( clause(NewHead, _)
-> true
; New = true,
assertz(NewClause)
).
clause_head(M:(Head:-_Body), M:Head) :- !.
clause_head((M:Head :-_Body), M:Head) :- !.
clause_head(Head, Head).
rename_clause(M:Clause, M:NewClause, Head, NewHead) :- !,
rename_clause(Clause, NewClause, Head, NewHead).
rename_clause((Head :- Body), (NewHead :- Body), Head, NewHead) :- !.
rename_clause(Head, NewHead, Head, NewHead) :- !.
rename_clause(Head, Head, _, _).
/*******************************
* QUERY OPTIONS *
*******************************/
%% current_option_arg(:PI, ?Arg) is nondet.
%
% True when Arg of PI processes predicate options. Which options
% are processed can be accessed using current_predicate_option/3.
current_option_arg(Module:Name/Arity, Arg) :-
current_option_arg(Module:Name/Arity, Arg, _DefM).
current_option_arg(Module:Name/Arity, Arg, DefM) :-
atom(Name), integer(Arity), !,
resolve_module(Module:Name/Arity, DefM:Name/Arity),
functor(Head, Name, Arity),
( option_decl(Head, DefM, Arg)
; dyn_option_decl(Head, DefM, Arg)
).
current_option_arg(M:Name/Arity, Arg, M) :-
( option_decl(Head, M, Arg)
; dyn_option_decl(Head, M, Arg)
),
functor(Head, Name, Arity).
%% current_predicate_option(:PI, ?Arg, ?Option) is nondet.
%
% True when Arg of PI processes Option. For example, the following
% is true:
%
% ==
% ?- current_predicate_option(open/4, 4, type(text)).
% true.
% ==
%
% This predicate is intended to support conditional compilation
% using if/1 ... endif/0. The predicate
% current_predicate_options/3 can be used to access the full
% capabilities of a predicate.
current_predicate_option(Module:PI, Arg, Option) :-
current_option_arg(Module:PI, Arg, DefM),
PI = Name/Arity,
functor(Head, Name, Arity),
catch(pred_option(DefM:Head, Option),
error(type_error(_,_),_),
fail).
%% check_predicate_option(:PI, +Arg, +Option) is det.
%
% Similar to current_predicate_option/3, but intended to support
% runtime checking.
%
% @error existence_error(option, OptionName) if the option is not
% supported by PI.
% @error type_error(Type, Value) if the option is supported but
% the value does not match the option type. See must_be/2.
check_predicate_option(Module:PI, Arg, Option) :-
define_predicate(Module:PI),
current_option_arg(Module:PI, Arg, DefM),
PI = Name/Arity,
functor(Head, Name, Arity),
( pred_option(DefM:Head, Option)
-> true
; existence_error(option, Option)
).
pred_option(M:Head, Option) :-
pred_option(M:Head, Option, []).
pred_option(M:Head, Option, Seen) :-
( has_static_option_decl(M),
M:'$pred_option'(Head, _, Option, Seen)
; has_dynamic_option_decl(M),
M:'$dyn_pred_option'(Head, _, Option, Seen)
).
has_static_option_decl(M) :-
'$c_current_predicate'(_, M:'$pred_option'(_,_,_,_)).
has_dynamic_option_decl(M) :-
'$c_current_predicate'(_, M:'$dyn_pred_option'(_,_,_,_)).
/*******************************
* TYPE&MODE CONSTRAINTS *
*******************************/
:- public
system:predicate_option_mode/2,
system:predicate_option_type/2.
add_attr(Var, Value) :-
( get_attr(Var, predicate_options, Old)
-> put_attr(Var, predicate_options, [Value|Old])
; put_attr(Var, predicate_options, [Value])
).
system:predicate_option_type(Type, Arg) :-
var(Arg), !,
add_attr(Arg, option_type(Type)).
system:predicate_option_type(Type, Arg) :-
must_be(Type, Arg).
system:predicate_option_mode(Mode, Arg) :-
var(Arg), !,
add_attr(Arg, option_mode(Mode)).
system:predicate_option_mode(Mode, Arg) :-
check_mode(Mode, Arg).
check_mode(input, Arg) :-
( nonvar(Arg)
-> true
; instantiation_error(Arg)
).
check_mode(output, Arg) :-
( var(Arg)
-> true
; instantiation_error(Arg) % TBD: Uninstantiated
).
attr_unify_hook([], _).
attr_unify_hook([H|T], Var) :-
option_hook(H, Var),
attr_unify_hook(T, Var).
option_hook(option_type(Type), Value) :-
is_of_type(Type, Value).
option_hook(option_mode(Mode), Value) :-
check_mode(Mode, Value).
attribute_goals(Var) -->
{ get_attr(Var, predicate_options, Attrs) },
option_goals(Attrs, Var).
option_goals([], _) --> [].
option_goals([H|T], Var) -->
option_goal(H, Var),
option_goals(T, Var).
option_goal(option_type(Type), Var) --> [predicate_option_type(Type, Var)].
option_goal(option_mode(Mode), Var) --> [predicate_option_mode(Mode, Var)].
/*******************************
* OUTPUT DECLARATIONS *
*******************************/
%% current_predicate_options(:PI, ?Arg, ?Options) is nondet.
%
% True when Options is the current active option declaration for
% PI on Arg. See predicate_options/3 for the argument
% descriptions. If PI is ground and refers to an undefined
% predicate, the autoloader is used to obtain a definition of the
% predicate.
current_predicate_options(PI, Arg, Options) :-
define_predicate(PI),
setof(Arg-Option,
current_predicate_option_decl(PI, Arg, Option),
Options0),
group_pairs_by_key(Options0, Grouped),
member(Arg-Options, Grouped).
current_predicate_option_decl(PI, Arg, Option) :-
current_predicate_option(PI, Arg, Option0),
Option0 =.. [Name|Values],
maplist(mode_and_type, Values, Types),
Option =.. [Name|Types].
mode_and_type(Value, ModeAndType) :-
copy_term(Value,_,Goals),
( memberchk(predicate_option_mode(output, _), Goals)
-> ModeAndType = -(Type)
; ModeAndType = Type
),
( memberchk(predicate_option_type(Type, _), Goals)
-> true
; Type = any
).
define_predicate(PI) :-
ground(PI), !,
PI = M:Name/Arity,
functor(Head, Name, Arity),
once(predicate_property(M:Head, _)).
define_predicate(_).
%% derived_predicate_options(:PI, ?Arg, ?Options) is nondet.
%
% True when Options is the current _derived_ active option
% declaration for PI on Arg.
derived_predicate_options(PI, Arg, Options) :-
define_predicate(PI),
setof(Arg-Option,
derived_predicate_option(PI, Arg, Option),
Options0),
group_pairs_by_key(Options0, Grouped),
member(Arg-Options1, Grouped),
PI = M:_,
phrase(expand_pass_to_options(Options1, M), Options2),
sort(Options2, Options).
derived_predicate_option(PI, Arg, Decl) :-
current_option_arg(PI, Arg, DefM),
PI = _:Name/Arity,
functor(Head, Name, Arity),
has_dynamic_option_decl(DefM),
( has_static_option_decl(DefM),
DefM:'$pred_option'(Head, Decl, _, [])
; DefM:'$dyn_pred_option'(Head, Decl, _, [])
).
%% expand_pass_to_options(+OptionsIn, +Module, -OptionsOut)// is det.
%
% Expand the options of pass_to(PI,Arg) if PI does not refer to a
% public predicate.
expand_pass_to_options([], _) --> [].
expand_pass_to_options([H|T], M) -->
expand_pass_to(H, M),
expand_pass_to_options(T, M).
expand_pass_to(pass_to(PI, Arg), Module) -->
{ strip_module(Module:PI, M, Name/Arity),
functor(Head, Name, Arity),
\+ ( predicate_property(M:Head, exported)
; predicate_property(M:Head, public)
; M == system
), !,
current_predicate_options(M:Name/Arity, Arg, Options)
},
list(Options).
expand_pass_to(Option, _) -->
[Option].
list([]) --> [].
list([H|T]) --> [H], list(T).
%% derived_predicate_options(+Module) is det.
%
% Derive predicate option declarations for the given module and
% print them to the current output.
derived_predicate_options(Module) :-
var(Module), !,
forall(current_module(Module),
derived_predicate_options(Module)).
derived_predicate_options(Module) :-
findall(predicate_options(Module:PI, Arg, Options),
( derived_predicate_options(Module:PI, Arg, Options),
PI = Name/Arity,
functor(Head, Name, Arity),
( predicate_property(Module:Head, exported)
-> true
; predicate_property(Module:Head, public)
)
),
Decls0),
maplist(qualify_decl(Module), Decls0, Decls1),
sort(Decls1, Decls),
( Decls \== []
-> format('~N~n~n% Predicate option declarations for module ~q~n~n',
[Module]),
forall(member(Decl, Decls),
portray_clause((:-Decl)))
; true
).
qualify_decl(M,
predicate_options(PI0, Arg, Options0),
predicate_options(PI1, Arg, Options1)) :-
qualify(PI0, M, PI1),
maplist(qualify_option(M), Options0, Options1).
qualify_option(M, pass_to(PI0, Arg), pass_to(PI1, Arg)) :- !,
qualify(PI0, M, PI1).
qualify_option(_, Opt, Opt).
qualify(M:Term, M, Term) :- !.
qualify(QTerm, _, QTerm).
/*******************************
* CLEANUP *
*******************************/
%% retractall_predicate_options is det.
%
% Remove all dynamically (derived) predicate options.
retractall_predicate_options :-
forall(retract(dyn_option_decl(_,M,_)),
abolish(M:'$dyn_pred_option'/4)).
/*******************************
* COMPILE-TIME CHECKER *
*******************************/
:- thread_local
new_decl/1.
%% check_predicate_options is det.
%
% Analyse loaded program for errornous options. This predicate
% decompiles the current program and searches for calls to
% predicates that process options. For each option list, it
% validates whether the provided options are supported and
% validates the argument type. This predicate performs partial
% dataflow analysis to track option-lists inside a clause.
%
% @see derive_predicate_options/0 can be used to derive
% declarations for predicates that pass options. This
% predicate should normally be called before
% check_predicate_options/0.
check_predicate_options :-
forall(current_module(Module),
check_predicate_options_module(Module)).
%% derive_predicate_options is det.
%
% Derive new predicate option declarations. This predicate
% analyses the loaded program to find clauses that process options
% using one of the predicates from library(option) or passes
% options to other predicates that are known to process options.
% The process is repeated until no new declarations are retrieved.
%
% @see autoload/0 may be used to complete the loaded program.
derive_predicate_options :-
derive_predicate_options(NewDecls),
( NewDecls == []
-> true
; print_message(informational, check_options(new(NewDecls))),
new_decls(NewDecls),
derive_predicate_options
).
new_decls([]).
new_decls([predicate_options(PI, A, O)|T]) :-
assert_predicate_options(PI, A, O, _),
new_decls(T).
derive_predicate_options(NewDecls) :-
call_cleanup(
( forall(
current_module(Module),
forall(
( predicate_in_module(Module, PI),
PI = Name/Arity,
functor(Head, Name, Arity),
catch(Module:clause(Head, Body, Ref), _, fail)
),
check_clause((Head:-Body), Module, Ref, decl))),
( setof(Decl, retract(new_decl(Decl)), NewDecls)
-> true
; NewDecls = []
)
),
retractall(new_decl(_))).
check_predicate_options_module(Module) :-
forall(predicate_in_module(Module, PI),
check_predicate_options(Module:PI)).
predicate_in_module(Module, PI) :-
current_predicate(Module:PI),
PI = Name/Arity,
functor(Head, Name, Arity),
\+ predicate_property(Module:Head, imported_from(_)).
%% check_predicate_options(:PredicateIndicator) is det.
%
% Verify calls to predicates that have options in all clauses of
% the predicate indicated by PredicateIndicator.
check_predicate_options(Module:Name/Arity) :-
debug(predicate_options, 'Checking ~q', [Module:Name/Arity]),
functor(Head, Name, Arity),
forall(catch(Module:clause(Head, Body, Ref), _, fail),
check_clause((Head:-Body), Module, Ref, check)).
%% check_clause(+Clause, +Module, +Ref, +Action) is det.
%
% Action is one of
%
% * decl
% Create additional declarations
% * check
% Produce error messages
check_clause((Head:-Body), M, ClauseRef, Action) :- !,
catch(check_body(Body, M, _, Action), E, true),
( var(E)
-> option_decl(M:Head, Action)
; ( clause_info(ClauseRef, File, TermPos, _NameOffset),
TermPos = term_position(_,_,_,_,[_,BodyPos]),
catch(check_body(Body, M, BodyPos, Action),
error(Formal, ArgPos), true),
compound(ArgPos),
arg(1, ArgPos, CharCount),
integer(CharCount)
-> Location = file_char_count(File, CharCount)
; Location = clause(ClauseRef),
E = error(Formal, _)
),
print_message(error, predicate_option_error(Formal, Location))
).
%% check_body(+Body, +Module, +TermPos, +Action)
check_body(Var, _, _, _) :-
var(Var), !.
check_body(M:G, _, term_position(_,_,_,_,[_,Pos]), Action) :- !,
check_body(G, M, Pos, Action).
check_body((A,B), M, term_position(_,_,_,_,[PA,PB]), Action) :- !,
check_body(A, M, PA, Action),
check_body(B, M, PB, Action).
check_body(A=B, _, _, _) :- % partial evaluation
unify_with_occurs_check(A,B), !.
check_body(Goal, M, term_position(_,_,_,_,ArgPosList), Action) :-
callable(Goal),
functor(Goal, Name, Arity),
( '$get_predicate_attribute'(M:Goal, imported, DefM)
-> true
; DefM = M
),
( eval_option_pred(DefM:Goal)
-> true
; current_option_arg(DefM:Name/Arity, OptArg), !,
arg(OptArg, Goal, Options),
nth1(OptArg, ArgPosList, ArgPos),
check_options(DefM:Name/Arity, OptArg, Options, ArgPos, Action)
).
check_body(Goal, M, _, Action) :-
prolog:called_by(Goal, Called), !,
check_called_by(Called, M, Action).
check_body(Meta, M, term_position(_,_,_,_,ArgPosList), Action) :-
'$get_predicate_attribute'(M:Meta, meta_predicate, Head), !,
check_meta_args(1, Head, Meta, M, ArgPosList, Action).
check_body(_, _, _, _).
check_meta_args(I, Head, Meta, M, [ArgPos|ArgPosList], Action) :-
arg(I, Head, AS), !,
( AS == 0
-> arg(I, Meta, MA),
check_body(MA, M, ArgPos, Action)
; true
),
succ(I, I2),
check_meta_args(I2, Head, Meta, M, ArgPosList, Action).
check_meta_args(_,_,_,_, _, _).
%% check_called_by(+CalledBy, +M, +Action) is det.
%
% Handle results from prolog:called_by/2.
check_called_by([], _, _).
check_called_by([H|T], M, Action) :-
( H = G+N
-> ( extend(G, N, G2)
-> check_body(G2, M, _, Action)
; true
)
; check_body(H, M, _, Action)
),
check_called_by(T, M, Action).
extend(Goal, N, GoalEx) :-
callable(Goal),
Goal =.. List,
length(Extra, N),
append(List, Extra, ListEx),
GoalEx =.. ListEx.
%% check_options(:Predicate, +OptionArg, +Options, +ArgPos, +Action)
%
% Verify the list Options, that is passed into Predicate on
% argument OptionArg. ArgPos is a term-position term describing
% the location of the Options list. If Options is a partial list,
% the tail is annotated with pass_to(PI, OptArg).
check_options(PI, OptArg, QOptions, ArgPos, Action) :-
debug(predicate_options, '\tChecking call to ~q', [PI]),
remove_qualifier(QOptions, Options),
must_be(list_or_partial_list, Options),
check_option_list(Options, PI, OptArg, Options, ArgPos, Action).
remove_qualifier(X, X) :-
var(X), !.
remove_qualifier(_:X, X) :- !.
remove_qualifier(X, X).
check_option_list(Var, PI, OptArg, _, _, _) :-
var(Var), !,
annotate(Var, pass_to(PI, OptArg)).
check_option_list([], _, _, _, _, _).
check_option_list([H|T], PI, OptArg, Options, ArgPos, Action) :-
check_option(PI, OptArg, H, ArgPos, Action),
check_option_list(T, PI, OptArg, Options, ArgPos, Action).
check_option(_, _, _, _, decl) :- !.
check_option(PI, OptArg, Opt, ArgPos, _) :-
catch(check_predicate_option(PI, OptArg, Opt), E, true), !,
( var(E)
-> true
; E = error(Formal,_),
throw(error(Formal,ArgPos))
).
/*******************************
* ANNOTATIONS *
*******************************/
%% annotate(+Var, +Term) is det.
%
% Use constraints to accumulate annotations about variables. If
% two annotated variables are unified, the attributes are joined.
annotate(Var, Term) :-
( get_attr(Var, predopts_analysis, Old)
-> put_attr(Var, predopts_analysis, [Term|Old])
; var(Var)
-> put_attr(Var, predopts_analysis, [Term])
; true
).
annotations(Var, Annotations) :-
get_attr(Var, predopts_analysis, Annotations).
predopts_analysis:attr_unify_hook(Opts, Value) :-
get_attr(Value, predopts_analysis, Others), !,
append(Opts, Others, All),
put_attr(Value, predopts_analysis, All).
predopts_analysis:attr_unify_hook(_, _).
/*******************************
* PARTIAL EVAL *
*******************************/
eval_option_pred(swi_option:option(Opt, Options)) :-
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:option(Opt, Options, _Default)) :-
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:select_option(Opt, Options, Rest)) :-
ignore(unify_with_occurs_check(Rest, Options)),
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:select_option(Opt, Options, Rest, _Default)) :-
ignore(unify_with_occurs_check(Rest, Options)),
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:meta_options(_Cond, QOptionsIn, QOptionsOut)) :-
remove_qualifier(QOptionsIn, OptionsIn),
remove_qualifier(QOptionsOut, OptionsOut),
ignore(unify_with_occurs_check(OptionsIn, OptionsOut)).
processes(Opt, Spec) :-
compound(Opt),
functor(Opt, OptName, 1),
Spec =.. [OptName,any].
/*******************************
* NEW DECLARTIONS *
*******************************/
%% option_decl(:Head, +Action) is det.
%
% Add new declarations based on attributes left by the analysis
% pass. We do not add declarations for system modules or modules
% that already contain static declarations.
%
% @tbd Should we add a mode to include generating declarations
% for system modules and modules with static declarations?
option_decl(_, check) :- !.
option_decl(M:_, _) :-
system_module(M), !.
option_decl(M:_, _) :-
has_static_option_decl(M), !.
option_decl(M:Head, _) :-
arg(AP, Head, QA),
remove_qualifier(QA, A),
annotations(A, Annotations0),
functor(Head, Name, Arity),
PI = M:Name/Arity,
delete(Annotations0, pass_to(PI,AP), Annotations),
Annotations \== [],
Decl = predicate_options(PI, AP, Annotations),
( new_decl(Decl)
-> true
; assert_predicate_options(M:Name/Arity, AP, Annotations, false)
-> true
; assertz(new_decl(Decl)),
debug(predicate_options(decl), '~q', [Decl])
),
fail.
option_decl(_, _).
system_module(system) :- !.
system_module(Module) :-
sub_atom(Module, 0, _, _, $).
/*******************************
* MISC *
*******************************/
canonical_pi(M:Name//Arity, M:Name/PArity) :-
integer(Arity),
PArity is Arity+2.
canonical_pi(PI, PI).
%% resolve_module(:PI, -DefPI) is det.
%
% Find the real predicate indicator pointing to the definition
% module of PI. This is similar to using predicate_property/3 with
% the property imported_from, but using
% '$get_predicate_attribute'/3 avoids auto-importing the
% predicate.
resolve_module(Module:Name/Arity, DefM:Name/Arity) :-
functor(Head, Name, Arity),
( '$get_predicate_attribute'(Module:Head, imported, M)
-> DefM = M
; DefM = Module
).
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message//1.
prolog:message(predicate_option_error(Formal, Location)) -->
error_location(Location),
'$messages':term_message(Formal). % TBD: clean interface
prolog:message(check_options(new(Decls))) -->
[ 'Inferred declarations:'-[], nl ],
new_decls(Decls).
error_location(file_char_count(File, CharPos)) -->
{ filepos_line(File, CharPos, Line, LinePos) },
[ '~w:~d:~d: '-[File, Line, LinePos] ].
error_location(clause(ClauseRef)) -->
{ clause_property(ClauseRef, file(File)),
clause_property(ClauseRef, line_count(Line))
}, !,
[ '~w:~d: '-[File, Line] ].
error_location(clause(ClauseRef)) -->
[ 'Clause ~q: '-[ClauseRef] ].
filepos_line(File, CharPos, Line, LinePos) :-
setup_call_cleanup(
( open(File, read, In),
open_null_stream(Out)
),
( Skip is CharPos-1,
copy_stream_data(In, Out, Skip),
stream_property(In, position(Pos)),
stream_position_data(line_count, Pos, Line),
stream_position_data(line_position, Pos, LinePos)
),
( close(Out),
close(In)
)).
new_decls([]) --> [].
new_decls([H|T]) -->
[ ' :- ~q'-[H], nl ],
new_decls(T).
/*******************************
* SYSTEM DECLARATIONS *
*******************************/
:- use_module(library(dialect/swi/syspred_options)).

141
LGPL/predopts.pl Normal file
View File

@@ -0,0 +1,141 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2011, VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module('$predopts',
[
]).
:- multifile
predicate_options:option_decl/3,
predicate_options:pred_option/3.
:- multifile % provided by library(predicate_options)
system:predicate_option_type/2,
system:predicate_option_mode/2.
:- public
option_clauses//4.
%% expand_predicate_options(:PI, +Arg, +OptionList, -Clauses) is det.
%
% Term-expansion code for predicate_options(PI, Arg, OptionList).
expand_predicate_options(PI, Arg, Options,
[ predicate_options:option_decl(Head, M, Arg),
(:-multifile(M:'$pred_option'/4))
| OptionClauses
]) :-
canonical_pi(PI, CPI),
prolog_load_context(module, M0),
strip_module(M0:CPI, M, Name/Arity),
functor(Head, Name, Arity),
( is_list(Options)
-> true
; throw(error(type_error(list, Options), _))
),
phrase(option_clauses(Options, Head, M, Arg), OptionClauses0),
qualify_list(OptionClauses0, M0, OptionClauses).
qualify_list([], _, []).
qualify_list([H0|T0], M, [H|T]) :-
qualify(H0, M, H),
qualify_list(T0, M, T).
qualify(M:Term, M, Term) :- !.
qualify(QTerm, _, QTerm).
option_clauses([], _, _, _) --> [].
option_clauses([H|T], Head, M, A) -->
option_clause(H, Head, M),
option_clauses(T, Head, M, A).
option_clause(Var, _, _) -->
{ var(Var), !,
throw(error(instantiation_error, _))
}.
option_clause(pass_to(PI0, Arg), Head, M) --> !,
{ canonical_pi(PI0, PI),
strip_module(M:PI, TM, Name/Arity),
functor(THead, Name, Arity),
Clause = ('$pred_option'(Head, pass_to(PI0, Arg), Opt, Seen) :-
\+ memberchk(PI-Arg, Seen),
predicate_options:pred_option(TM:THead, Opt, [PI-Arg|Seen]))
},
[ M:Clause ].
option_clause(Option, Head, M) -->
{ Option =.. [Name|ModeAndTypes], !,
modes_and_types(ModeAndTypes, Args, Body),
Opt =.. [Name|Args],
Clause = ('$pred_option'(Head, Option, Opt, _) :- Body)
},
[ M:Clause ].
option_clause(Option, _, _) -->
{ throw(error(type_error(option_specifier, Option)))
}.
modes_and_types([], [], true).
modes_and_types([H|T], [A|AT], Body) :-
mode_and_type(H, A, Body0),
( T == []
-> Body = Body0,
AT = []
; Body0 == true
-> modes_and_types(T, AT, Body)
; Body = (Body0,Body1),
modes_and_types(T, AT, Body1)
).
mode_and_type(-Type, A, (predicate_option_mode(output, A), Body)) :- !,
type_goal(Type, A, Body).
mode_and_type(+Type, A, Body) :- !,
type_goal(Type, A, Body).
mode_and_type(Type, A, Body) :-
type_goal(Type, A, Body).
type_goal(Type, A, predicate_option_type(Type, A)).
%% canonical_pi(+PIIn, -PIout)
canonical_pi(M:Name//Arity, M:Name/PArity) :-
integer(Arity), !,
PArity is Arity+2.
canonical_pi(Name//Arity, Name/PArity) :-
integer(Arity), !,
PArity is Arity+2.
canonical_pi(PI, PI).
/*******************************
* EXPAND *
*******************************/
%system:term_expansion((:- predicate_options(PI, Arg, Options)), Clauses) :-
% expand_predicate_options(PI, Arg, Options, Clauses).

675
LGPL/prolog_clause.pl Normal file
View File

@@ -0,0 +1,675 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2011, University of Amsterdam
VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_clause,
[ clause_info/4, % +ClauseRef, -File, -TermPos, -VarNames
predicate_name/2, % +Head, -Name
clause_name/2 % +ClauseRef, -Name
]).
:- use_module(library(lists), [append/3]).
:- use_module(library(occurs), [sub_term/2]).
:- use_module(library(debug)).
:- use_module(library(listing)).
:- use_module(library(prolog_source)).
:- public % called from library(trace/clause)
unify_term/2,
make_varnames/5,
do_make_varnames/3.
:- multifile
make_varnames_hook/5.
/** <module> Get detailed source-information about a clause
This module started life as part of the GUI tracer. As it is generally
useful for debugging purposes it has moved to the general Prolog
library.
The tracer library library(trace/clause) adds caching and dealing with
dynamic predicates using listing to XPCE objects to this. Note that
clause_info/4 as below can be slow.
*/
%% clause_info(+ClauseRef, -File, -TermPos, -VarNames)
%
% Fetches source information for the given clause. File is the
% file from which the clause was loaded. TermPos describes the
% source layout in a format compatible to the subterm_positions
% option of read_term/2. VarNames provides access to the variable
% allocation in a stack-frame. See make_varnames/5 for details.
clause_info(ClauseRef, File, TermPos, NameOffset) :-
( debugging(clause_info)
-> clause_name(ClauseRef, Name),
debug(clause_info, 'clause_info(~w) (~w)... ',
[ClauseRef, Name])
; true
),
clause_property(ClauseRef, file(File)),
'$clause'(Head, Body, ClauseRef, VarOffset),
( Body == true
-> DecompiledClause = Head
; DecompiledClause = (Head :- Body)
),
File \== user, % loaded using ?- [user].
clause_property(ClauseRef, line_count(LineNo)),
( module_property(Module, file(File))
-> true
; strip_module(user:Head, Module, _)
),
debug(clause_info, 'from ~w:~d ... ', [File, LineNo]),
read_term_at_line(File, LineNo, Module, Clause, TermPos0, VarNames),
debug(clause_info, 'read ...', []),
unify_clause(Clause, DecompiledClause, Module, TermPos0, TermPos),
debug(clause_info, 'unified ...', []),
make_varnames(Clause, DecompiledClause, VarOffset, VarNames, NameOffset),
debug(clause_info, 'got names~n', []), !.
%% unify_term(+T1, +T2)
%
% Unify the two terms, where T2 is created by writing the term and
% reading it back in, but be aware that rounding problems may
% cause floating point numbers not to unify. Also, if the initial
% term has a string object, it is written as "..." and read as a
% code-list. We compensate for that.
%
% NOTE: Called directly from library(trace/clause) for the GUI
% tracer.
unify_term(X, X) :- !.
unify_term(X1, X2) :-
compound(X1),
compound(X2),
functor(X1, F, Arity),
functor(X2, F, Arity), !,
unify_args(0, Arity, X1, X2).
unify_term(X, Y) :-
float(X), float(Y), !.
unify_term(X, Y) :-
string(X),
is_list(Y),
string_to_list(X, Y), !.
unify_term(_, Y) :-
Y == '...', !. % elipses left by max_depth
unify_term(_:X, Y) :-
unify_term(X, Y), !.
unify_term(X, _:Y) :-
unify_term(X, Y), !.
unify_term(X, Y) :-
format('[INTERNAL ERROR: Diff:~n'),
portray_clause(X),
format('~N*** <->~n'),
portray_clause(Y),
break.
unify_args(N, N, _, _) :- !.
unify_args(I, Arity, T1, T2) :-
A is I + 1,
arg(A, T1, A1),
arg(A, T2, A2),
unify_term(A1, A2),
unify_args(A, Arity, T1, T2).
%% read_term_at_line(+File, +Line, +Module,
%% -Clause, -TermPos, -VarNames) is semidet.
%
% Read a term from File at Line.
read_term_at_line(File, Line, Module, Clause, TermPos, VarNames) :-
catch(open(File, read, In), _, fail),
call_cleanup(
read_source_term_at_location(
In, Clause,
[ line(Line),
module(Module),
subterm_positions(TermPos),
variable_names(VarNames)
]),
close(In)).
%% make_varnames(+ReadClause, +DecompiledClause,
%% +Offsets, +Names, -Term) is det.
%
% Create a Term varnames(...) where each argument contains the name
% of the variable at that offset. If the read Clause is a DCG rule,
% name the two last arguments <DCG_list> and <DCG_tail>
%
% This predicate calles the multifile predicate
% make_varnames_hook/5 with the same arguments to allow for user
% extensions. Extending this predicate is needed if a compiler
% adds additional arguments to the clause head that must be made
% visible in the GUI tracer.
%
% @param Offsets List of Offset=Var
% @param Names List of Name=Var
make_varnames(ReadClause, DecompiledClause, Offsets, Names, Term) :-
make_varnames_hook(ReadClause, DecompiledClause, Offsets, Names, Term), !.
make_varnames((Head --> _Body), _, Offsets, Names, Bindings) :- !,
functor(Head, _, Arity),
In is Arity,
memberchk(In=IVar, Offsets),
Names1 = ['<DCG_list>'=IVar|Names],
Out is Arity + 1,
memberchk(Out=OVar, Offsets),
Names2 = ['<DCG_tail>'=OVar|Names1],
make_varnames(xx, xx, Offsets, Names2, Bindings).
make_varnames(_, _, Offsets, Names, Bindings) :-
length(Offsets, L),
functor(Bindings, varnames, L),
do_make_varnames(Offsets, Names, Bindings).
do_make_varnames([], _, _).
do_make_varnames([N=Var|TO], Names, Bindings) :-
( find_varname(Var, Names, Name)
-> true
; Name = '_'
),
AN is N + 1,
arg(AN, Bindings, Name),
do_make_varnames(TO, Names, Bindings).
find_varname(Var, [Name = TheVar|_], Name) :-
Var == TheVar, !.
find_varname(Var, [_|T], Name) :-
find_varname(Var, T, Name).
%% unify_clause(+Read, +Decompiled, +Module, +ReadTermPos,
%% -RecompiledTermPos).
%
% What you read isn't always what goes into the database. The task
% of this predicate is to establish the relation between the term
% read from the file and the result from decompiling the clause.
%
% This predicate calls the multifile predicate unify_clause_hook/5
% with the same arguments to support user extensions.
%
% @tbd This really must be more flexible, dealing with much
% more complex source-translations, falling back to a
% heuristic method locating as much as possible.
:- multifile
unify_clause_hook/5.
unify_clause(Read, Read, _, TermPos, TermPos) :- !.
% XPCE send-methods
unify_clause(Read, Decompiled, Module, TermPoso, TermPos) :-
unify_clause_hook(Read, Decompiled, Module, TermPoso, TermPos), !.
unify_clause(:->(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
% XPCE get-methods
unify_clause(:<-(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
% Unit test clauses
unify_clause((TH :- Body),
(_:'unit body'(_, _) :- !, Body), _,
TP0, TP) :-
( TH = test(_,_)
; TH = test(_)
), !,
TP0 = term_position(F,T,FF,FT,[HP,BP]),
TP = term_position(F,T,FF,FT,[HP,term_position(0,0,0,0,[FF-FT,BP])]).
% module:head :- body
unify_clause((Head :- Read),
(Head :- _M:Compiled), Module, TermPos0, TermPos) :-
unify_clause((Head :- Read), (Head :- Compiled), Module, TermPos0, TermPos1),
TermPos1 = term_position(TA,TZ,FA,FZ,[PH,PB]),
TermPos = term_position(TA,TZ,FA,FZ,
[ PH,
term_position(0,0,0,0,[0-0,PB])
]).
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
Read = (_ --> List, _),
is_list(List),
ci_expand(Read, Compiled2, Module),
Compiled2 = (DH :- _),
functor(DH, _, Arity),
DArg is Arity - 1,
arg(DArg, DH, List),
nonvar(List),
TermPos0 = term_position(F,T,FF,FT,[ HP,
term_position(_,_,_,_,[_,BP])
]), !,
TermPos1 = term_position(F,T,FF,FT,[ HP, BP ]),
match_module(Compiled2, Compiled1, TermPos1, TermPos).
% general term-expansion
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
ci_expand(Read, Compiled2, Module),
match_module(Compiled2, Compiled1, TermPos0, TermPos).
% I don't know ...
unify_clause(_, _, _, _, _) :-
debug(clause_info, 'Could not unify clause', []),
fail.
unify_clause_head(H1, H2) :-
strip_module(H1, _, H),
strip_module(H2, _, H).
ci_expand(Read, Compiled, Module) :-
catch(setup_call_cleanup('$set_source_module'(Old, Module),
expand_term(Read, Compiled),
'$set_source_module'(_, Old)),
E,
expand_failed(E, Read)).
match_module((H1 :- B1), (H2 :- B2), Pos0, Pos) :- !,
unify_clause_head(H1, H2),
unify_body(B1, B2, Pos0, Pos).
match_module(H1, H2, Pos, Pos) :- % deal with facts
unify_clause_head(H1, H2).
%% expand_failed(+Exception, +Term)
%
% When debugging, indicate that expansion of the term failed.
expand_failed(E, Read) :-
debugging(clause_info),
message_to_string(E, Msg),
debug(clause_info, 'Term-expand ~p failed: ~w', [Read, Msg]),
fail.
%% unify_body(+Read, +Decompiled, +Pos0, -Pos)
%
% Deal with translations implied by the compiler. For example,
% compiling (a,b),c yields the same code as compiling a,b,c.
%
% Pos0 and Pos still include the term-position of the head.
unify_body(B, B, Pos, Pos) :-
does_not_dcg_after_binding(B, Pos), !.
unify_body(R, D,
term_position(F,T,FF,FT,[HP,BP0]),
term_position(F,T,FF,FT,[HP,BP])) :-
ubody(R, D, BP0, BP).
%% does_not_dcg_after_binding(+ReadBody, +ReadPos) is semidet.
%
% True if ReadPos/ReadPos does not contain DCG delayed
% unifications.
%
% @tbd We should pass that we are in a DCG; if we are not there
% is no reason for this test.
does_not_dcg_after_binding(B, Pos) :-
acyclic_term(B), % X = call(X)
\+ sub_term(brace_term_position(_,_,_), Pos),
\+ (sub_term((Cut,_=_), B), Cut == !), !.
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Some remarks.
a --> { x, y, z }.
This is translated into "(x,y),z), X=Y" by the DCG translator, after
which the compiler creates "a(X,Y) :- x, y, z, X=Y".
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
%% ubody(+Read, +Decompiled, +TermPosRead, -TermPosForDecompiled)
%
% @param Read Clause read _after_ expand_term/2
% @param Decompiled Decompiled clause
% @param TermPosRead Sub-term positions of source
ubody(B, B, P, P) :-
does_not_dcg_after_binding(B, P), !.
ubody(X, call(X), % X = call(X)
From-To,
term_position(From, To, From, To, [From-To])) :- !.
ubody(B0, B,
brace_term_position(F,T,A0),
Pos) :-
B0 = (_,_=_), !,
T1 is T - 1,
ubody(B0, B,
term_position(F,T,
F,T,
[A0,T1-T]),
Pos).
ubody(B0, B,
brace_term_position(F,T,A0),
term_position(F,T,F,T,[A])) :- !,
ubody(B0, B, A0, A).
ubody(C0, C, P0, P) :-
nonvar(C0), nonvar(C),
C0 = (_,_), C = (_,_), !,
conj(C0, P0, GL, PL),
mkconj(C, P, GL, PL).
ubody(X0, X,
term_position(F,T,FF,TT,PA0),
term_position(F,T,FF,TT,PA)) :-
meta(X0), !,
X0 =.. [_|A0],
X =.. [_|A],
ubody_list(A0, A, PA0, PA).
% 5.7.X optimizations
ubody(_=_, true, % singleton = Any
term_position(F,T,_FF,_TT,_PA),
F-T) :- !.
ubody(_==_, fail, % singleton/firstvar == Any
term_position(F,T,_FF,_TT,_PA),
F-T) :- !.
ubody(A1=B1, B2=A2, % Term = Var --> Var = Term
term_position(F,T,FF,TT,[PA1,PA2]),
term_position(F,T,FF,TT,[PA2,PA1])) :-
(A1==B1) =@= (B2==A2), !,
A1 = A2, B1=B2.
ubody(A1==B1, B2==A2, % const == Var --> Var == const
term_position(F,T,FF,TT,[PA1,PA2]),
term_position(F,T,FF,TT,[PA2,PA1])) :-
(A1==B1) =@= (B2==A2), !,
A1 = A2, B1=B2.
ubody(A is B - C, A is B + C2, Pos, Pos) :-
integer(C),
C2 =:= -C, !.
ubody_list([], [], [], []).
ubody_list([G0|T0], [G|T], [PA0|PAT0], [PA|PAT]) :-
ubody(G0, G, PA0, PA),
ubody_list(T0, T, PAT0, PAT).
conj(Goal, Pos, GoalList, PosList) :-
conj(Goal, Pos, GoalList, [], PosList, []).
conj((A,B), term_position(_,_,_,_,[PA,PB]), GL, TG, PL, TP) :- !,
conj(A, PA, GL, TGA, PL, TPA),
conj(B, PB, TGA, TG, TPA, TP).
conj((A,B), brace_term_position(_,T,PA), GL, TG, PL, TP) :-
B = (_=_), !,
conj(A, PA, GL, TGA, PL, TPA),
T1 is T - 1,
conj(B, T1-T, TGA, TG, TPA, TP).
conj((!,(S=SR)), F-T, [!,S=SR|TG], TG, [F-T,F1-T1|TP], TP) :-
F1 is F+1,
T1 is T+1.
conj(A, P, [A|TG], TG, [P|TP], TP).
mkconj(Goal, Pos, GoalList, PosList) :-
mkconj(Goal, Pos, GoalList, [], PosList, []).
mkconj(Conj, term_position(0,0,0,0,[PA,PB]), GL, TG, PL, TP) :-
nonvar(Conj),
Conj = (A,B), !,
mkconj(A, PA, GL, TGA, PL, TPA),
mkconj(B, PB, TGA, TG, TPA, TP).
mkconj(A0, P0, [A|TG], TG, [P|TP], TP) :-
ubody(A, A0, P, P0).
/*******************************
* PCE STUFF (SHOULD MOVE) *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
<method>(Receiver, ... Arg ...) :->
Body
mapped to:
send_implementation(Id, <method>(...Arg...), Receiver)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
pce_method_clause(Head, Body, _:PlHead, PlBody, TermPos0, TermPos) :- !,
pce_method_clause(Head, Body, PlBody, PlHead, TermPos0, TermPos).
pce_method_clause(Head, Body,
send_implementation(_Id, Msg, Receiver), PlBody,
TermPos0, TermPos) :- !,
debug(clause_info, 'send method ...', []),
arg(1, Head, Receiver),
functor(Head, _, Arity),
pce_method_head_arguments(2, Arity, Head, Msg),
debug(clause_info, 'head ...', []),
pce_method_body(Body, PlBody, TermPos0, TermPos).
pce_method_clause(Head, Body,
get_implementation(_Id, Msg, Receiver, Result), PlBody,
TermPos0, TermPos) :- !,
debug(clause_info, 'get method ...', []),
arg(1, Head, Receiver),
debug(clause_info, 'receiver ...', []),
functor(Head, _, Arity),
arg(Arity, Head, PceResult),
debug(clause_info, '~w?~n', [PceResult = Result]),
pce_unify_head_arg(PceResult, Result),
Ar is Arity - 1,
pce_method_head_arguments(2, Ar, Head, Msg),
debug(clause_info, 'head ...', []),
pce_method_body(Body, PlBody, TermPos0, TermPos).
pce_method_head_arguments(N, Arity, Head, Msg) :-
N =< Arity, !,
arg(N, Head, PceArg),
PLN is N - 1,
arg(PLN, Msg, PlArg),
pce_unify_head_arg(PceArg, PlArg),
debug(clause_info, '~w~n', [PceArg = PlArg]),
NextArg is N+1,
pce_method_head_arguments(NextArg, Arity, Head, Msg).
pce_method_head_arguments(_, _, _, _).
pce_unify_head_arg(V, A) :-
var(V), !,
V = A.
pce_unify_head_arg(A:_=_, A) :- !.
pce_unify_head_arg(A:_, A).
% pce_method_body(+SrcBody, +DbBody, +TermPos0, -TermPos
%
% Unify the body of an XPCE method. Goal-expansion makes this
% rather tricky, especially as we cannot call XPCE's expansion
% on an isolated method.
%
% TermPos0 is the term-position term of the whole clause!
%
% Further, please note that the body of the method-clauses reside
% in another module than pce_principal, and therefore the body
% starts with an I_CONTEXT call. This implies we need a
% hypothetical term-position for the module-qualifier.
pce_method_body(A0, A, TermPos0, TermPos) :-
TermPos0 = term_position(F, T, FF, FT,
[ HeadPos,
BodyPos0
]),
TermPos = term_position(F, T, FF, FT,
[ HeadPos,
term_position(0,0,0,0, [0-0,BodyPos])
]),
pce_method_body2(A0, A, BodyPos0, BodyPos).
pce_method_body2(::(_,A0), A, TermPos0, TermPos) :- !,
TermPos0 = term_position(_, _, _, _, [_Cmt,BodyPos0]),
TermPos = BodyPos,
expand_goal(A0, A, BodyPos0, BodyPos).
pce_method_body2(A0, A, TermPos0, TermPos) :-
A0 =.. [Func,B0,C0],
control_op(Func), !,
A =.. [Func,B,C],
TermPos0 = term_position(F, T, FF, FT,
[ BP0,
CP0
]),
TermPos = term_position(F, T, FF, FT,
[ BP,
CP
]),
pce_method_body2(B0, B, BP0, BP),
expand_goal(C0, C, CP0, CP).
pce_method_body2(A0, A, TermPos0, TermPos) :-
expand_goal(A0, A, TermPos0, TermPos).
control_op(',').
control_op((;)).
control_op((->)).
control_op((*->)).
/*******************************
* EXPAND_GOAL SUPPORT *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
With the introduction of expand_goal, it is increasingly hard to relate
the clause from the database to the actual source. For one thing, we do
not know the compilation module of the clause (unless we want to
decompile it).
Goal expansion can translate goals into control-constructs, multiple
clauses, or delete a subgoal.
To keep track of the source-locations, we have to redo the analysis of
the clause as defined in init.pl
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
expand_goal(G, call(G), P, term_position(0,0,0,0,[P])) :-
var(G), !.
expand_goal(G, G, P, P) :-
var(G), !.
expand_goal(M0, M, P0, P) :-
meta(M0), !,
P0 = term_position(F,T,FF,FT,PL0),
P = term_position(F,T,FF,FT,PL),
functor(M0, Functor, Arity),
functor(M, Functor, Arity),
expand_meta_args(PL0, PL, 1, M0, M).
expand_goal(A, B, P0, P) :-
goal_expansion(A, B0, P0, P1), !,
expand_goal(B0, B, P1, P).
expand_goal(A, A, P, P).
expand_meta_args([], [], _, _, _).
expand_meta_args([P0|T0], [P|T], I, M0, M) :-
arg(I, M0, A0),
arg(I, M, A),
expand_goal(A0, A, P0, P),
NI is I + 1,
expand_meta_args(T0, T, NI, M0, M).
meta((_ , _)).
meta((_ ; _)).
meta((_ -> _)).
meta((_ *-> _)).
meta((\+ _)).
meta((not(_))).
meta((call(_))).
meta((once(_))).
meta((ignore(_))).
meta((forall(_, _))).
goal_expansion(send(R, Msg), send_class(R, _, SuperMsg), P, P) :-
compound(Msg),
Msg =.. [send_super, Selector | Args], !,
SuperMsg =.. [Selector|Args].
goal_expansion(get(R, Msg, A), get_class(R, _, SuperMsg, A), P, P) :-
compound(Msg),
Msg =.. [get_super, Selector | Args], !,
SuperMsg =.. [Selector|Args].
goal_expansion(send_super(R, Msg), send_class(R, _, Msg), P, P).
goal_expansion(get_super(R, Msg, V), get_class(R, _, Msg, V), P, P).
goal_expansion(SendSuperN, send_class(R, _, Msg), P, P) :-
compound(SendSuperN),
SendSuperN =.. [send_super, R, Sel | Args],
Msg =.. [Sel|Args].
goal_expansion(SendN, send(R, Msg), P, P) :-
compound(SendN),
SendN =.. [send, R, Sel | Args],
atom(Sel), Args \== [],
Msg =.. [Sel|Args].
goal_expansion(GetSuperN, get_class(R, _, Msg, Answer), P, P) :-
compound(GetSuperN),
GetSuperN =.. [get_super, R, Sel | AllArgs],
append(Args, [Answer], AllArgs),
Msg =.. [Sel|Args].
goal_expansion(GetN, get(R, Msg, Answer), P, P) :-
compound(GetN),
GetN =.. [get, R, Sel | AllArgs],
append(Args, [Answer], AllArgs),
atom(Sel), Args \== [],
Msg =.. [Sel|Args].
goal_expansion(G0, G, P, P) :-
user:goal_expansion(G0, G), % TBD: we need the module!
G0 \== G. % \=@=?
/*******************************
* PRINTABLE NAMES *
*******************************/
:- module_transparent
predicate_name/2.
:- multifile
user:prolog_predicate_name/2,
user:prolog_clause_name/2.
hidden_module(user).
hidden_module(system).
hidden_module(pce_principal). % should be config
hidden_module(Module) :- % SWI-Prolog specific
import_module(Module, system).
thaffix(1, st) :- !.
thaffix(2, nd) :- !.
thaffix(_, th).
%% predicate_name(:Head, -PredName:string) is det.
%
% Describe a predicate as [Module:]Name/Arity.
predicate_name(Predicate, PName) :-
strip_module(Predicate, Module, Head),
( user:prolog_predicate_name(Module:Head, PName)
-> true
; functor(Head, Name, Arity),
( hidden_module(Module)
-> format(string(PName), '~q/~d', [Name, Arity])
; format(string(PName), '~q:~q/~d', [Module, Name, Arity])
)
).
%% clause_name(+Ref, -Name)
%
% Provide a suitable description of the indicated clause.
clause_name(Ref, Name) :-
user:prolog_clause_name(Ref, Name), !.
clause_name(Ref, Name) :-
nth_clause(Head, N, Ref), !,
predicate_name(Head, PredName),
thaffix(N, Th),
format(string(Name), '~d-~w clause of ~w', [N, Th, PredName]).
clause_name(_, '<meta-call>').

1508
LGPL/prolog_colour.pl Normal file
View File

File diff suppressed because it is too large Load Diff

3
LGPL/settings.pl
View File

@@ -290,6 +290,8 @@ expr_to_list(setting(Name), Module) --> !,
expr_to_list(A, _) -->
[A].
:- if((\+ current_prolog_flag(version_data,yap(_,_,_,_)))).
%% env(+Name:atom, -Value:number) is det.
%% env(+Name:atom, +Default:number, -Value:number) is det
%
@@ -310,6 +312,7 @@ env(Name, Default, Value) :-
; Value = Default
).
:- endif.
%% numeric_type(+Type, -BaseType)
%

3
Makefile.in
View File

@@ -101,7 +101,7 @@ SONAMEFLAG=@SONAMEFLAG@
#4.1VPATH=@srcdir@:@srcdir@/OPTYap
CWD=$(PWD)
#
VERSION=6.3.1
VERSION=6.3.2
MYDDAS_VERSION=MYDDAS-0.9.1
#
@@ -861,6 +861,7 @@ install_copied_files:
@INSTALLCLP@(cd LGPL/clp ; $(MAKE) install)
(cd packages/CLPBN ; $(MAKE) install)
(cd packages/meld; $(MAKE) install)
(cd packages/xml; $(MAKE) install)
(cd packages/ProbLog ; $(MAKE) install)
##########

64
OPTYap/opt.preds.c
View File

@@ -484,9 +484,12 @@ static Int p_abolish_all_tables( USES_REGS1 ) {
static Int p_show_tabled_predicates( USES_REGS1 ) {
IOSTREAM *out;
tab_ent_ptr tab_ent;
Term t = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t))))
return FALSE;
tab_ent = GLOBAL_root_tab_ent;
Sfprintf(out, "Tabled predicates\n");
if (tab_ent == NULL)
@@ -504,9 +507,12 @@ static Int p_show_table( USES_REGS1 ) {
IOSTREAM *out;
Term mod, t;
tab_ent_ptr tab_ent;
Term t1 = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t1) || !IsAtomTerm(t1))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t1))))
return FALSE;
mod = Deref(ARG2);
t = Deref(ARG3);
if (IsAtomTerm(t))
@@ -526,9 +532,12 @@ static Int p_show_table( USES_REGS1 ) {
static Int p_show_all_tables( USES_REGS1 ) {
IOSTREAM *out;
tab_ent_ptr tab_ent;
Term t = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t))))
return FALSE;
tab_ent = GLOBAL_root_tab_ent;
while(tab_ent) {
show_table(tab_ent, SHOW_MODE_STRUCTURE, out);
@@ -541,9 +550,12 @@ static Int p_show_all_tables( USES_REGS1 ) {
static Int p_show_global_trie( USES_REGS1 ) {
IOSTREAM *out;
Term t = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t))))
return FALSE;
show_global_trie(SHOW_MODE_STRUCTURE, out);
PL_release_stream(out);
return (TRUE);
@@ -554,9 +566,12 @@ static Int p_show_statistics_table( USES_REGS1 ) {
IOSTREAM *out;
Term mod, t;
tab_ent_ptr tab_ent;
Term t1 = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t1) || !IsAtomTerm(t1))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t1))))
return FALSE;
mod = Deref(ARG2);
t = Deref(ARG3);
if (IsAtomTerm(t))
@@ -580,9 +595,12 @@ static Int p_show_statistics_tabling( USES_REGS1 ) {
long total_pages = 0;
#endif /* USE_PAGES_MALLOC */
IOSTREAM *out;
Term t = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t))))
return FALSE;
bytes = 0;
Sfprintf(out, "Execution data structures\n");
stats = show_statistics_table_entries(out);
@@ -636,9 +654,12 @@ static Int p_show_statistics_tabling( USES_REGS1 ) {
static Int p_show_statistics_global_trie( USES_REGS1 ) {
IOSTREAM *out;
Term t = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t))))
return FALSE;
show_global_trie(SHOW_MODE_STATISTICS, out);
PL_release_stream(out);
return (TRUE);
@@ -765,9 +786,12 @@ static Int p_show_statistics_or( USES_REGS1 ) {
long total_pages = 0;
#endif /* USE_PAGES_MALLOC */
IOSTREAM *out;
Term t = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t))))
return FALSE;
bytes = 0;
Sfprintf(out, "Execution data structures\n");
stats = show_statistics_or_frames(out);
@@ -808,10 +832,12 @@ static Int p_show_statistics_opt( USES_REGS1 ) {
#ifdef USE_PAGES_MALLOC
long total_pages = 0;
#endif /* USE_PAGES_MALLOC */
IOSTREAM *out;
Term t = Deref(ARG1);
if (!PL_get_stream_handle(Yap_InitSlot(Deref(ARG1) PASS_REGS), &out))
return (FALSE);
if (IsVarTerm(t) || !IsAtomTerm(t))
return FALSE;
if (!(out = Yap_GetStreamHandle(AtomOfTerm(t))))
return FALSE;
bytes = 0;
Sfprintf(out, "Execution data structures\n");
stats = show_statistics_table_entries(out);

4
OPTYap/tab.tries.c
View File

@@ -1068,7 +1068,7 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
RESET_VARIABLE(t);
}
sg_fr_ptr *sg_fr_end = get_insert_subgoal_frame_addr(current_sg_node PASS_REGS);
volatile sg_fr_ptr *sg_fr_end = get_insert_subgoal_frame_addr(current_sg_node PASS_REGS);
#ifndef THREADS
LOCK_SUBGOAL_NODE(current_sg_node);
#endif /* !THREADS */
@@ -1087,7 +1087,7 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
TAG_AS_SUBGOAL_LEAF_NODE(current_sg_node);
UNLOCK_SUBGOAL_NODE(current_sg_node);
#else /* THREADS_FULL_SHARING || THREADS_CONSUMER_SHARING */
sg_ent_ptr sg_ent = (sg_ent_ptr) TrNode_sg_ent(current_sg_node);
sg_ent_ptr sg_ent = (sg_ent_ptr) UNTAG_SUBGOAL_NODE(TrNode_sg_ent(current_sg_node));
new_subgoal_frame(sg_fr, sg_ent);
#ifdef THREADS_CONSUMER_SHARING
SgFr_state(sg_fr) = ready_external;

32
configure vendored
View File

@@ -623,8 +623,8 @@ ENABLE_WINCONSOLE
STATIC_MODE
MAX_WORKERS
LAMOBJS
JAVAINCPATH
JAVALIBPATH
JAVACFLAGS
JAVALIBS
INSTALLCLP
INSTALL_COMMAND
MPI_LIBS
@@ -4823,7 +4823,7 @@ if test "${with_lam+set}" = set; then :
CPPFLAGS="$CPPFLAGS -I${yap_cv_lam}/include"
fi
else
yap_cv_lam=yes
yap_cv_lam=no
fi
@@ -6716,27 +6716,27 @@ elif test -e "$srcdir"/packages/jpl/Makefile.in; then
case "$target_os" in
*cygwin*|*mingw*)
if test $threads = yes; then
JAVALIBPATH="\"$JAVA_HOME\"/lib/jvm.lib -lpthread"
JAVALIBS="\"$JAVA_HOME\"/lib/jvm.lib -lpthread"
else
JAVALIBPATH="\"$JAVA_HOME\"/lib/jvm.lib"
JAVALIBS="\"$JAVA_HOME\"/lib/jvm.lib"
fi
JAVAINCPATH="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/win32"
JAVACFLAGS="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/win32"
;;
*darwin*)
LIBS="$LIBS -framework JavaVM"
JAVALIBPATH="-L/System/Library/Frameworks/JavaVM.framework/Libraries -Wl,-framework,JavaVM"
JAVAINCPATH="-I/System/Library/Frameworks/JavaVM.framework/Headers"
JAVALIBS="-L/System/Library/Frameworks/JavaVM.framework/Libraries -Wl,-framework,JavaVM"
JAVACFLAGS="-I/System/Library/Frameworks/JavaVM.framework/Headers"
;;
*)
case "$target_os" in
*linux*)
JAVAINCPATH="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/linux"
JAVACFLAGS="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/linux"
;;
*solaris*)
JAVAINCPATH="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/solaris"
JAVACFLAGS="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/solaris"
;;
esac
JAVALIBPATH="-L$JAVA_HOME/jre/lib/$YAP_TARGET -L$JAVA_HOME/jre/lib/$YAP_TARGET/client -L$JAVA_HOME/jre/lib/$YAP_TARGET/server -Wl,-R,$JAVA_HOME/jre/lib/$YAP_TARGET -ljava -lverify -ljvm "
JAVALIBS="-L$JAVA_HOME/jre/lib/$YAP_TARGET -L$JAVA_HOME/jre/lib/$YAP_TARGET/client -L$JAVA_HOME/jre/lib/$YAP_TARGET/server -Wl,-R,$JAVA_HOME/jre/lib/$YAP_TARGET -ljava -lverify -ljvm "
;;
esac
if test "$yap_cv_java" = ""; then
@@ -9738,8 +9738,8 @@ else
fi
if test "$IN_UNIX" = ""; then
CLIB_TARGETS="unix.$SO $CLIB_TARGETS"
CLIB_PLTARGETS="unix.pl $CLIB_PLTARGETS"
CLIB_TARGETS="uid.$SO unix.$SO $CLIB_TARGETS"
CLIB_PLTARGETS="uid.pl unix.pl $CLIB_PLTARGETS"
CLIB_NETLIBS=
else
ac_fn_c_check_func "$LINENO" "socket" "ac_cv_func_socket"
@@ -10127,6 +10127,8 @@ mkdir -p packages/cplint/approx
mkdir -p packages/cplint/approx/simplecuddLPADs
mkdir -p packages/http
mkdir -p packages/jpl
mkdir -p packages/jpl/src
mkdir -p packages/jpl/src/c
mkdir -p packages/jpl/src/java
mkdir -p packages/jpl/src/java/jpl
mkdir -p packages/jpl/src/java/jpl/fli
@@ -10153,6 +10155,7 @@ mkdir -p packages/RDF
mkdir -p packages/real
mkdir -p packages/semweb
mkdir -p packages/sgml
mkdir -p packages/xml
mkdir -p packages/zlib
ac_config_files="$ac_config_files Makefile"
@@ -10199,6 +10202,8 @@ ac_config_files="$ac_config_files packages/cplint/slipcase/Makefile"
ac_config_files="$ac_config_files packages/meld/Makefile"
ac_config_files="$ac_config_files packages/xml/Makefile"
ac_config_files="$ac_config_files packages/ProbLog/Makefile"
@@ -11012,6 +11017,7 @@ do
"packages/cplint/approx/simplecuddLPADs/Makefile") CONFIG_FILES="$CONFIG_FILES packages/cplint/approx/simplecuddLPADs/Makefile" ;;
"packages/cplint/slipcase/Makefile") CONFIG_FILES="$CONFIG_FILES packages/cplint/slipcase/Makefile" ;;
"packages/meld/Makefile") CONFIG_FILES="$CONFIG_FILES packages/meld/Makefile" ;;
"packages/xml/Makefile") CONFIG_FILES="$CONFIG_FILES packages/xml/Makefile" ;;
"packages/ProbLog/Makefile") CONFIG_FILES="$CONFIG_FILES packages/ProbLog/Makefile" ;;
"packages/chr/Makefile") CONFIG_FILES="$CONFIG_FILES packages/chr/Makefile" ;;
"packages/clib/Makefile") CONFIG_FILES="$CONFIG_FILES packages/clib/Makefile" ;;

30
configure.in
View File

@@ -392,7 +392,7 @@ AC_ARG_WITH(lam,
LDFLAGS="$LDFLAGS -L${yap_cv_lam}/lib"
CPPFLAGS="$CPPFLAGS -I${yap_cv_lam}/include"
fi,
[yap_cv_lam=yes])
[yap_cv_lam=no])
AC_ARG_WITH(heap-space,
[ --with-heap-space[=space] default heap size in Kbytes],
@@ -984,27 +984,27 @@ elif test -e "$srcdir"/packages/jpl/Makefile.in; then
case "$target_os" in
*cygwin*|*mingw*)
if test $threads = yes; then
JAVALIBPATH="\"$JAVA_HOME\"/lib/jvm.lib -lpthread"
JAVALIBS="\"$JAVA_HOME\"/lib/jvm.lib -lpthread"
else
JAVALIBPATH="\"$JAVA_HOME\"/lib/jvm.lib"
JAVALIBS="\"$JAVA_HOME\"/lib/jvm.lib"
fi
JAVAINCPATH="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/win32"
JAVACFLAGS="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/win32"
;;
*darwin*)
LIBS="$LIBS -framework JavaVM"
JAVALIBPATH="-L/System/Library/Frameworks/JavaVM.framework/Libraries -Wl,-framework,JavaVM"
JAVAINCPATH="-I/System/Library/Frameworks/JavaVM.framework/Headers"
JAVALIBS="-L/System/Library/Frameworks/JavaVM.framework/Libraries -Wl,-framework,JavaVM"
JAVACFLAGS="-I/System/Library/Frameworks/JavaVM.framework/Headers"
;;
*)
case "$target_os" in
*linux*)
JAVAINCPATH="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/linux"
JAVACFLAGS="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/linux"
;;
*solaris*)
JAVAINCPATH="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/solaris"
JAVACFLAGS="-I\"$JAVA_HOME\"/include -I\"$JAVA_HOME\"/include/solaris"
;;
esac
JAVALIBPATH="-L$JAVA_HOME/jre/lib/$YAP_TARGET -L$JAVA_HOME/jre/lib/$YAP_TARGET/client -L$JAVA_HOME/jre/lib/$YAP_TARGET/server -Wl,-R,$JAVA_HOME/jre/lib/$YAP_TARGET -ljava -lverify -ljvm "
JAVALIBS="-L$JAVA_HOME/jre/lib/$YAP_TARGET -L$JAVA_HOME/jre/lib/$YAP_TARGET/client -L$JAVA_HOME/jre/lib/$YAP_TARGET/server -Wl,-R,$JAVA_HOME/jre/lib/$YAP_TARGET -ljava -lverify -ljvm "
;;
esac
if test "$yap_cv_java" = ""; then
@@ -1757,8 +1757,8 @@ AC_SUBST(MPI_OBJS)
AC_SUBST(MPI_LIBS)
AC_SUBST(INSTALL_COMMAND)
AC_SUBST(INSTALLCLP)
AC_SUBST(JAVALIBPATH)
AC_SUBST(JAVAINCPATH)
AC_SUBST(JAVALIBS)
AC_SUBST(JAVACFLAGS)
AC_SUBST(LAMOBJS)
AC_SUBST(MAX_WORKERS)
AC_SUBST(STATIC_MODE)
@@ -2110,8 +2110,8 @@ else
fi
if test "$IN_UNIX" = ""; then
CLIB_TARGETS="unix.$SO $CLIB_TARGETS"
CLIB_PLTARGETS="unix.pl $CLIB_PLTARGETS"
CLIB_TARGETS="uid.$SO unix.$SO $CLIB_TARGETS"
CLIB_PLTARGETS="uid.pl unix.pl $CLIB_PLTARGETS"
CLIB_NETLIBS=
else
AC_CHECK_FUNC(socket, [], [
@@ -2261,6 +2261,8 @@ mkdir -p packages/cplint/approx
mkdir -p packages/cplint/approx/simplecuddLPADs
mkdir -p packages/http
mkdir -p packages/jpl
mkdir -p packages/jpl/src
mkdir -p packages/jpl/src/c
mkdir -p packages/jpl/src/java
mkdir -p packages/jpl/src/java/jpl
mkdir -p packages/jpl/src/java/jpl/fli
@@ -2287,6 +2289,7 @@ mkdir -p packages/RDF
mkdir -p packages/real
mkdir -p packages/semweb
mkdir -p packages/sgml
mkdir -p packages/xml
mkdir -p packages/zlib
AC_CONFIG_FILES([Makefile])
@@ -2311,6 +2314,7 @@ AC_CONFIG_FILES([packages/cplint/Makefile])
AC_CONFIG_FILES([packages/cplint/approx/simplecuddLPADs/Makefile])
AC_CONFIG_FILES([packages/cplint/slipcase/Makefile])
AC_CONFIG_FILES([packages/meld/Makefile])
AC_CONFIG_FILES([packages/xml/Makefile])
AC_CONFIG_FILES([packages/ProbLog/Makefile ])
if test "$ENABLE_CHR" = ""; then

24
docs/yap.tex
View File

@@ -2309,6 +2309,25 @@ file into a module which is not the working one, prefix the file name
with the module name, in the form @code{@var{Module}:@var{File}}, when
loading the file.
@item export(+@var{PredicateIndicator})
@findex export/1
@snindex export/1
@cnindex export/1
Add predicates to the public list of the context module. This implies
the predicate will be imported into another module if this module is
imported with @code{use_module/[1,2]}. Note that predicates are normally
exported using the directive @code{module/2}. @code{export/1} is meant
to handle export from dynamically created modules.
@item export_list(?@var{Mod},?@var{ListOfPredicateIndicator})
@findex export_list/2
@snindex export_list/2
@cnindex export_list/2
The list @var{ListOfPredicateIndicator} contains all predicates exported
by module @var{Mod}.
@end table
@node Using Modules, Meta-Predicates in Modules, Defining Modules, Modules
@@ -8119,6 +8138,11 @@ architecture.
Read or set the size of the hash table that is used for looking up the
blackboard when the key is an integer.
@item occurs_check
@findex occurs_check (yap_flag/2 option)
@*
Current read-only and set to @code{false}.
@item n_of_integer_keys_in_db
@findex n_of_integer_keys_in_db (yap_flag/2 option)
@*

3
library/Makefile.in
View File

@@ -97,7 +97,8 @@ DIALECT_PROGRAMS= \
DIALECT_SWI= \
$(srcdir)/dialect/swi/INDEX.pl \
$(srcdir)/dialect/swi/listing.pl
$(srcdir)/dialect/swi/listing.pl \
$(srcdir)/dialect/swi/syspred_options.pl
DIALECT_BP= \
$(srcdir)/dialect/bprolog/actionrules.pl \

10
library/dialect/swi/fli/swi.c
View File

@@ -207,16 +207,16 @@ X_API int _PL_get_arg(int index, term_t ts, term_t a)
if ( !YAP_IsApplTerm(t) ) {
if (YAP_IsPairTerm(t)) {
if (index == 1){
Yap_PutInSlot(a,YAP_HeadOfTerm(t) PASS_REGS);
Yap_PutInSlot(a,HeadOfTerm(t) PASS_REGS);
return 1;
} else if (index == 2) {
Yap_PutInSlot(a,YAP_TailOfTerm(t) PASS_REGS);
Yap_PutInSlot(a,TailOfTerm(t) PASS_REGS);
return 1;
}
}
return 0;
}
Yap_PutInSlot(a,YAP_ArgOfTerm(index, t) PASS_REGS);
Yap_PutInSlot(a,ArgOfTerm(index, t) PASS_REGS);
return 1;
}
@@ -585,9 +585,9 @@ X_API int PL_get_pointer(term_t ts, void **i)
{
CACHE_REGS
YAP_Term t = Yap_GetFromSlot(ts PASS_REGS);
if (!YAP_IsIntTerm(t) )
if (IsVarTerm(t) || !IsIntegerTerm(t) )
return 0;
*i = (void *)YAP_IntOfTerm(t);
*i = (void *)IntegerOfTerm(t);
return 1;
}

163
library/dialect/swi/syspred_options.pl Normal file
View File

@@ -0,0 +1,163 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2011, VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_system_predicate_options, []).
:- use_module(library(predicate_options)).
/** <module> Provide declarations for options to built-in predicates
*/
:- predicate_options(system:open/4, 4,
[ type(oneof([text,binary])),
alias(atom),
encoding(encoding),
bom(boolean),
eof_action(oneof([eof_code,error,reset])),
buffer(oneof([full,line,false])),
close_on_abort(boolean),
lock(oneof([none,read,shared,write,exclusive])),
wait(boolean)
]).
:- predicate_options(system:write_term/3, 3,
[ attributes(oneof([ignore,dots,write,portray])),
backquoted_string(boolean),
blobs(oneof([portray])),
character_escapes(boolean),
cycles(boolean),
ignore_ops(boolean),
max_depth(nonneg),
module(atom),
numbervars(boolean),
partial(boolean),
portray(boolean),
portray_goal(callable+2), % as in meta_predicate
priority(between(0,1200)),
quoted(boolean),
spacing(oneof([standard,next_argument]))
]).
:- predicate_options(system:write_term/2, 2,
[ pass_to(system:write_term/3, 3)
]).
:- predicate_options(system:write_length/3, 3,
[ max_length(nonneg),
pass_to(system:write_term/3, 3)
]).
:- predicate_options(system:read_term/3, 3,
[ backquoted_string(boolean),
character_escapes(boolean),
comments(-any),
cycles(boolean),
double_quotes(boolean),
module(atom),
singletons(-list),
syntax_errors(oneof([error,fail,quiet,dec10])),
subterm_positions(-any),
term_position(-any),
variables(-list),
variable_names(-list)
]).
:- predicate_options(system:read_term/2, 2,
[ pass_to(system:read_term/3, 3)
]).
:- predicate_options(system:numbervars/4, 4,
[ functor_name(atom),
attvar(oneof([skip,bind,error])),
singletons(boolean)
]).
:- predicate_options(system:absolute_file_name/3, 3,
[ extensions(list(atom)),
relative_to(atom),
access(oneof([read,write,append,execute,exist,none])),
file_type(oneof([txt,prolog,executable,directory])),
file_errors(oneof([fail,error])),
solutions(oneof([first,all])),
expand(boolean)
]).
:- predicate_options(system:load_files/2, 2,
[ autoload(boolean),
derived_from(atom),
encoding(encoding),
expand(boolean),
format(oneof([source,qlf])),
if(oneof([true,changed,not_loaded])),
imports(any),
modified(float),
must_be_module(boolean),
qcompile(oneof([never,auto,large,part])),
redefine_module(oneof([false,true,ask])),
reexport(boolean),
silent(boolean),
stream(any)
]).
:- predicate_options(system:qcompile/2, 2,
[ pass_to(system:load_files/2, 2)
]).
:- predicate_options(system:close/2, 2,
[ force(boolean)
]).
:- predicate_options(system:create_prolog_flag/3, 3,
[ access(oneof([read_write,read_only])),
type(oneof([boolean,atom,integer,float,term]))
]).
:- predicate_options(system:qsave_program/2, 2,
[ local(nonneg),
global(nonneg),
trail(nonneg),
argument(nonneg),
goal(callable),
toplevel(callable),
init_file(atom),
class(oneof([runtime,kernel,development])),
autoload(boolean),
map(atom),
op(oneof([save,standard])),
stand_alone(boolean),
emulator(atom)
]).
:- predicate_options(system:thread_create/3, 3,
[ alias(atom),
at_exit(callable),
detached(boolean),
global(nonneg),
local(nonneg),
c_stack(nonneg),
trail(nonneg)
]).
:- predicate_options(system:message_queue_create/2, 2,
[ alias(atom),
max_size(nonneg)
]).
:- predicate_options(system:mutex_create/2, 2,
[ alias(atom)
]).
:- predicate_options(system:thread_get_message/3, 3,
[ timeout(float)
]).

19
library/random.yap
View File

@@ -31,6 +31,11 @@
setrand/1
]).
:- use_module(library(pairs)).
:- use_module(library(error)).
:- use_module(library(lists)).
:- load_foreign_files([yap_random], [], init_random).
@@ -40,13 +45,17 @@
% when L and U are integers (note that U will NEVER be generated),
% or to a random floating number in [L,U) otherwise.
random(L, U, R) :- integer(L), integer(U), !,
random(X),
R is L+integer((U-L)*X).
random(L, U, R) :-
number(L), number(U), !,
( integer(L), integer(U) ->
U > L,
random(X),
R is L+((U-L)*X).
R is L+integer((U-L)*X)
;
number(L), number(U),
U > L,
random(X),
R is L+((U-L)*X)
).
/* There are two versions of this operation.

1
misc/ATOMS
View File

@@ -277,6 +277,7 @@ A StartupSavedState F "$startup_saved_state"
A StaticClause F "$static_clause"
A StaticProcedure N "static_procedure"
A Stream F "$stream"
A SWIStream F "<stream>"
A VStream N "stream"
A Streams N "streams"
A StreamOrAlias N "stream_or_alias"

2
misc/Yap.spec
View File

@@ -3,7 +3,7 @@
Name: yap
Summary: Prolog Compiler
Version: 6.3.1
Version: 6.3.2
Packager: Vitor Santos Costa <vsc@dcc.fc.up.pt>
Release: 1
Source: http://www.dcc.fc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz

2
misc/Yap64.spec
View File

@@ -3,7 +3,7 @@
Name: yap
Summary: Prolog Compiler
Version: 6.3.1
Version: 6.3.2
Packager: Vitor Santos Costa <vsc@dcc.fc.up.pt>
Release: 1
Source: http://www.dcc.fc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz

2
misc/yap.nsi
View File

@@ -273,4 +273,4 @@ Function .onInstFailed
installer, please contact yap-users@sf.net"
FunctionEnd
outfile "yap-6.3.1-installer.exe"
outfile "yap-6.3.2-installer.exe"

2
misc/yap64.nsi
View File

@@ -270,4 +270,4 @@ Function .onInstFailed
installer, please contact yap-users@sf.net"
FunctionEnd
outfile "yap64-6.3.1-installer.exe"
outfile "yap64-6.3.2-installer.exe"

59
os/pl-file.c
View File

@@ -636,7 +636,6 @@ PL_get_stream_handle(term_t t, IOSTREAM **s)
return term_stream_handle(t, s, SH_ERRORS|SH_ALIAS PASS_LD);
}
static int
unify_stream_ref(term_t t, IOSTREAM *s)
{ GET_LD
@@ -4672,6 +4671,64 @@ EndPredDefs
#if __YAP_PROLOG__
void *
Yap_GetStreamHandle(Atom at)
{ GET_LD
atom_t a;
IOSTREAM *s;
a = YAP_SWIAtomFromAtom(at);
if (!get_stream_handle(a, &s, SH_ERRORS|SH_ALIAS))
return NULL;
return s;
}
void *Yap_GetInputStream(Atom at)
{ GET_LD
atom_t a;
IOSTREAM *s;
if ( at == AtomUser ) {
if ( (s = getStream(Suser_input)) )
return s;
return NULL;
}
a = YAP_SWIAtomFromAtom(at);
if ( !get_stream_handle(a, &s, SH_ERRORS|SH_ALIAS|SH_INPUT) )
return NULL;
if ( !(s->flags &SIO_INPUT) )
{ releaseStream(s);
return Yap_Error(PERMISSION_ERROR_INPUT_STREAM, MkAtomTerm(at),
"read or ql");
return NULL;
}
return s;
}
void *Yap_GetOutputStream(Atom at)
{ GET_LD
atom_t a;
IOSTREAM *s;
if ( at == AtomUser ) {
if ( (s = getStream(Suser_output)) )
return s;
return NULL;
}
a = YAP_SWIAtomFromAtom(at);
if ( !get_stream_handle(a, &s, SH_ERRORS|SH_ALIAS|SH_OUTPUT) )
return NULL;
if ( !(s->flags &SIO_OUTPUT) )
{ releaseStream(s);
return Yap_Error(PERMISSION_ERROR_OUTPUT_STREAM, MkAtomTerm(at),
"write or ql");
return NULL;
}
return s;
}
static int
pl_get_time(term_t t)
{ return PL_unify_float(t, WallTime());

1291
os/pl-write.c
View File

File diff suppressed because it is too large Load Diff

7
packages/Dialect.defs.in
View File

@@ -24,7 +24,8 @@ PLINCL=$(PLBASE)/include
PLLIBDIR=$(PLBASE)/share/Yap
SOLIBDIR=$(PLBASE)/lib/Yap
PKGDOCDIR=$(PLBASE)/share/doc/Yap/packages
PKGEXDIR=$(PLBASE)/share/doc/Yap//packages/examples
PKGEXDIR=$(PLBASE)/share/doc/Yap/packages/examples
XPCEBASE=$(PLBASE)/xpce
#
# YAP internal stuff
@@ -53,11 +54,11 @@ LDFLAGS=$(PKGLDFLAGS)
MKINDEX=(cd $(srcdir) ; $(PL) -f none -g make -t halt)
.txt.tex:
swipl -f script.pl -g "doc_latex('$*.txt','$*.tex',[stand_alone(false)]),halt" -t "halt(1)"
$(PUBLICPL) -L $(SHAREDIR)/doc_latex -g "doc_latex('$*.txt','$*.tex',[stand_alone(false)]),halt" -t "halt(1)"
PUBLICPL=$(PL)
PLTOTEX=$(PUBLICPL) -q -l $(srcdir)/pltotex.pl -g pltotex --
PLTOTEX=$(PUBLICPL) -q -l $(srcdir)/pltotex -g pltotex --
#
# find out how to generate .o files from $(scrdir)

8
packages/Makefile.defs.in
View File

@@ -57,12 +57,18 @@ $(PDF): $(TEX)
$(DOC2TEX) $< > $@
%.tex : $(srcdir)/%.txt
$(PUBLICPL) -f none -g "doc_latex('$<','$@',[stand_alone(false)]),halt" -t "halt(1)"
$(PUBLICPL) -f $(PLLIBDIR)/doc_latex -g "doc_latex('$<','$@',[stand_alone(false)]),halt" -t "halt(1)"
%.tex : $(srcdir)/%.pl
$(PLTOTEX) $< > $@
# Get the Prolog dialect specific part of the Makefiles
LIBSRCPL=$(addprefix $(srcdir)/, $(LIBPL))
LIBSRCALL=$(addprefix $(srcdir)/, $(LIBALL))
SRCXPCEPL=$(addprefix $(srcdir)/, $(XPCEPL))
include ../Dialect.defs

2
packages/R

Submodule packages/R updated: a9c5837d21...8fced60cfb

2
packages/RDF

Submodule packages/RDF updated: ed9354de88...2d0bbe41cd

2
packages/chr

Submodule packages/chr updated: 59f3bce3c8...118e4bf761

2
packages/clib

Submodule packages/clib updated: e6b682d909...18e06cc6da

2
packages/clpqr

Submodule packages/clpqr updated: f71221999d...a05f9a19fa

2
packages/http

Submodule packages/http updated: b83111f016...c51532c21e

2
packages/jpl

Submodule packages/jpl updated: 4742393c91...5857584a3e

3
packages/meld/Makefile.in
View File

@@ -49,7 +49,8 @@ all:
install: $(PROGRAMS) $(EXAMPLES)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/meld
mkdir -p $(DESTDIR)$(SHAREDIR)/share/Yap/examples/meld
$(INSTALL_DATA) $(srcdir)/meld.yap $(DESTDIR)$(SHAREDIR)/Yap
for p in $(MELD_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/meld; done
for p in $(MELD_EXAMPLES); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/meld; done
for p in $(MELD_EXAMPLES); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/share/Yap/examples/meld; done

2
packages/pldoc

Submodule packages/pldoc updated: 504bef629e...d02a0bda23

2
packages/plunit

Submodule packages/plunit updated: c969e90cb0...b0fafe2051

2
packages/real

Submodule packages/real updated: f4c629b195...3db8d8e80f

2
packages/semweb

Submodule packages/semweb updated: 9c1ccd0d29...239e87f783

2
packages/sgml

Submodule packages/sgml updated: 27608a1fc2...5cf4dd8541

71
packages/xml/Makefile.in Normal file
View File

@@ -0,0 +1,71 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for binary libraries
#
LIBDIR=@libdir@/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
YAP_EXTRAS=@YAP_EXTRAS@
EXDIR=$(srcdir)/examples
XML_PROGRAMS= \
$(srcdir)/xml_acquisition.pl \
$(srcdir)/xml_diagnosis.pl \
$(srcdir)/xml_driver.pl \
$(srcdir)/xml_generation.pl \
$(srcdir)/xml.iso.pl \
$(srcdir)/xml_pp.pl \
$(srcdir)/xml_utilities.pl
XML_EXAMPLES= \
$(srcdir)/xml_example/bib.xml \
$(srcdir)/xml_example/books.xml \
$(srcdir)/xml_example/misc.pl \
$(srcdir)/xml_example/prices.xml \
$(srcdir)/xml_example/q1.xml \
$(srcdir)/xml_example/q2.xml \
$(srcdir)/xml_example/q3.xml \
$(srcdir)/xml_example/q4.xml \
$(srcdir)/xml_example/q5.xml \
$(srcdir)/xml_example/q6.xml \
$(srcdir)/xml_example/q7.xml \
$(srcdir)/xml_example/q8.xml \
$(srcdir)/xml_example/q9.xml \
$(srcdir)/xml_example/q10.xml \
$(srcdir)/xml_example/q11.xml \
$(srcdir)/xml_example/q12.xml \
$(srcdir)/xml_example/reviews.xml \
$(srcdir)/xml_example/xml_example.pl
PROGRAMS= \
$(srcdir)/xml.pl \
$(XML_PROGRAMS)
all:
install: $(PROGRAMS) $(EXAMPLES)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/xml
mkdir -p $(DESTDIR)$(SHAREDIR)/doc/Yap/examples/xml
$(INSTALL_DATA) $(srcdir)/xml.pl $(DESTDIR)$(SHAREDIR)/Yap
for p in $(XML_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/xml; done
for p in $(XML_EXAMPLES); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/doc/Yap/examples/xml; done

78
packages/xml/xml.iso.pl Normal file
View File

@@ -0,0 +1,78 @@
/* xml.iso.pl : Wrapper for ISO Prolog.
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.3 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*
*/
:- module( xml,
[
xml_parse/2,
xml_parse/3,
xml_subterm/2,
xml_pp/1
] ).
/* xml is intended to be a rather modular module: it should be easy to
* build a program that can output XML, but not read it, or vice versa.
* Similarly, you may be happy to dispense with diagnosis once you are
* sure that your code will only try to make valid calls to xml_parse/2.
*
* It is intended that the code should be very portable too. Clearly,
* some small changes will be needed between platforms, but these should
* be limited to xml_utilities. xml_utilities contains most of the shared
* code and most of the potentially non-portable code.
*/
:- ensure_loaded( xml_driver ).
/* xml_exception( +Message, +Document, +Culprit, +Path ) is a hook to
* raise an exception to be raised in respect of a fault in the XML Term:
* Document.
* - Culprit is a sub-term of Document which cannot be serialized;
* - Message is an atom naming the type of error;

62
packages/xml/xml.lpa.pl Normal file
View File

@@ -0,0 +1,62 @@
/* xml.lpa.pl : Wrapper for LPA Prolog.
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.3 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*
* xml is intended to be a rather modular module: it should be easy to
* build a program that can output XML, but not read it, or vice versa.
* Similarly, you may be happy to dispense with diagnosis once you are
* sure that your code will only try to make valid calls to xml_parse/2.
*
* It is intended that the code should be very portable too. Clearly,
* some small changes will be needed between platforms, but these should
* be limited to xml_utilities. xml_utilities contains most of the shared
* code and most of the potentially non-portable code.
*/
:- ensure_loaded( xml_driver ).
/* atom_codes/2, number_codes/2 and throw/1 are ISO predicates, mapped to
* the Quintus equivalent here.
*/
atom_codes( Atom, Codes ) :-
atom_chars( Atom, Codes ).

86
packages/xml/xml.pl Normal file
View File

@@ -0,0 +1,86 @@
/* xml.pl : XML Module wrapper for Quintus Prolog.
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.3 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*
*/
:- module( xml,
[
xml_parse/2,
xml_parse/3,
xml_subterm/2,
xml_pp/1
] ).
/* xml is intended to be a rather modular module: it should be easy to
* build a program that can output XML, but not read it, or vice versa.
* Similarly, you may be happy to dispense with diagnosis once you are
* sure that your code will only try to make valid calls to xml_parse/2.
*
* It is intended that the code should be very portable too. Clearly,
* some small changes will be needed between platforms, but these should
* be limited to xml_utilities. xml_utilities contains most of the shared
* code and most of the potentially non-portable code.
*/
:- use_module( library(lists), [append/3] ).
:- ensure_loaded( xml/xml_driver ).
/* atom_codes/2, number_codes/2 and throw/1 are ISO predicates, mapped to
* the Quintus equivalent here.
*/
%atom_codes( Atom, Codes ) :-
% atom_chars( Atom, Codes ).

1117
packages/xml/xml_acquisition.pl Normal file
View File

File diff suppressed because it is too large Load Diff

84
packages/xml/xml_diagnosis.pl Normal file
View File

@@ -0,0 +1,84 @@
/* xml_diagnosis.pl : XML exception diagnosis.
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.3 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*/
:- ensure_loaded( xml_generation ).
/* xml_fault( +Term, +Indentation, ?SubTerm, ?Path, ?Message ) identifies SubTerm
* as a sub-term of Term which cannot be serialized after Indentation.
* Message is an atom naming the type of error; Path is a string encoding a
* list of SubTerm's ancestor elements in the form <tag>{(id)}* where <tag> is the
* element tag and <id> is the value of any attribute _named_ id.
*/
xml_fault( Term, _Indent, Term, [], "Illegal Variable" ) :-
var( Term ).
xml_fault( xml(Attributes,_Content), _Indent, Term, [], Message ) :-
member( Attribute, Attributes ),
attribute_fault( Attribute, Term, Message ).
xml_fault( xml(_Attributes,Content), Indent, Culprit, Path, Message ) :-
xml_content_fault( Content, Indent, Culprit, Path, Message ).
xml_fault( Term, _Indent, Term, [], "Illegal Term" ).
xml_content_fault( Term, _Indent, Term, [], "Illegal Variable" ) :-
var( Term ).
xml_content_fault( pcdata(Chars), _Indent, Chars, [], "Invalid Character Data" ) :-
\+ is_chars( Chars ).
xml_content_fault( cdata(Chars), _Indent, Chars, [], "Invalid Character Data" ) :-
\+ is_chars( Chars ).
xml_content_fault( [H|_T], Indent, Culprit, Path, Message ) :-
xml_content_fault( H, Indent, Culprit, Path, Message ).
xml_content_fault( [_H|T], Indent, Culprit, Path, Message ) :-
xml_content_fault( T, Indent, Culprit, Path, Message ).
xml_content_fault( namespace(_URI,_Prefix,Element), Indent, Culprit, Path, Message ) :-

131
packages/xml/xml_driver.pl Normal file
View File

@@ -0,0 +1,131 @@
/* xml_driver.pl : Contains xml_parse/[2,3] a bi-directional XML parser written in
* Prolog.
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.3 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*
* xml_parse( {+Controls}, +?Chars, ?+Document ) parses Chars to/from a data
* structure of the form xml(<atts>, <content>). <atts> is a list of
* <atom>=<string> attributes from the (possibly implicit) XML signature of the
* document. <content> is a (possibly empty) list comprising occurrences of :
*
* pcdata(<string>) : Text
* comment(<string>) : An xml comment;
* element(<tag>,<atts>,<content>) : <tag>..</tag> encloses <content>
* : <tag /> if empty
* instructions(<atom>, <string>) : Processing <? <atom> <params> ?>"
* cdata( <string> ) : <![CDATA[ <string> ]]>
* doctype(<atom>, <doctype id>) : DTD <!DOCTYPE .. >
*
* The conversions are not completely symmetrical, in that weaker XML is
* accepted than can be generated. Specifically, in-bound (Chars -> Document)
* does not require strictly well-formed XML. Document is instantiated to the
* term malformed(Attributes, Content) if Chars does not represent well-formed
* XML. The Content of a malformed/2 structure can contain:
*
* unparsed( <string> ) : Text which has not been parsed
* out_of_context( <tag> ) : <tag> is not closed
*
* in addition to the standard term types.
*
* Out-bound (Document -> Chars) parsing _does_ require that Document defines
* strictly well-formed XML. If an error is detected a 'domain' exception is
* raised.
*
* The domain exception will attempt to identify the particular sub-term in
* error and the message will show a list of its ancestor elements in the form
* <tag>{(id)}* where <id> is the value of any attribute _named_ id.
*
* At this release, the Controls applying to in-bound (Chars -> Document)
* parsing are:
*
* extended_characters(<bool>) : Use the extended character
* : entities for XHTML (default true)
*
* format(<bool>) : Strip layouts when no character data
* : appears between elements.
* : (default true)
*
* remove_attribute_prefixes(<bool>) : Remove namespace prefixes from
* : attributes when it's the same as the
* : prefix of the parent element
* : (default false).
*
* allow_ampersand(<bool>) : Allow unescaped ampersand
* : characters (&) to occur in PCDATA.
* : (default false).
*
* [<bool> is one of 'true' or 'false']

36
packages/xml/xml_example/bib.xml Normal file
View File

@@ -0,0 +1,36 @@
<bib>
<book year="1994">
<title>TCP/IP Illustrated</title>
<author><last>Stevens</last><first>W.</first></author>
<publisher>Addison-Wesley</publisher>
<price> 65.95</price>
</book>
<book year="1992">
<title>Advanced Programming in the Unix environment</title>
<author><last>Stevens</last><first>W.</first></author>
<publisher>Addison-Wesley</publisher>
<price>65.95</price>
</book>
<book year="2000">
<title>Data on the Web</title>
<author><last>Abiteboul</last><first>Serge</first></author>
<author><last>Buneman</last><first>Peter</first></author>
<author><last>Suciu</last><first>Dan</first></author>
<publisher>Morgan Kaufmann Publishers</publisher>
<price>39.95</price>
</book>
<book year="1999">
<title>The Economics of Technology and Content for Digital TV</title>
<editor>
<last>Gerbarg</last><first>Darcy</first>
<affiliation>CITI</affiliation>
</editor>
<publisher>Kluwer Academic Publishers</publisher>
<price>129.95</price>
</book>
</bib>

15
packages/xml/xml_example/books.xml Normal file
View File

@@ -0,0 +1,15 @@
<chapter>
<title>Data Model</title>
<section>
<title>Syntax For Data Model</title>
</section>
<section>
<title>XML</title>
<section>
<title>Basic Syntax</title>
</section>
<section>
<title>XML and Semistructured Data</title>
</section>
</section>
</chapter>

95
packages/xml/xml_example/misc.pl Normal file
View File

@@ -0,0 +1,95 @@
% Utility Predicates
% The following predicates are used in the puzzle solutions.
% unique_solution( +Goal ) holds when Goal has one ground solution. Operationally,
% Goal may produce several solutions, ("don't care" non-deterministically), but they
% must all be identical (==).
unique_solution( Goal ) :-
findall( Goal, Goal, [Solution|Solutions] ),
same_solution( Solutions, Solution ),
Solution = Goal.
same_solution( [], _Solution ).
same_solution( [Solution0|Solutions], Solution ) :-
Solution0 == Solution,
same_solution( Solutions, Solution ).
% forall( +Enumerator, +Test ) is true if Enumerator and Test are goals and Test holds everywhere
% that Enumerator does. NB: does not further instantiate arguments.
%% forall( Enumerator, Test ) :-
%% \+ (call(Enumerator), \+ call(Test)).
% member( ?Element, ?List ) holds when Element is a member of List.
member( H, [H|_] ).
member( H, [_|T] ):-
member( H, T ).
% select( ?Element, ?List0, ?List1 ) is true if List1 is equal to List1 with Element removed.
select( H, [H|T], T ).
select( Element, [H|T0], [H|T1] ):-
select( Element, T0, T1 ).
% memberchk( +Element, +List ) succeeds (once) if Element is a member of List.
memberchk( Element, List ):-
member( Element, List ),
!.
% between( +Lower, +Upper, ?Index ) is true if Lower =< Index =< Upper. Two valid cases are
% possible:
% - Index is already instantiated to an integer so the checks on order are applied (test).
% - Index is a logical variable so a series of alternative solutions is generated as the
% monotonic sequence of values between Lower and Upper (non-deterministic generator).
%% between( Lower, Upper, Index ):-
%% integer( Lower ),
%% integer( Upper ),
%% Lower =< Upper,
%% ( integer( Index ) -> % Case 1: "test"
%% Index >= Lower,
%% Index =< Upper
%% ; var( Index ) -> % Case 2: "generate".
%% generate_between( Lower, Upper, Index )
%% ).
generate_between( Lower, Upper, Index ) :-
( Lower =:= Upper ->
Index = Lower
; Index = Lower
; Next is Lower + 1,
Next =< Upper,
generate_between( Next, Upper, Index )
).
% sum( +List, ?Sum ) holds when the List of numbers sum to Sum.
sum( [H|T], Sum ) :-
sum1( T, H, Sum ).
sum1( [], Sum, Sum ).
sum1( [H|T], Sum0, Sum ):-
Sum1 is Sum0 + H,
sum1( T, Sum1, Sum ).
% put_chars( +Chars ) if Chars is a (possibly empty) list of character codes and the
% corresponding characters are written to the current output stream.
put_chars( [] ).
put_chars( [Char|Chars] ) :-
put( Char ),
put_chars( Chars ).
% get_chars( ?Chars ) if Chars is a (possibly empty) list of character codes read
% from the current input stream.
get_chars( Input ) :-
get0( Char ),
( Char > -1 ->
Input = [Char|Chars],
get_chars( Chars )
; otherwise ->
Input = []
).

32
packages/xml/xml_example/prices.xml Normal file
View File

@@ -0,0 +1,32 @@
<prices>
<book>
<title>Advanced Programming in the Unix environment</title>
<source>www.amazon.com</source>
<price>65.95</price>
</book>
<book>
<title>Advanced Programming in the Unix environment</title>
<source>www.bn.com</source>
<price>65.95</price>
</book>
<book>
<title>TCP/IP Illustrated</title>
<source>www.amazon.com</source>
<price>65.95</price>
</book>
<book>
<title>TCP/IP Illustrated</title>
<source>www.bn.com</source>
<price>65.95</price>
</book>
<book>
<title>Data on the Web</title>
<source>www.amazon.com</source>
<price>34.95</price>
</book>
<book>
<title>Data on the Web</title>
<source>www.bn.com</source>
<price>39.95</price>
</book>
</prices>

9
packages/xml/xml_example/q1.xml Normal file
View File

@@ -0,0 +1,9 @@
<bib>
<book year="1994">
<title>TCP/IP Illustrated</title>
</book>
<book year="1992">
<title>Advanced Programming in the Unix environment</title>
</book>
</bib>

11
packages/xml/xml_example/q10.xml Normal file
View File

@@ -0,0 +1,11 @@
<results>
<minprice title="Advanced Programming in the Unix environment">
<price>65.95</price>
</minprice>
<minprice title="TCP/IP Illustrated">
<price>65.95</price>
</minprice>
<minprice title="Data on the Web">
<price>34.95</price>
</minprice>
</results>

35
packages/xml/xml_example/q11.xml Normal file
View File

@@ -0,0 +1,35 @@
<bib>
<book>
<title>TCP/IP Illustrated</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</book>
<book>
<title>Advanced Programming in the Unix environment</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</book>
<book>
<title>Data on the Web</title>
<author>
<last>Abiteboul</last>
<first>Serge</first>
</author>
<author>
<last>Buneman</last>
<first>Peter</first>
</author>
<author>
<last>Suciu</last>
<first>Dan</first>
</author>
</book>
<reference>
<title>The Economics of Technology and Content for Digital TV</title>
<affiliation>CITI</affiliation>
</reference>
</bib>

6
packages/xml/xml_example/q12.xml Normal file
View File

@@ -0,0 +1,6 @@
<bib>
<book-pair>
<title>TCP/IP Illustrated</title>
<title>Advanced Programming in the Unix environment</title>
</book-pair>
</bib>

37
packages/xml/xml_example/q2.xml Normal file
View File

@@ -0,0 +1,37 @@
<results>
<result>
<title>TCP/IP Illustrated</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</result>
<result>
<title>Advanced Programming in the Unix environment</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</result>
<result>
<title>Data on the Web</title>
<author>
<last>Abiteboul</last>
<first>Serge</first>
</author>
</result>
<result>
<title>Data on the Web</title>
<author>
<last>Buneman</last>
<first>Peter</first>
</author>
</result>
<result>
<title>Data on the Web</title>
<author>
<last>Suciu</last>
<first>Dan</first>
</author>
</result>
</results>

34
packages/xml/xml_example/q3.xml Normal file
View File

@@ -0,0 +1,34 @@
<results>
<result>
<title>TCP/IP Illustrated</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</result>
<result>
<title>Advanced Programming in the Unix environment</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</result>
<result>
<title>Data on the Web</title>
<author>
<last>Abiteboul</last>
<first>Serge</first>
</author>
<author>
<last>Buneman</last>
<first>Peter</first>
</author>
<author>
<last>Suciu</last>
<first>Dan</first>
</author>
</result>
<result>
<title>The Economics of Technology and Content for Digital TV</title>
</result>
</results>

31
packages/xml/xml_example/q4.xml Normal file
View File

@@ -0,0 +1,31 @@
<results>
<result>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
<title>TCP/IP Illustrated</title>
<title>Advanced Programming in the Unix environment</title>
</result>
<result>
<author>
<last>Abiteboul</last>
<first>Serge</first>
</author>
<title>Data on the Web</title>
</result>
<result>
<author>
<last>Buneman</last>
<first>Peter</first>
</author>
<title>Data on the Web</title>
</result>
<result>
<author>
<last>Suciu</last>
<first>Dan</first>
</author>
<title>Data on the Web</title>
</result>
</results>

18
packages/xml/xml_example/q5.xml Normal file
View File

@@ -0,0 +1,18 @@
<books-with-prices>
<book-with-prices>
<title>TCP/IP Illustrated</title>
<price-amazon>65.95</price-amazon>
<price-bn> 65.95</price-bn>
</book-with-prices>
<book-with-prices>
<title>Advanced Programming in the Unix environment</title>
<price-amazon>65.95</price-amazon>
<price-bn>65.95</price-bn>
</book-with-prices>
<book-with-prices>
<title>Data on the Web</title>
<price-amazon>34.95</price-amazon>
<price-bn>39.95</price-bn>
</book-with-prices>
</books-with-prices>

28
packages/xml/xml_example/q6.xml Normal file
View File

@@ -0,0 +1,28 @@
<bib>
<book>
<title>TCP/IP Illustrated</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</book>
<book>
<title>Advanced Programming in the Unix environment</title>
<author>
<last>Stevens</last>
<first>W.</first>
</author>
</book>
<book>
<title>Data on the Web</title>
<author>
<last>Abiteboul</last>
<first>Serge</first>
</author>
<author>
<last>Buneman</last>
<first>Peter</first>
</author>
<et-al/>
</book>
</bib>

9
packages/xml/xml_example/q7.xml Normal file
View File

@@ -0,0 +1,9 @@
<bib>
<book year="1992">
<title>Advanced Programming in the Unix environment</title>
</book>
<book year="1994">
<title>TCP/IP Illustrated</title>
</book>
</bib>

10
packages/xml/xml_example/q8.xml Normal file
View File

@@ -0,0 +1,10 @@
<bib>
<book>
<title>Data on the Web</title>
<author>
<last>Suciu</last>
<first>Dan</first>
</author>
</book>
</bib>

5
packages/xml/xml_example/q9.xml Normal file
View File

@@ -0,0 +1,5 @@
<results>
<title>XML</title>
<title>XML and Semistructured Data</title>
</results>

25
packages/xml/xml_example/reviews.xml Normal file
View File

@@ -0,0 +1,25 @@
<reviews>
<entry>
<title>Data on the Web</title>
<price>34.95</price>
<review>
A very good discussion of semi-structured database
systems and XML.
</review>
</entry>
<entry>
<title>Advanced Programming in the Unix environment</title>
<price>65.95</price>
<review>
A clear and detailed discussion of UNIX programming.
</review>
</entry>
<entry>
<title>TCP/IP Illustrated</title>
<price>65.95</price>
<review>
One of the best books on TCP/IP.
</review>
</entry>
</reviews>

388
packages/xml/xml_example/xml_example.pl Normal file
View File

@@ -0,0 +1,388 @@
/* Using xml.pl to solve XML Query Cases - An Example
*
* The following is a complete example to illustrate how the module can be used;
* it exercises both the input and output parsing modes of xml_parse/[2,3], and
* illustrates the use of xml_subterm/2 to access the nodes of a "document value
* model". It's written for Quintus Prolog, but should port to other Prologs
* easily.
*
* The entry-point of the program is the test/1 predicate.
*
* test( +QueryId ) executes a Prolog implementation of a Query from Use Case
* "XMP": Experiences and Exemplars, in the W3C's XML Query Use Cases, which
* "contains several example queries that illustrate requirements gathered from
* the database and document communities".
* <http://www.w3.org/TR/2002/WD-xmlquery-use-cases-20021115/#xmp>
*
* QueryId is one of q1<EFBFBD>q12 selecting which of the 12 use cases is executed.
* The XML output is written to the file [QueryId].xml in the current directory.
*
* xml_pp/1 is used to display the resulting "document value model"
% data-structures on the user output (stdout) stream.
*/
:- use_module(library(lists),[append/3]).
test( Query ) :-
xml_query( Query, ResultElement ),
% Parse output XML into the Output chars
xml_parse( Output, xml([], [ResultElement]) ),
absolute_file_name( Query, [extensions([xml])], OutputFile ),
% Write OutputFile from the Output list of chars
tell( OutputFile ),
put_chars( Output ),
told,
% Pretty print OutputXML
write( 'Output XML' ), nl,
xml_pp( xml([], [ResultElement]) ).
/* xml_query( +QueryNo, ?OutputXML ) when OutputXML is an XML Document Value Model
* produced by running an example taken, identified by QueryNo from the XML Query
* "XMP" use case.
*/
% Q1: List books published by Addison-Wesley after 1991, including their year and
% title.
xml_query( q1, element(bib, [], Books) ) :-
element_name( Title, title ),
element_name( Publisher, publisher ),
input_document( 'bib.xml', Bibliography ),
findall(
element(book, [year=Year], [Title]),
(
xml_subterm( Bibliography, element(book, Attributes, Content) ),
xml_subterm( Content, Publisher ),
xml_subterm( Publisher, Text ),
text_value( Text, "Addison-Wesley" ),
member( year=Year, Attributes ),
number_codes( YearNo, Year ),
YearNo > 1991,
xml_subterm( Content, Title )
),
Books
).
% Q2: Create a flat list of all the title-author pairs, with each pair enclosed
% in a "result" element.
xml_query( q2, element(results, [], Results) ) :-
element_name( Title, title ),
element_name( Author, author ),
element_name( Book, book ),
input_document( 'bib.xml', Bibliography ),
findall(
element(result, [], [Title,Author]),
(
xml_subterm( Bibliography, Book ),
xml_subterm( Book, Title ),
xml_subterm( Book, Author )
),
Results
).
% Q3: For each book in the bibliography, list the title and authors, grouped
% inside a "result" element.
xml_query( q3, element(results, [], Results) ) :-
element_name( Title, title ),
element_name( Author, author ),
element_name( Book, book ),
input_document( 'bib.xml', Bibliography ),
findall(
element(result, [], [Title|Authors]),
(
xml_subterm( Bibliography, Book ),
xml_subterm( Book, Title ),
findall( Author, xml_subterm(Book, Author), Authors )
),
Results
).
% Q4: For each author in the bibliography, list the author's name and the titles
% of all books by that author, grouped inside a "result" element.
xml_query( q4, element(results, [], Results) ) :-
element_name( Title, title ),
element_name( Author, author ),
element_name( Book, book ),
input_document( 'bib.xml', Bibliography ),
findall( Author, xml_subterm(Bibliography, Author), AuthorBag ),
sort( AuthorBag, Authors ),
findall(
element(result, [], [Author|Titles]),
(
member( Author, Authors ),
findall( Title, (
xml_subterm( Bibliography, Book ),
xml_subterm( Book, Author ),
xml_subterm( Book, Title )
),
Titles
)
),
Results
).
% Q5: For each book found at both bn.com and amazon.com, list the title of the
% book and its price from each source.
xml_query( q5, element('books-with-prices', [], BooksWithPrices) ) :-
element_name( Title, title ),
element_name( Book, book ),
element_name( Review, entry ),
input_document( 'bib.xml', Bibliography ),
input_document( 'reviews.xml', Reviews ),
findall(
element('book-with-prices', [], [
Title,
element('price-bn',[], BNPrice ),
element('price-amazon',[], AmazonPrice )
] ),
(
xml_subterm( Bibliography, Book ),
xml_subterm( Book, Title ),
xml_subterm( Reviews, Review ),
xml_subterm( Review, Title ),
xml_subterm( Book, element(price,_, BNPrice) ),
xml_subterm( Review, element(price,_, AmazonPrice) )
),
BooksWithPrices
).
% Q6: For each book that has at least one author, list the title and first two
% authors, and an empty "et-al" element if the book has additional authors.
xml_query( q6, element(bib, [], Results) ) :-
element_name( Title, title ),
element_name( Author, author ),
element_name( Book, book ),
input_document( 'bib.xml', Bibliography ),
findall(
element(book, [], [Title,FirstAuthor|Authors]),
(
xml_subterm( Bibliography, Book ),
xml_subterm( Book, Title ),
findall( Author, xml_subterm(Book, Author), [FirstAuthor|Others] ),
other_authors( Others, Authors )
),
Results
).
% Q7: List the titles and years of all books published by Addison-Wesley after
% 1991, in alphabetic order.
xml_query( q7, element(bib, [], Books) ) :-
element_name( Title, title ),
element_name( Publisher, publisher ),
input_document( 'bib.xml', Bibliography ),
findall(
Title-element(book, [year=Year], [Title]),
(
xml_subterm( Bibliography, element(book, Attributes, Book) ),
xml_subterm( Book, Publisher ),
xml_subterm( Publisher, Text ),
text_value( Text, "Addison-Wesley" ),
member( year=Year, Attributes ),
number_codes( YearNo, Year ),
YearNo > 1991,
xml_subterm( Book, Title )
),
TitleBooks
),
keysort( TitleBooks, TitleBookSet ),
range( TitleBookSet, Books ).
% Q8: Find books in which the name of some element ends with the string "or" and
% the same element contains the string "Suciu" somewhere in its content. For each
% such book, return the title and the qualifying element.
xml_query( q8, element(bib, [], Books) ) :-
element_name( Title, title ),
element_name( Book, book ),
element_name( QualifyingElement, QualifyingName ),
append( "Suciu", _Back, Suffix ),
input_document( 'bib.xml', Bibliography ),
findall(
element(book, [], [Title,QualifyingElement]),
(
xml_subterm( Bibliography, Book ),
xml_subterm( Book, QualifyingElement ),
atom_codes( QualifyingName, QNChars ),
append( _QNPrefix, "or", QNChars ),
xml_subterm( QualifyingElement, TextItem ),
text_value( TextItem, TextValue ),
append( _Prefix, Suffix, TextValue ),
xml_subterm( Book, Title )
),
Books
).
% Q9: In the document "books.xml", find all section or chapter titles that
% contain the word "XML", regardless of the level of nesting.
xml_query( q9, element(results, [], Titles) ) :-
element_name( Title, title ),
append( "XML", _Back, Suffix ),
input_document( 'books.xml', Books ),
findall(
Title,
(
xml_subterm( Books, Title ),
xml_subterm( Title, TextItem ),
text_value( TextItem, TextValue ),
append( _Prefix, Suffix, TextValue )
),
Titles
).
% Q10: In the document "prices.xml", find the minimum price for each book, in the
% form of a "minprice" element with the book title as its title attribute.
xml_query( q10, element(results, [], MinPrices) ) :-
element_name( Title, title ),
element_name( Price, price ),
input_document( 'prices.xml', Prices ),
findall( Title, xml_subterm(Prices, Title), TitleBag ),
sort( TitleBag, TitleSet ),
element_name( Book, book ),
findall(
element(minprice, [title=TitleString], [MinPrice]),
(
member( Title, TitleSet ),
xml_subterm( Title, TitleText ),
text_value( TitleText, TitleString ),
findall( PriceValue-Price, (
xml_subterm( Prices, Book ),
xml_subterm( Book, Title ),
xml_subterm( Book, Price ),
xml_subterm( Price, Text ),
text_value( Text, PriceChars ),
number_codes( PriceValue, PriceChars )
),
PriceValues
),
minimum( PriceValues, PriceValue-MinPrice )
),
MinPrices
).
% Q11: For each book with an author, return the book with its title and authors.
% For each book with an editor, return a reference with the book title and the
% editor's affiliation.
xml_query( q11, element(bib, [], Results) ) :-
element_name( Title, title ),
element_name( Author, author ),
element_name( Book, book ),
element_name( Editor, editor ),
element_name( Affiliation, affiliation ),
input_document( 'bib.xml', Bibliography ),
findall(
element(book, [], [Title,FirstAuthor|Authors]),
(
xml_subterm( Bibliography, Book ),
xml_subterm( Book, Title ),
findall( Author, xml_subterm(Book, Author), [FirstAuthor|Authors] )
),
Books
),
findall(
element(reference, [], [Title,Affiliation]),
(
xml_subterm( Bibliography, Book ),
xml_subterm( Book, Title ),
xml_subterm( Book, Editor ),
xml_subterm( Editor, Affiliation )
),
References
),
append( Books, References, Results ).
% Q12: Find pairs of books that have different titles but the same set of authors
% (possibly in a different order).
xml_query( q12, element(bib, [], Pairs) ) :-
element_name( Author, author ),
element_name( Book1, book ),
element_name( Book2, book ),
element_name( Title1, title ),
element_name( Title2, title ),
input_document( 'bib.xml', Bibliography ),
findall(
element('book-pair', [], [Title1,Title2]),
(
xml_subterm( Bibliography, Book1 ),
findall( Author, xml_subterm(Book1, Author), AuthorBag1 ),
sort( AuthorBag1, AuthorSet ),
xml_subterm( Bibliography, Book2 ),
Book2 @< Book1,
findall( Author, xml_subterm(Book2, Author), AuthorBag2 ),
sort( AuthorBag2, AuthorSet ),
xml_subterm( Book1, Title1 ),
xml_subterm( Book2, Title2 )
),
Pairs
).
% Auxilliary Predicates
other_authors( [], [] ).
other_authors( [Author|Authors], [Author|EtAl] ) :-
et_al( Authors, EtAl ).
et_al( [], [] ).
et_al( [_|_], [element('et-al',[],[])] ).
text_value( [pcdata(Text)], Text ).
text_value( [cdata(Text)], Text ).
element_name( element(Name, _Attributes, _Content), Name ).
/* range( +Pairs, ?Range ) when Pairs is a list of key-datum pairs and Range
* is the list of data.
*/
range( [], [] ).
range( [_Key-Datum|Pairs], [Datum|Data] ) :-
range( Pairs, Data ).
/* minimum( +List, ?Min ) is true if Min is the least member of List in the
* standard order.
*/
minimum( [H|T], Min ):-
minimum1( T, H, Min ).
minimum1( [], Min, Min ).
minimum1( [H|T], Min0, Min ) :-
compare( Relation, H, Min0 ),
minimum2( Relation, H, Min0, T, Min ).
minimum2( '=', Min0, Min0, T, Min ) :-
minimum1( T, Min0, Min ).
minimum2( '<', Min0, _Min1, T, Min ) :-
minimum1( T, Min0, Min ).
minimum2( '>', _Min0, Min1, T, Min ) :-
minimum1( T, Min1, Min ).
/* input_document( +File, ?XML ) reads File and parses the input into the
* "Document Value Model" XML.
*/
input_document( File, XML ) :-
% Read InputFile as a list of chars
see( File ),
get_chars( Input ),
seen,
% Parse the Input chars into the term XML
xml_parse( Input, XML ).
% Load the XML module.
:- use_module( library(xml) ).
% Load a small library of utilities.
:- ensure_loaded( misc ).

389
packages/xml/xml_generation.pl Normal file
View File

@@ -0,0 +1,389 @@
/* xml_generation.pl : Document -> XML translation
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.7 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*/
:- ensure_loaded( xml_utilities ).
/* document_generation( +Format, +Document ) is a DCG generating Document
* as a list of character codes. Format is true|false defining whether layouts,
* to provide indentation, should be added between the element content of
* the resultant "string". Note that formatting is disabled for elements that
* are interspersed with pcdata/1 terms, such as XHTML's 'inline' elements.
* Also, Format is over-ridden, for an individual element, by an explicit
* 'xml:space'="preserve" attribute.
*/
document_generation( Format, xml(Attributes, Document) ) -->
document_generation_body( Attributes, Format, Document ).
document_generation_body( [], Format, Document ) -->
generation( Document, "", Format, [], _Format1 ).
document_generation_body( Attributes, Format, Document ) -->
{ Attributes = [_|_],
xml_declaration_attributes_valid( Attributes )
},
"<?xml",
generated_attributes( Attributes, Format, Format0 ),
"?>",
indent( true, [] ),
generation( Document, "", Format0, [], _Format1 ).
generation( [], _Prefix, Format, _Indent, Format ) --> [].
generation( [Term|Terms], Prefix, Format0, Indent, Format ) -->
generation( Term, Prefix, Format0, Indent, Format1 ),
generation( Terms, Prefix, Format1, Indent, Format ).
generation( doctype(Name, External), _Prefix, Format, [], Format ) -->
"<!DOCTYPE ",
generated_name( Name ),
generated_external_id( External ),
">".
generation( instructions(Target,Process), _Prefix, Format, Indent, Format ) -->
indent( Format, Indent ),
"<?", generated_name(Target), " ", chars( Process ) ,"?>".
generation( pcdata(Chars), _Prefix, Format0, _Indent, Format1 ) -->
pcdata_generation( Chars ),
{character_data_format( Chars, Format0, Format1 )}.
generation( comment( Comment ), _Prefix, Format, Indent, Format ) -->
indent( Format, Indent ),
"<!--", chars( Comment ), "-->".
generation( namespace(URI, Prefix, element(Name, Atts, Content)),
_Prefix0, Format, Indent, Format ) -->
indent( Format, Indent ),
"<", generated_prefixed_name( Prefix, Name ),
generated_prefixed_attributes( Prefix, URI, Atts, Format, Format1 ),
generated_content( Content, Format1, Indent, Prefix, Name ).
generation( element(Name, Atts, Content), Prefix, Format, Indent, Format ) -->
indent( Format, Indent ),
"<", generated_prefixed_name( Prefix, Name ),
generated_attributes( Atts, Format, Format1 ),
generated_content( Content, Format1, Indent, Prefix, Name ).
generation( cdata(CData), _Prefix, Format0, _Indent, Format1 ) -->
"<![CDATA[", cdata_generation(CData), "]]>",
{character_data_format( CData, Format0, Format1 )}.
generated_attributes( [], Format, Format ) --> [].
generated_attributes( [Name=Value|Attributes], Format0, Format ) -->
{( Name == 'xml:space',
Value="preserve" ->
Format1 = false
; otherwise ->
Format1 = Format0
)},
" ",
generated_name( Name ),
"=""",
quoted_string( Value ),
"""",
generated_attributes( Attributes, Format1, Format ).
generated_prefixed_name( [], Name ) -->
generated_name( Name ).
generated_prefixed_name( Prefix, Name ) -->
{Prefix = [_|_]},
chars( Prefix ), ":",
generated_name( Name ).
generated_content( [], _Format, _Indent, _Prefix, _Namespace ) -->
" />". % Leave an extra space for XHTML output.
generated_content( [H|T], Format, Indent, Prefix, Namespace ) -->
">",
generation( H, Prefix, Format, [0' |Indent], Format1 ),
generation( T, Prefix, Format1, [0' |Indent], Format2 ),
indent( Format2, Indent ),
"</", generated_prefixed_name( Prefix, Namespace ), ">".
generated_prefixed_attributes( [_|_Prefix], _URI, Atts, Format0, Format ) -->
generated_attributes( Atts, Format0, Format ).
generated_prefixed_attributes( [], URI, Atts, Format0, Format ) -->
{atom_codes( URI, Namespace ),
findall( Attr, (member(Attr, Atts), \+ Attr=(xmlns=_Val)), Atts1 )
},
generated_attributes( [xmlns=Namespace|Atts1], Format0, Format ).
generated_name( Name, Plus, Minus ) :-
atom_codes( Name, Chars ),
append( Chars, Minus, Plus ).
generated_external_id( local ) --> "".
generated_external_id( local(Literals) ) --> " [",
generated_doctype_literals( Literals ), "
]".
generated_external_id( system(URL) ) -->
" SYSTEM """,
chars( URL ),
"""".
generated_external_id( system(URL,Literals) ) -->
" SYSTEM """,
chars( URL ),
""" [",
generated_doctype_literals( Literals ), "
]".
generated_external_id( public(URN,URL) ) -->
" PUBLIC """,
chars( URN ),
""" """,
chars( URL ),
"""".
generated_external_id( public(URN,URL,Literals) ) -->
" PUBLIC """,
chars( URN ),
""" """,
chars( URL ),
""" [",
generated_doctype_literals( Literals ), "
]".
generated_doctype_literals( [] ) --> "".
generated_doctype_literals( [dtd_literal(String)|Literals] ) --> "
<!", cdata_generation( String ), ">",
generated_doctype_literals( Literals ).
/* quoted_string( +Chars ) is a DCG representing Chars, a list of character
* codes, as a legal XML attribute string. Any leading or trailing layout
* characters are removed. &, " and < characters are replaced by &amp;, &quot;
* and &lt; respectively, .
*/
quoted_string( Raw, Plus, Minus ) :-
quoted_string1( Raw, NoLeadingLayouts ),
quoted_string2( NoLeadingLayouts, Layout, Layout, Plus, Minus ).
quoted_string1( [], [] ).
quoted_string1( [Char|Chars], NoLeadingLayouts ) :-
( Char > 32 ->
NoLeadingLayouts = [Char|Chars]
; otherwise ->
quoted_string1( Chars, NoLeadingLayouts )
).
quoted_string2( [], _LayoutPlus, _LayoutMinus, List, List ).
quoted_string2( [Char|Chars], LayoutPlus, LayoutMinus, Plus, Minus ) :-
( Char =< " " ->
Plus = Plus1,
LayoutMinus = [Char|LayoutMinus1],
LayoutPlus = LayoutPlus1
; Char == 34 ->
Plus = LayoutPlus,
escaped_quote( LayoutMinus, Plus1 ),
LayoutPlus1 = LayoutMinus1
; Char == 39 ->
Plus = LayoutPlus,
apos( LayoutMinus, Plus1 ),
LayoutPlus1 = LayoutMinus1
; Char =< 127 ->
Plus = LayoutPlus,
pcdata_7bit( Char, LayoutMinus, Plus1 ),
LayoutPlus1 = LayoutMinus1
; legal_xml_unicode( Char ) ->
Plus = LayoutPlus,
number_codes( Char, Codes ),
pcdata_8bits_plus( Codes, LayoutMinus, Plus1 ),
LayoutPlus1 = LayoutMinus1
; otherwise ->
LayoutPlus = LayoutPlus1,
LayoutMinus = LayoutMinus1,
Plus = Plus1
),
quoted_string2( Chars, LayoutPlus1, LayoutMinus1, Plus1, Minus ).

198
packages/xml/xml_pp.pl Normal file
View File

@@ -0,0 +1,198 @@
/* xml_pp: "pretty print" an XML Document on the current output stream.
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.3 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*/
:- ensure_loaded( xml_utilities ).
/* xml_pp( +XMLDocument ) "pretty prints" XMLDocument on the current
* output stream.
*/
xml_pp( xml(Attributes, Document) ) :-
write( 'xml( ' ), pp_attributes( Attributes, 0 ), pp_comma, nl,
pp_list( Document, s(0) ),
write( ' ).' ), nl.
xml_pp( malformed(Attributes, Document) ) :-
write( 'malformed( ' ), pp_attributes( Attributes, 0 ), pp_comma, nl,
pp_list( Document, s(0) ),
write( ' ).' ), nl.
pp_indented( [], Indent ) :-
pp_indent( Indent), write( '[]' ).
pp_indented( List, Indent ) :-
List = [_|_],
pp_indent( Indent ),
pp_list( List, Indent ).
pp_indented( comment(Text), Indent ) :-
pp_indent( Indent ), write( 'comment(' ), pp_string(Text), write( ')' ).
pp_indented( namespace(URI,Prefix,Element), Indent ) :-
pp_indent( Indent ),
write( 'namespace( ' ), writeq( URI ), pp_comma_sp,
pp_string( Prefix ), pp_comma, nl,
pp_indented( Element, s(Indent) ), nl,
pp_indent( s(Indent) ), write( ')' ).
pp_indented( element(Tag,Attributes,Contents), Indent ) :-
pp_indent( Indent ), write( 'element( ' ), writeq( Tag ), pp_comma, nl,
pp_attributes( Attributes, s(Indent) ), pp_comma, nl,
pp_list( Contents, s(Indent) ), write( ' )' ).
pp_indented( instructions(Target, Processing), Indent ) :-
pp_indent( Indent ), write( 'instructions( ' ), writeq( Target ), pp_comma_sp,
pp_string(Processing), write( ')' ).
pp_indented( doctype(Name, DoctypeId), Indent ) :-
pp_indent( Indent ), write( 'doctype( ' ), writeq( Name ), pp_comma_sp,
pp_indented( DoctypeId, s(Indent) ), %'
write( ' )' ).
pp_indented( cdata(CData), Indent ) :-
pp_indent( Indent ), write( 'cdata(' ), pp_string(CData), write( ')' ).
pp_indented( pcdata(PCData), Indent ) :-
pp_indent( Indent ), write( 'pcdata(' ), pp_string(PCData), write( ')' ).
pp_indented( public(URN,URL), _Indent ) :-
write( 'public(' ), pp_string(URN), pp_comma_sp,
pp_string(URL), write( ')' ).
pp_indented( public(URN,URL,Literals), Indent ) :-
write( 'public(' ), pp_string(URN), pp_comma_sp,
pp_string(URL), pp_list( Literals, s(Indent) ), write( ')' ).
pp_indented( system(URL), _Indent ) :-
write( 'system(' ), pp_string(URL), write( ')' ).
pp_indented( system(URL,Literals), Indent ) :-
write( 'system(' ), pp_string(URL), pp_comma_sp,
pp_list( Literals, s(Indent) ), write( ')' ).
pp_indented( local, _Indent ) :-
write( local ).
pp_indented( local(Literals), Indent ) :-
write( 'local(' ), nl,
pp_list( Literals, s(Indent) ), write( ')' ).
pp_indented( dtd_literal(String), Indent ) :-
pp_indent( Indent ), write( 'dtd_literal(' ), pp_string(String), write( ')' ).
pp_indented( out_of_context(Tag), Indent ) :-
pp_indent( Indent ), write( '/* SYNTAX ERROR */ out_of_context( ' ),
writeq( Tag ), write( ' )' ).
pp_indented( unparsed(String), Indent ) :-
pp_indent( Indent ), write( '/* SYNTAX ERROR */ unparsed( ' ),
pp_string(String), write( ' )' ).
pp_list( [], Indent ) :-
pp_indent( Indent ), write( [] ).
pp_list( [H|T], Indent ) :-
pp_indent( Indent ), write( '[' ), nl,
pp_indented( H, Indent ),
pp_list1( T, Indent ),
pp_indent( Indent ), write( ']' ).
pp_list1( [], _Indent ) :-
nl.
pp_list1( [H|T], Indent ) :-
pp_comma, nl,
pp_indented( H, Indent ),
pp_list1( T, Indent ).
pp_attributes( [], Indent ) :-
pp_indent( Indent ), write( [] ).

499
packages/xml/xml_utilities.pl Normal file
View File

@@ -0,0 +1,499 @@
/* XML Utilities
*
* Copyright (C) 2001-2005 Binding Time Limited
* Copyright (C) 2005-2011 John Fletcher
*
* Current Release: $Revision: 3.4 $
*
* TERMS AND CONDITIONS:
*
* This program is offered free of charge, as unsupported source code. You may
* use it, copy it, distribute it, modify it or sell it without restriction,
* but entirely at your own risk.
*/
% Entity and Namespace map operations: these maps are usually quite small, so
% a linear list lookup is okay. They could be substituted by a logarithmic
% data structure - in extremis.
/* empty_map( ?Map ) is true if Map is a null map.
*/
empty_map( [] ).
/* map_member( +Key, +Map, ?Data ) is true if Map is a ordered map structure
* which records the pair Key-Data. Key must be ground.
*/
map_member( Key0, [Key1-Data1|Rest], Data0 ) :-
( Key0 == Key1 ->
Data0 = Data1
; Key0 @> Key1 ->
map_member( Key0, Rest, Data0 )
).
/* map_store( +Map0, +Key, +Data, ?Map1 ) is true if Map0 is an ordered map
* structure, Key must be ground, and Map1 is identical to Map0 except that
* the pair Key-Data is recorded by Map1.
*/
map_store( [], Key, Data, [Key-Data] ).
map_store( [Key0-Data0|Map0], Key, Data, Map ) :-
( Key == Key0 ->
Map = [Key-Data|Map0]
; Key @< Key0 ->
Map = [Key-Data,Key0-Data0|Map0]
; otherwise -> % >
Map = [Key0-Data0|Map1],
map_store( Map0, Key, Data, Map1 )
).
/* context(?Element, ?PreserveSpace, ?CurrentNS, ?DefaultNS, ?Entities, ?Namespaces )
* is an ADT hiding the "state" arguments for XML Acquisition
*/
initial_context(
Controls,
context(void,PreserveSpace,'','',Entities,Empty,
RemoveAttributePrefixes,AllowAmpersand)
) :-
empty_map( Empty ),
( member( extended_characters(false), Controls ) ->
Entities = Empty
; otherwise ->
extended_character_entities(Entities)
),
( member( format(false), Controls ) ->
PreserveSpace = true
; otherwise ->
PreserveSpace = false
),
( member( remove_attribute_prefixes(true), Controls ) ->
RemoveAttributePrefixes = true
; otherwise ->
RemoveAttributePrefixes = false
),
( member( allow_ampersand(true), Controls ) ->
AllowAmpersand = true
; otherwise ->
AllowAmpersand = false
).
context_update( current_namespace, Context0, URI, Context1 ) :-
Context0 = context(Element,Preserve,_Current,Default,Entities,
Namespaces,RemoveAttributePrefixes,Amp),
Context1 = context(Element,Preserve,URI,Default,Entities,
Namespaces,RemoveAttributePrefixes,Amp).
context_update( element, Context0, Tag, Context1 ) :-
Context0 = context(_Element,Preserve,Current,Default,Entities,
Namespaces,RemoveAttributePrefixes,Amp),
Context1 = context(tag(Tag),Preserve,Current,Default,Entities,
Namespaces,RemoveAttributePrefixes,Amp).
context_update( default_namespace, Context0, URI, Context1 ):-
Context0 = context(Element,Preserve,Current,_Default,Entities,
Namespaces,RemoveAttributePrefixes,Amp),
Context1 = context(Element,Preserve,Current,URI,Entities,
Namespaces,RemoveAttributePrefixes,Amp).
context_update( space_preserve, Context0, Boolean, Context1 ):-
Context0 = context(Element,_Preserve,Current,Default,Entities,
Namespaces,RemoveAttributePrefixes,Amp),
Context1 = context(Element,Boolean,Current,Default,Entities,
Namespaces,RemoveAttributePrefixes,Amp).
context_update( ns_prefix(Prefix), Context0, URI, Context1 ) :-
Context0 = context(Element,Preserve,Current,Default,Entities,
Namespaces0,RemoveAttributePrefixes,Amp),
Context1 = context(Element,Preserve,Current,Default,Entities,
Namespaces1,RemoveAttributePrefixes,Amp),
map_store( Namespaces0, Prefix, URI, Namespaces1 ).
context_update( entity(Name), Context0, String, Context1 ) :-
Context0 = context(Element,Preserve,Current,Default,Entities0,
Namespaces,RemoveAttributePrefixes,Amp),
Context1 = context(Element,Preserve,Current,Default,Entities1,
Namespaces,RemoveAttributePrefixes,Amp),
map_store( Entities0, Name, String, Entities1 ).
remove_attribute_prefixes( Context ) :-
Context = context(_Element,_Preserve,_Current,_Default,_Entities,
_Namespaces,true,_Amp).
current_tag( Context, Tag ) :-
Context = context(tag(Tag),_Preserve,_Current,_Default,_Entities,
_Namespaces,_RPFA,_Amp).
current_namespace( Context, Current ) :-
Context = context(_Element,_Preserve,Current,_Default,_Entities,
_Namespaces,_RPFA,_Amp).
default_namespace( Context, Default ) :-
Context = context(_Element,_Preserve,_Current,Default,_Entities,
_Namespaces,_RPFA,_Amp).
space_preserve( Context ) :-
Context = context(tag(_Tag),true,_Current,_Default,_Entities,
_Namespaces,_RPFA,_Amp).
specific_namespace( Prefix, Context, URI ) :-
Context = context(_Element,_Preserve,_Current,_Default,_Entities,
Namespaces,_RPFA,_Amp),
map_member( Prefix, Namespaces, URI ).
defined_entity( Reference, Context, String ) :-
Context = context(_Element,_Preserve,_Current,_Default,Entities,
_Namespaces,_RPFA,_Amp),
map_member( Reference, Entities, String ).
close_context( Context, Terms, WellFormed ) :-
Context = context(Element,_Preserve,_Current,_Default,_Entities,
_Namespaces,_RPFA,_Amp),
close_context1( Element, Terms, WellFormed ).
close_context1( void, [], true ).
close_context1( tag(TagChars), [out_of_context(Tag)], false ) :-
atom_chars( Tag, TagChars ).
void_context(
context(void,_Preserve,_Current,_Default,_Entities,_Names,_RPFA,_Amp)
).
allow_ampersand(
context(_Void,_Preserve,_Current,_Default,_Entities,_Names,_RPFA,true)
).
/* pp_string( +String ) prints String onto the current output stream.
* If String contains only 7-bit chars it is printed in shorthand quoted
* format, otherwise it is written as a list.
* If your Prolog uses " to delimit a special string type, just use write/1.
*/
pp_string( Chars ) :-
( member( Char, Chars ),
not_shorthand( Char ) ->
write( Chars )
; otherwise ->
put_quote,
pp_string1( Chars ),
put_quote
).
not_shorthand( Char ) :-
Char > 255.
not_shorthand( Char ) :-
Char < 9.
not_shorthand( 126 ). % ~ gives syntax errors in LPA Prolog
put_quote :-
put( 0'" ). % '
pp_string1( [] ).
pp_string1( [Char|Chars] ) :-
( Char =:= """" -> % Meta-quote
put( Char ),
put( Char ),
pp_string1( Chars )
; Char =:= 13, % Handle Windows border-settings
Chars = [10|Chars1] ->
put( 10 ),
pp_string1( Chars1 )
; otherwise ->
put( Char ),
pp_string1( Chars )
).
xml_declaration_attributes_valid( [] ).
xml_declaration_attributes_valid( [Name=Value|Attributes] ) :-
xml_declaration_attribute_valid( Name, Value ),
xml_declaration_attributes_valid( Attributes ).
xml_declaration_attribute_valid( Name, Value ) :-
lowercase( Value, Lowercase ),
canonical_xml_declaration_attribute( Name, Lowercase ).
canonical_xml_declaration_attribute( version, "1.0" ).
canonical_xml_declaration_attribute( standalone, "yes" ).
canonical_xml_declaration_attribute( standalone, "no" ).
% The encodings here are all valid for the output produced.
canonical_xml_declaration_attribute( encoding, "utf-8" ).
% canonical_xml_declaration_attribute( encoding, "utf-16" ).
% This is erroneous for the output of this library
canonical_xml_declaration_attribute( encoding, "us-ascii" ).
canonical_xml_declaration_attribute( encoding, "ascii" ).
canonical_xml_declaration_attribute( encoding, "iso-8859-1" ).
canonical_xml_declaration_attribute( encoding, "iso-8859-2" ).
canonical_xml_declaration_attribute( encoding, "iso-8859-15" ).
canonical_xml_declaration_attribute( encoding, "windows-1252" ).
% In general, it's better not to specify an encoding.
/* lowercase( +MixedCase, ?Lowercase ) holds when Lowercase and MixedCase are
* lists of character codes, and Lowercase is identical to MixedCase with
* every uppercase character replaced by its lowercase equivalent.
*/
lowercase( [], [] ).
lowercase( [Char|Chars], [Lower|LowerCase] ) :-
( Char >= "A", Char =< "Z" ->
Lower is Char + "a" - "A"
; otherwise ->
Lower = Char
),
lowercase( Chars, LowerCase ).
extended_character_entities( [
"AElig"-[198], % latin capital letter AE
"Aacute"-[193], % latin capital letter A with acute,
"Acirc"-[194], % latin capital letter A with circumflex,
"Agrave"-[192], % latin capital letter A with grave
"Alpha"-[913], % greek capital letter alpha, U+0391
"Aring"-[197], % latin capital letter A with ring above
"Atilde"-[195], % latin capital letter A with tilde,
"Auml"-[196], % latin capital letter A with diaeresis,
"Beta"-[914], % greek capital letter beta, U+0392
"Ccedil"-[199], % latin capital letter C with cedilla,
"Chi"-[935], % greek capital letter chi, U+03A7
"Dagger"-[8225], % double dagger, U+2021 ISOpub
"Delta"-[916], % greek capital letter delta,
"ETH"-[208], % latin capital letter ETH, U+00D0 ISOlat1>
"Eacute"-[201], % latin capital letter E with acute,
"Ecirc"-[202], % latin capital letter E with circumflex,

2
packages/zlib

Submodule packages/zlib updated: 2a859fd757...5da6dfcfe7

20
pl/boot.yap
View File

@@ -311,7 +311,7 @@ true :- true.
(
O = (:- G1)
->
'$process_directive'(G1, Option, M)
'$process_directive'(G1, Option, M, VL, Pos)
;
'$execute_commands'(O,VL,Pos,Option,O)
).
@@ -328,33 +328,33 @@ true :- true.
% SICStus accepts everything in files
% YAP accepts everything everywhere
%
'$process_directive'(G, top, M) :-
'$process_directive'(G, top, M, VL, Pos) :-
'$access_yap_flags'(8, 0), !, % YAP mode, go in and do it,
'$process_directive'(G, consult, M).
'$process_directive'(G, top, _) :- !,
'$process_directive'(G, consult, M, VL, Pos).
'$process_directive'(G, top, _, _, _) :- !,
'$do_error'(context_error((:- G),clause),query).
%
% allow modules
%
'$process_directive'(M:G, Mode, _) :- !,
'$process_directive'(G, Mode, M).
'$process_directive'(M:G, Mode, _, VL, Pos) :- !,
'$process_directive'(G, Mode, M, VL, Pos).
%
% default case
%
'$process_directive'(Gs, Mode, M) :-
'$process_directive'(Gs, Mode, M, VL, Pos) :-
'$all_directives'(Gs), !,
'$exec_directives'(Gs, Mode, M).
'$exec_directives'(Gs, Mode, M, VL, Pos).
%
% ISO does not allow goals (use initialization).
%
'$process_directive'(D, _, M) :-
'$process_directive'(D, _, M, VL, Pos) :-
'$access_yap_flags'(8, 1), !, % ISO Prolog mode, go in and do it,
'$do_error'(context_error((:- M:D),query),directive).
%
% but YAP and SICStus does.
%
'$process_directive'(G, _, M) :-
'$process_directive'(G, _, M, VL, Pos) :-
'$exit_system_mode',
( '$notrace'(M:G) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ),
'$enter_system_mode'.

18
pl/consult.yap
View File

@@ -229,8 +229,7 @@ use_module(M,F,Is) :-
'$csult'([F|L], M) :- '$consult'(F, M), '$csult'(L, M).
'$do_lf'(ContextModule, Stream, InfLevel, _, Imports, SkipUnixComments, CompMode, Reconsult, UseModule) :-
nb_getval('$if_level',OldIncludeLevel),
nb_setval('$if_level',0),
'$reset_if'(OldIfLevel),
( nb_getval('$system_mode', OldMode) -> true ; OldMode = off),
( OldMode == off -> '$enter_system_mode' ; true ),
'$record_loaded'(Stream, ContextModule, Reconsult),
@@ -285,7 +284,7 @@ use_module(M,F,Is) :-
% surely, we were in run mode or we would not have included the file!
nb_setval('$if_skip_mode',run),
% back to include mode!
nb_setval('$if_level',OldIncludeLevel),
nb_setval('$if_level',OldIfLevel),
'$bind_module'(Mod, UseModule),
'$import_to_current_module'(File, ContextModule, Imports),
( LC == 0 -> prompt(_,' |: ') ; true),
@@ -293,6 +292,12 @@ use_module(M,F,Is) :-
'$exec_initialisation_goals',
!.
'$reset_if'(OldIfLevel) :-
catch(nb_getval('$if_level',OldIncludeLevel),_,fail), !,
nb_setval('$if_level',0).
'$reset_if'(0) :-
nb_setval('$if_level',0).
'$bind_module'(_, load_files).
'$bind_module'(Mod, use_module(Mod)).
@@ -631,7 +636,7 @@ absolute_file_name(File0,File) :-
'$absolute_file_name'(F0,[access(read),file_type(source),file_errors(fail),solutions(first),expand(true)],F,G).
absolute_file_name(File,TrueFileName,Opts) :-
var(TrueFileName), !,
( var(TrueFileName) ; atom(TrueFileName) ), !,
absolute_file_name(File,Opts,TrueFileName).
absolute_file_name(File,Opts,TrueFileName) :-
'$absolute_file_name'(File,Opts,TrueFileName,absolute_file_name(File,Opts,TrueFileName)).
@@ -665,7 +670,7 @@ absolute_file_name(File,Opts,TrueFileName) :-
'$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions0,RelTo0,Type0,Access0,FErrors0,Solutions0,Expand0,Debug0,G),
'$process_fn_opts'(Opts,Extensions0,RelTo0,Type0,Access0,FErrors0,Solutions0,Expand0,Debug0,G).
'$process_fn_opts'(Opts,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !,
'$do_error'(type_error(list,T),G).
'$do_error'(type_error(list,Opts),G).
'$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- var(Opt), !,
'$do_error'(instantiation_error, G).
@@ -1038,3 +1043,6 @@ make_library_index(_Directory).
'$current_loop_stream'(Stream) :-
catch(nb_getval('$loop_stream',Stream), _, fail).
exists_source(File) :-
'$full_filename'(File, AbsFile, exists_source(File)).

4
pl/dialect.yap
View File

@@ -42,8 +42,8 @@ check_dialect(Dialect) :-
% :- endif.
% ==
exists_source(Source) :-
exists_source(Source, _Path).
%exists_source(Source) :-
% exists_source(Source, _Path).
exists_source(Source, Path) :-
absolute_file_name(Source, Path,

99
pl/directives.yap
View File

@@ -39,6 +39,7 @@
'$directive'(include(_)).
'$directive'(initialization(_)).
'$directive'(initialization(_,_)).
'$directive'(license(_)).
'$directive'(meta_predicate(_)).
'$directive'(module(_,_)).
'$directive'(module(_,_,_)).
@@ -52,6 +53,7 @@
'$directive'(reconsult(_)).
'$directive'(reexport(_)).
'$directive'(reexport(_,_)).
'$directive'(predicate_options(_,_,_)).
'$directive'(thread_initialization(_)).
'$directive'(thread_local(_)).
'$directive'(uncutable(_)).
@@ -60,89 +62,100 @@
'$directive'(use_module(_,_,_)).
'$directive'(wait(_)).
'$exec_directives'((G1,G2), Mode, M) :- !,
'$exec_directives'(G1, Mode, M),
'$exec_directives'(G2, Mode, M).
'$exec_directives'(G, Mode, M) :-
'$exec_directive'(G, Mode, M).
'$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) :-
'$exec_directive'(G, Mode, M, VL, Pos).
'$exec_directive'(multifile(D), _, M) :-
'$exec_directive'(multifile(D), _, M, _, _) :-
'$system_catch'('$multifile'(D, M), M,
Error,
user:'$LoopError'(Error, top)).
'$exec_directive'(discontiguous(D), _, M) :-
'$exec_directive'(discontiguous(D), _, M, _, _) :-
'$discontiguous'(D,M).
'$exec_directive'(initialization(D), _, M) :-
'$exec_directive'(initialization(D), _, M, _, _) :-
'$initialization'(M:D).
'$exec_directive'(initialization(D,OPT), _, M) :-
'$exec_directive'(initialization(D,OPT), _, M, _, _) :-
'$initialization'(M:D, OPT).
'$exec_directive'(thread_initialization(D), _, M) :-
'$exec_directive'(thread_initialization(D), _, M, _, _) :-
'$thread_initialization'(M:D).
'$exec_directive'(expects_dialect(D), _, _) :-
'$exec_directive'(expects_dialect(D), _, _, _, _) :-
'$expects_dialect'(D).
'$exec_directive'(encoding(Enc), _, _) :-
'$exec_directive'(encoding(Enc), _, _, _, _) :-
'$set_encoding'(Enc).
'$exec_directive'(include(F), Status, _) :-
'$exec_directive'(include(F), Status, _, _, _) :-
'$include'(F, Status).
'$exec_directive'(module(N,P), Status, _) :-
'$exec_directive'(module(N,P), Status, _, _, _) :-
'$module'(Status,N,P).
'$exec_directive'(module(N,P,Op), Status, _) :-
'$exec_directive'(module(N,P,Op), Status, _, _, _) :-
'$module'(Status,N,P,Op).
'$exec_directive'(meta_predicate(P), _, M) :-
'$exec_directive'(meta_predicate(P), _, M, _, _) :-
'$meta_predicate'(P, M).
'$exec_directive'(module_transparent(P), _, M) :-
'$exec_directive'(module_transparent(P), _, M, _, _) :-
'$module_transparent'(P, M).
'$exec_directive'(noprofile(P), _, M) :-
'$exec_directive'(noprofile(P), _, M, _, _) :-
'$noprofile'(P, M).
'$exec_directive'(require(Ps), _, M) :-
'$exec_directive'(require(Ps), _, M, _, _) :-
'$require'(Ps, M).
'$exec_directive'(dynamic(P), _, M) :-
'$exec_directive'(dynamic(P), _, M, _, _) :-
'$dynamic'(P, M).
'$exec_directive'(thread_local(P), _, M) :-
'$exec_directive'(thread_local(P), _, M, _, _) :-
'$thread_local'(P, M).
'$exec_directive'(op(P,OPSEC,OP), _, _) :-
'$exec_directive'(op(P,OPSEC,OP), _, _, _, _) :-
'$current_module'(M),
op(P,OPSEC,M:OP).
'$exec_directive'(set_prolog_flag(F,V), _, _) :-
'$exec_directive'(set_prolog_flag(F,V), _, _, _, _) :-
set_prolog_flag(F,V).
'$exec_directive'(ensure_loaded(Fs), _, M) :-
'$exec_directive'(ensure_loaded(Fs), _, M, _, _) :-
'$load_files'(M:Fs, [if(changed)], ensure_loaded(Fs)).
'$exec_directive'(char_conversion(IN,OUT), _, _) :-
'$exec_directive'(char_conversion(IN,OUT), _, _, _, _) :-
char_conversion(IN,OUT).
'$exec_directive'(public(P), _, M) :-
'$exec_directive'(public(P), _, M, _, _) :-
'$public'(P, M).
'$exec_directive'(compile(Fs), _, M) :-
'$exec_directive'(compile(Fs), _, M, _, _) :-
'$load_files'(M:Fs, [], compile(Fs)).
'$exec_directive'(reconsult(Fs), _, M) :-
'$exec_directive'(reconsult(Fs), _, M, _, _) :-
'$load_files'(M:Fs, [], reconsult(Fs)).
'$exec_directive'(consult(Fs), _, M) :-
'$exec_directive'(consult(Fs), _, M, _, _) :-
'$consult'(Fs, M).
'$exec_directive'(use_module(F), _, M) :-
'$exec_directive'(use_module(F), _, M, _, _) :-
'$load_files'(M:F, [if(not_loaded)],use_module(F)).
'$exec_directive'(reexport(F), _, M) :-
'$exec_directive'(reexport(F), _, M, _, _) :-
'$reexport'(F, all, M).
'$exec_directive'(reexport(F,Spec), _, M) :-
'$exec_directive'(reexport(F,Spec), _, M, _, _) :-
'$reexport'(F, Spec, M).
'$exec_directive'(use_module(F,Is), _, M) :-
'$exec_directive'(use_module(F,Is), _, M, _, _) :-
'$load_files'(M:F, [if(not_loaded),imports(Is)],use_module(F,Is)).
'$exec_directive'(use_module(Mod,F,Is), _, _) :-
'$exec_directive'(use_module(Mod,F,Is), _, _, _, _) :-
'$use_module'(Mod,F,Is).
'$exec_directive'(block(BlockSpec), _, _) :-
'$exec_directive'(block(BlockSpec), _, _, _, _) :-
'$block'(BlockSpec).
'$exec_directive'(wait(BlockSpec), _, _) :-
'$exec_directive'(wait(BlockSpec), _, _, _, _) :-
'$wait'(BlockSpec).
'$exec_directive'(table(PredSpec), _, M) :-
'$exec_directive'(table(PredSpec), _, M, _, _) :-
'$table'(PredSpec, M).
'$exec_directive'(uncutable(PredSpec), _, M) :-
'$exec_directive'(uncutable(PredSpec), _, M, _, _) :-
'$uncutable'(PredSpec, M).
'$exec_directive'(if(Goal), Context, M) :-
'$exec_directive'(if(Goal), Context, M, _, _) :-
'$if'(M:Goal, Context).
'$exec_directive'(else, Context, _) :-
'$exec_directive'(else, Context, _, _, _) :-
'$else'(Context).
'$exec_directive'(elif(Goal), Context, M) :-
'$exec_directive'(elif(Goal), Context, M, _, _) :-
'$elif'(M:Goal, Context).
'$exec_directive'(endif, Context, _) :-
'$exec_directive'(endif, Context, _, _, _) :-
'$endif'(Context).
'$exec_directive'(license(_), Context, _, _, _) :-
Context \= top.
'$exec_directive'(predicate_options(PI, Arg, Options), Context, Module, VL, Pos) :-
Context \= top,
'$predopts':expand_predicate_options(PI, Arg, Options, Clauses),
'$assert_list'(Clauses, Context, Module, VL, Pos).
'$assert_list'([], _Context, _Module, _VL, _Pos).
'$assert_list'(Clause.Clauses, Context, Module, VL, Pos) :-
'$command'(Clause, VL, Pos, Context),
'$assert_list'(Clauses, Context, Module, VL, Pos).
%
% allow users to define their own directives.
@@ -154,7 +167,7 @@ user_defined_directive(Dir,Action) :-
functor(NDir,Na,Ar),
'$current_module'(M, prolog),
assert_static('$directive'(NDir)),
assert_static(('$exec_directive'(Dir, _, _) :- Action)),
assert_static(('$exec_directive'(Dir, _, _, _, _) :- Action)),
'$current_module'(_, M).
'$thread_initialization'(M:D) :-

22
pl/flags.yap
View File

@@ -543,6 +543,13 @@ yap_flag(discontiguous_warnings,X) :-
yap_flag(discontiguous_warnings,X) :-
'$do_error'(domain_error(flag_value,discontiguous_warnings+X),yap_flag(discontiguous_warnings,X)).
yap_flag(occurs_check,X) :-
X = false, !.
yap_flag(occurs_check,true) :- !,
fail.
yap_flag(occurs_check,X) :-
'$do_error'(domain_error(flag_value,occurs_check+X),yap_flag(occurs_check,X)).
yap_flag(redefine_warnings,X) :-
var(X), !,
('$syntax_check_mode'(on,_), '$syntax_check_multiple'(on,_) ->
@@ -734,23 +741,21 @@ yap_flag(stack_dump_on_error,X) :-
yap_flag(user_input,OUT) :-
var(OUT), !,
'$flag_check_alias'(OUT, user_input).
stream_property(OUT,alias(user_input)).
yap_flag(user_input,Stream) :-
'$change_alias_to_stream'(user_input,Stream).
set_stream(Stream, alias(user_input).
yap_flag(user_output,OUT) :-
var(OUT), !,
'$flag_check_alias'(OUT, user_output).
stream_property(OUT,alias(user_output)).
yap_flag(user_output,Stream) :-
'$change_alias_to_stream'(user_output,Stream).
set_stream(Stream, alias(user_output).
yap_flag(user_error,OUT) :-
var(OUT), !,
'$flag_check_alias'(OUT, user_error).
stream_property(OUT,alias(user_error)).
yap_flag(user_error,Stream) :-
'$change_alias_to_stream'(user_error,Stream).
set_stream(Stream, alias(user_error).
yap_flag(debugger_print_options,OUT) :-
var(OUT),
@@ -876,6 +881,7 @@ yap_flag(dialect,yap).
'$yap_system_flag'(min_integer).
'$yap_system_flag'(min_tagged_integer).
'$yap_system_flag'(n_of_integer_keys_in_db).
'$yap_system_flag'(occurs_check).
'$yap_system_flag'(open_expands_filename).
'$yap_system_flag'(open_shared_object).
'$yap_system_flag'(optimise).

6
pl/init.yap
View File

@@ -140,12 +140,14 @@ system_mode(verbose,off) :- set_value('$verbose',off).
:- use_module('history.pl').
:- use_module('dbload.yap').
:- use_module('swi.yap').
:- use_module('../LGPL/predopts.pl').
'$system_module'('$messages').
'$system_module'('$hacks').
'$system_module'('$attributes').
'$system_module'('$coroutining').
'$system_module'('$hacks').
'$system_module'('$history').
'$system_module'('$messages').
'$system_module'('$predopts').
'$system_module'('$swi').
yap_hacks:cut_by(CP) :- '$$cut_by'(CP).

33
pl/modules.yap
View File

@@ -664,6 +664,37 @@ abolish_module(Mod) :-
fail.
abolish_module(_).
export(P) :-
var(P),
'$do_error'(instantiation_error,export(P)).
export(P) :-
P = F/N, atom(F), number(N), N > 0, !,
'$current_module'(Mod),
( recorded('$module','$module'(F,Mod,ExportedPreds),R) ->
erase(R),
recorda('$module','$module'(F,Mod,[P|ExportedPreds]),_)
;
recorda('$module','$module'(user_input,Mod,[P]),_)
).
export(P0) :-
P0 = F//N, atom(F), number(N), N > 0, !,
N1 is N+2, P = F/N1,
'$current_module'(Mod),
( recorded('$module','$module'(F,Mod,ExportedPreds),R) ->
erase(R),
recorda('$module','$module'(F,Mod,[P|ExportedPreds]),_)
;
recorda('$module','$module'(user_input,Mod,[P]),_)
).
export(op(Prio,Assoc,Name)) :- !,
op(Prio,Assoc,prolog:Name).
export(P) :-
'$do_error'(type_error(predicate_indicator,P),export(P)).
export_list(Module, List) :-
recorded('$module','$module'(_,Module,List),_).
'$reexport'(ModuleSource, Spec, Module) :-
nb_getval('$consulting_file',TopFile),
(
@@ -823,7 +854,7 @@ Start a new (source-)module
@param Line is the line-number of the :- module/2 directive.
@param Redefine If =true=, allow associating the module to a new file
*/
'$declare_module'(Name, Context, _, _, _) :-
'$declare_module'(Name, _Test, Context, _File, _Line, _) :-
add_import_module(Name, Context, start).
module_property(Mod, file(F)) :-

16
pl/utils.yap
View File

@@ -437,6 +437,8 @@ atom_concat(X,Y,At) :-
atom_codes(X, Xs),
atom_codes(Y, Ys).
callable(A) :-
( var(A) -> fail ; number(A) -> fail ; true ).
atomic_list_concat(L,At) :-
atomic_concat(L, At).
@@ -547,16 +549,16 @@ sub_atom(At, Bef, Size, After, SubAt) :-
'$sub_atom_needs_int'(Size,ErrorTerm),
'$sub_atom_needs_int'(After,ErrorTerm),
atom_codes(SubAt,Atls),
'$$_length1'(Atls, 0, Size),
length(Atls, 0, Size),
'$sub_atom_get_subchars_and_match'(Size, Atl, Atls, NAtl),
'$$_length1'(NAtl,0,After).
length(NAtl,0,After).
% SubAt is unbound, but Size is bound
'$sub_atom3'(Size, After, SubAt, Atl, ErrorTerm) :-
nonvar(Size), !,
'$sub_atom_needs_int'(Size,ErrorTerm),
'$sub_atom_needs_int'(After,ErrorTerm),
'$sub_atom_get_subchars_and_match'(Size, Atl, SubAts, NAtl),
'$$_length1'(NAtl,0,After),
length(NAtl,After),
atom_codes(SubAt,SubAts).
% SubAt and Size are unbound, but After is bound.
'$sub_atom3'(Size, After, SubAt, Atl, ErrorTerm) :-
@@ -567,7 +569,7 @@ sub_atom(At, Bef, Size, After, SubAt) :-
atom_codes(SubAt,SubAts).
% SubAt, Size, and After are unbound.
'$sub_atom3'(Size, After, SubAt, Atl, _) :-
'$$_length1'(Atl,0,Len),
length(Atl,Len),
'$sub_atom_split'(Atl,Len,SubAts,Size,_,After),
atom_codes(SubAt,SubAts).
@@ -578,8 +580,8 @@ sub_atom(At, Bef, Size, After, SubAt) :-
'$sub_atom_needs_atom'(SubAt, ErrorTerm),
atom_codes(SubAt,SubAts),
'$sub_atom_search'(SubAts, Atl, 0, Bef, AfterS),
'$$_length1'(SubAts, 0, Size),
'$$_length1'(AfterS, 0, After).
length(SubAts, Size),
length(AfterS, After).
% ok: in the second best case we just get rid of the tail
'$sub_atombv'(Bef, Size, After, SubAt, Atl, ErrorTerm) :-
nonvar(After), !,
@@ -590,7 +592,7 @@ sub_atom(At, Bef, Size, After, SubAt) :-
atom_codes(SubAt,SubAts).
% ok: just do everything
'$sub_atombv'(Bef, Size, After, SubAt, Atl, _) :-
'$$_length1'(Atl, 0, Len),
length(Atl, Len),
'$sub_atom_split'(Atl,Len,_,Bef,Atls2,Len2),
'$sub_atom_split'(Atls2,Len2,SubAts,Size,_,After),
atom_codes(SubAt,SubAts).