diff --git a/BEAM/eam_am.c b/BEAM/eam_am.c index 4ed220d05..e02dc2e40 100644 --- a/BEAM/eam_am.c +++ b/BEAM/eam_am.c @@ -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(); diff --git a/BEAM/toeam.c b/BEAM/toeam.c index ce016f5a8..6cf69d8ce 100644 --- a/BEAM/toeam.c +++ b/BEAM/toeam.c @@ -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,'%'); diff --git a/C/absmi.c b/C/absmi.c index 9ae5e05e1..9dcf31a7b 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -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); diff --git a/C/c_interface.c b/C/c_interface.c index 16428bd67..ef9593fbc 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -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(); } diff --git a/C/heapgc.c b/C/heapgc.c index 3c4f52a8a..e00e556f1 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -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; } diff --git a/C/index.c b/C/index.c index 148902e5a..933ffbe5d 100644 --- a/C/index.c +++ b/C/index.c @@ -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); } diff --git a/C/init.c b/C/init.c index 8a09598d2..e0127e6a2 100644 --- a/C/init.c +++ b/C/init.c @@ -307,6 +307,7 @@ static Opdef Ops[] = { {"#", yfx, 500}, {"rdiv", yfx, 400}, {"div", yfx, 400}, + {"xor", yfx, 400}, {"*", yfx, 400}, {"/", yfx, 400}, {"//", yfx, 400}, diff --git a/C/iopreds.c b/C/iopreds.c index d42d56d55..6f6a3acf2 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -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; } diff --git a/C/parser.c b/C/parser.c index 9bfc6847c..40cd81460 100644 --- a/C/parser.c +++ b/C/parser.c @@ -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 */ diff --git a/C/pl-yap.c b/C/pl-yap.c index a726358ec..197a1f422 100644 --- a/C/pl-yap.c +++ b/C/pl-yap.c @@ -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) { diff --git a/C/qlyr.c b/C/qlyr.c index b8f4ffd03..aa588fbf6 100644 --- a/C/qlyr.c +++ b/C/qlyr.c @@ -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(); diff --git a/C/qlyw.c b/C/qlyw.c index 4e13941f3..2992768f5 100644 --- a/C/qlyw.c +++ b/C/qlyw.c @@ -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; diff --git a/C/stdpreds.c b/C/stdpreds.c index 46cfba12a..601407dcf 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -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"); diff --git a/C/tracer.c b/C/tracer.c index f2d80aaa1..74da2a1bc 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -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; diff --git a/C/write.c b/C/write.c index 23f44c607..246743ce0 100644 --- a/C/write.c +++ b/C/write.c @@ -43,9 +43,7 @@ typedef enum { symbol /* the previous term was a symbol like +, -, *, .... */ } wtype; -static wtype lastw; - -typedef int (*wrf) (int, wchar_t); +typedef void *wrf; typedef struct union_slots { Int old; @@ -67,38 +65,41 @@ typedef struct rewind_term { } rwts; typedef struct write_globs { - wrf writewch; + void *stream; int Quote_illegal, Ignore_ops, Handle_vars, Use_portray; - int keep_terms; + int Keep_terms; int Write_Loops; + int Write_strings; UInt MaxDepth, MaxArgs; + wtype lw; } wglbs; -STATIC_PROTO(void wrputn, (Int, wrf)); -STATIC_PROTO(void wrputs, (char *, wrf)); -STATIC_PROTO(void wrputf, (Float, wrf)); -STATIC_PROTO(void wrputref, (CODEADDR, int, wrf)); +#define lastw wglb->lw + +STATIC_PROTO(void wrputn, (Int, struct write_globs *)); +STATIC_PROTO(void wrputf, (Float, struct write_globs *)); +STATIC_PROTO(void wrputref, (CODEADDR, int, struct write_globs *)); STATIC_PROTO(int legalAtom, (unsigned char *)); /*STATIC_PROTO(int LeftOpToProtect, (Atom, int)); STATIC_PROTO(int RightOpToProtect, (Atom, int));*/ STATIC_PROTO(wtype AtomIsSymbols, (unsigned char *)); -STATIC_PROTO(void putAtom, (Atom, int, wrf)); +STATIC_PROTO(void putAtom, (Atom, int, struct write_globs *)); STATIC_PROTO(void writeTerm, (Term, int, int, int, struct write_globs *, struct rewind_term *)); -#define wrputc(X,WF) ((*WF)(LOCAL_c_output_stream,X)) /* writes a character */ +#define wrputc(X,WF) Sputcode(X,WF) /* writes a character */ static void -wrputn(Int n, wrf writewch) /* writes an integer */ - +wrputn(Int n, struct write_globs *wglb) /* writes an integer */ + { - CACHE_REGS + wrf stream = wglb->stream; char s[256], *s1=s; /* that should be enough for most integers */ if (n < 0) { if (lastw == symbol) - wrputc(' ', writewch); + wrputc(' ', stream); } else { if (lastw == alphanum) - wrputc(' ', writewch); + wrputc(' ', stream); } #if HAVE_SNPRINTF snprintf(s, 256, Int_FORMAT, n); @@ -106,25 +107,17 @@ wrputn(Int n, wrf writewch) /* writes an integer */ sprintf(s, Int_FORMAT, n); #endif while (*s1) - wrputc(*s1++, writewch); + wrputc(*s1++, stream); lastw = alphanum; } -static void -wrputs(char *s, wrf writewch) /* writes a string */ -{ - CACHE_REGS - while (*s) { - wrputc((unsigned char)(*s++), writewch); - } -} +#define wrputs(s, stream) Sfputs(s, stream) static void -wrputws(wchar_t *s, wrf writewch) /* writes a string */ +wrputws(wchar_t *s, wrf stream) /* writes a string */ { - CACHE_REGS while (*s) - wrputc(*s++, writewch); + wrputc(*s++, stream); } #ifdef USE_GMP @@ -168,27 +161,26 @@ ensure_space(size_t sz) { } static void -write_mpint(MP_INT *big, wrf writewch) { - CACHE_REGS +write_mpint(MP_INT *big, struct write_globs *wglb) { char *s; s = ensure_space(3+mpz_sizeinbase(big, 10)); if (mpz_sgn(big) < 0) { if (lastw == symbol) - wrputc(' ', writewch); + wrputc(' ', wglb->stream); } else { if (lastw == alphanum) - wrputc(' ', writewch); + wrputc(' ', wglb->stream); } if (!s) { s = mpz_get_str(NULL, 10, big); if (!s) return; - wrputs(s,writewch); + wrputs(s,wglb->stream); free(s); } else { mpz_get_str(s, 10, big); - wrputs(s,writewch); + wrputs(s,wglb->stream); } } #endif @@ -197,72 +189,94 @@ write_mpint(MP_INT *big, wrf writewch) { static void writebig(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, struct rewind_term *rwt) { - CACHE_REGS CELL *pt = RepAppl(t)+1; + CELL big_tag = pt[0]; + #ifdef USE_GMP - if (pt[0] == BIG_INT) + if (big_tag == BIG_INT) { MP_INT *big = Yap_BigIntOfTerm(t); - write_mpint(big, wglb->writewch); + write_mpint(big, wglb); return; - } else if (pt[0] == BIG_RATIONAL) { + } else if (big_tag == BIG_RATIONAL) { Term trat = Yap_RatTermToApplTerm(t); writeTerm(trat, p, depth, rinfixarg, wglb, rwt); return; } #endif - if (pt[0] == BLOB_STRING) { - wrputc('"',wglb->writewch); - wrputs(Yap_BlobStringOfTerm(t),wglb->writewch); - wrputc('"',wglb->writewch); + if (big_tag == BLOB_STRING) { + if (wglb->Write_strings) + wrputc('`',wglb->stream); + else + wrputc('"',wglb->stream); + wrputs(Yap_BlobStringOfTerm(t),wglb->stream); + if (wglb->Write_strings) + wrputc('`',wglb->stream); + else + wrputc('"',wglb->stream); return; - } else if (pt[0] == BLOB_STRING) { + } else if (big_tag == BLOB_WIDE_STRING) { wchar_t *s = Yap_BlobWideStringOfTerm(t); - wrputc('"', wglb->writewch); + if (wglb->Write_strings) + wrputc('`',wglb->stream); + else + wrputc('"', wglb->stream); while (*s) { - wrputc(*s++, wglb->writewch); + wrputc(*s++, wglb->stream); } - wrputc('"',wglb->writewch); + if (wglb->Write_strings) + wrputc('`',wglb->stream); + else + wrputc('"',wglb->stream); return; + } else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) { + Opaque_CallOnWrite f; + CELL blob_info; + + blob_info = big_tag - USER_BLOB_START; + if (GLOBAL_OpaqueHandlers && + (f= GLOBAL_OpaqueHandlers[blob_info].write_handler)) { + (f)(wglb->stream, big_tag, (void *)((MP_INT *)(pt+1)), 0); + } } - wrputs("0",wglb->writewch); + wrputs("0",wglb->stream); } static void -wrputf(Float f, wrf writewch) /* writes a float */ +wrputf(Float f, struct write_globs *wglb) /* writes a float */ { - CACHE_REGS - char s[256], *pt = s, ch; - int found_dot = FALSE, found_exp = FALSE; + char s[256]; + wrf stream = wglb->stream; #if HAVE_ISNAN || defined(__WIN32) if (isnan(f)) { - wrputs("(nan)", writewch); + wrputs("(nan)", stream); lastw = separator; return; } #endif - if (f < 0) { #if HAVE_ISINF || defined(_WIN32) if (isinf(f)) { - wrputs("(-inf)", writewch); + if (f < 0) { + wrputs("(-inf)", stream); + } else { + wrputs("(+inf)", stream); + } lastw = separator; return; } #endif - if (lastw == symbol) - wrputc(' ', writewch); - } else { -#if HAVE_ISINF || defined(_WIN32) - if (isinf(f)) { - wrputs("(+inf)", writewch); - lastw = separator; - return; - } -#endif - if (lastw == alphanum) - wrputc(' ', writewch); +#if THREADS + /* old style writing */ + int found_dot = FALSE, found_exp = FALSE; + char *pt = s; + int ch; + + if (lastw == symbol) { + wrputc(' ', stream); + } else if (lastw == alphanum) { + wrputc(' ', stream); } lastw = alphanum; // sprintf(s, "%.15g", f); @@ -270,45 +284,72 @@ wrputf(Float f, wrf writewch) /* writes a float */ while (*pt == ' ') pt++; if (*pt == '-') { - wrputc('-', writewch); + wrputc('-', stream); pt++; } while ((ch = *pt) != '\0') { switch (ch) { case '.': found_dot = TRUE; - wrputc('.', writewch); + wrputc('.', stream); break; case 'e': case 'E': if (!found_dot) { - found_dot = TRUE; - wrputs(".0", writewch); + found_dot = TRUE; + wrputs(".0", stream); } found_exp = TRUE; default: - wrputc(ch, writewch); + wrputc(ch, stream); } pt++; } if (!found_dot) { - wrputs(".0", writewch); + wrputs(".0", stream); } +#else + char *format_float(double f, char *buf); + char *buf; + + /* use SWI's format_float */ + buf = format_float(f, s); + if (!buf) return; + wrputs(buf, stream); +#endif } +/* writes a data base reference */ static void -wrputref(CODEADDR ref, int Quote_illegal, wrf writewch) /* writes a data base reference */ - +wrputref(CODEADDR ref, int Quote_illegal, struct write_globs *wglb) { char s[256]; + wrf stream = wglb->stream; - putAtom(AtomDBref, Quote_illegal, writewch); + putAtom(AtomDBref, Quote_illegal, wglb); #if defined(__linux__) || defined(__APPLE__) sprintf(s, "(%p," UInt_FORMAT ")", ref, ((LogUpdClause*)ref)->ClRefCount); #else sprintf(s, "(0x%p," UInt_FORMAT ")", ref, ((LogUpdClause*)ref)->ClRefCount); #endif - wrputs(s, writewch); + wrputs(s, stream); + lastw = alphanum; +} + +/* writes a blob (default) */ +static void +wrputblob(CODEADDR ref, int Quote_illegal, struct write_globs *wglb) +{ + char s[256]; + wrf stream = wglb->stream; + + putAtom(AtomSWIStream, Quote_illegal, wglb); +#if defined(__linux__) || defined(__APPLE__) + sprintf(s, "(%p)", ref); +#else + sprintf(s, "(0x%p)", ref); +#endif + wrputs(s, stream); lastw = alphanum; } @@ -361,55 +402,54 @@ AtomIsSymbols(unsigned char *s) /* Is this atom just formed by symbols ? */ } static void -write_quoted(int ch, int quote, wrf writewch) +write_quoted(int ch, int quote, wrf stream) { - CACHE_REGS if (yap_flags[CHARACTER_ESCAPE_FLAG] == CPROLOG_CHARACTER_ESCAPES) { - wrputc(ch, writewch); + wrputc(ch, stream); if (ch == '\'') - wrputc('\'', writewch); /* be careful about quotes */ + wrputc('\'', stream); /* be careful about quotes */ return; } if (!(ch < 0xff && chtype(ch) == BS) && ch != '\'' && ch != '\\') { - wrputc(ch, writewch); + wrputc(ch, stream); } else { switch (ch) { case '\\': case '\'': - wrputc('\\', writewch); - wrputc(ch, writewch); + wrputc('\\', stream); + wrputc(ch, stream); break; case 7: - wrputc('\\', writewch); - wrputc('a', writewch); + wrputc('\\', stream); + wrputc('a', stream); break; case '\b': - wrputc('\\', writewch); - wrputc('b', writewch); + wrputc('\\', stream); + wrputc('b', stream); break; case '\t': - wrputc('\\', writewch); - wrputc('t', writewch); + wrputc('\\', stream); + wrputc('t', stream); break; case ' ': case 160: - wrputc(' ', writewch); + wrputc(' ', stream); break; case '\n': - wrputc('\\', writewch); - wrputc('n', writewch); + wrputc('\\', stream); + wrputc('n', stream); break; case 11: - wrputc('\\', writewch); - wrputc('v', writewch); + wrputc('\\', stream); + wrputc('v', stream); break; case '\r': - wrputc('\\', writewch); - wrputc('r', writewch); + wrputc('\\', stream); + wrputc('r', stream); break; case '\f': - wrputc('\\', writewch); - wrputc('f', writewch); + wrputc('\\', stream); + wrputc('f', stream); break; default: if ( ch <= 0xff ) { @@ -421,61 +461,63 @@ write_quoted(int ch, int quote, wrf writewch) /* last backslash in ISO mode */ sprintf(esc, "\\%03o\\", ch); } - wrputs(esc, writewch); + wrputs(esc, stream); } } } } +/* writes an atom */ static void -putAtom(Atom atom, int Quote_illegal, wrf writewch) /* writes an atom */ - +putAtom(Atom atom, int Quote_illegal, struct write_globs *wglb) { - CACHE_REGS - unsigned char *s = (unsigned char *)RepAtom(atom)->StrOfAE; - wtype atom_or_symbol = AtomIsSymbols(s); + unsigned char *s; + wtype atom_or_symbol; + wrf stream = wglb->stream; + if (IsBlob(atom)) { + wrputblob((CODEADDR)RepAtom(atom),wglb->Quote_illegal,wglb); + return; + } + if (IsWideAtom(atom)) { + wchar_t *ws = RepAtom(atom)->WStrOfAE; + + if (Quote_illegal) { + wrputc('\'', stream); + while (*ws) { + wchar_t ch = *ws++; + write_quoted(ch, '\'', stream); + } + wrputc('\'', stream); + } else { + wrputws(ws, stream); + } + return; + } + s = (unsigned char *)RepAtom(atom)->StrOfAE; /* #define CRYPT_FOR_STEVE 1*/ #ifdef CRYPT_FOR_STEVE if (Yap_GetValue(AtomCryptAtoms) != TermNil && Yap_GetAProp(atom, OpProperty) == NIL) { char s[16]; sprintf(s,"x%x", (CELL)s); - wrputs(s, writewch); + wrputs(s, stream); return; } #endif - if (IsBlob(atom)) { - wrputref((CODEADDR)RepAtom(atom),1,writewch); - return; - } - if (IsWideAtom(atom)) { - wchar_t *ws = (wchar_t *)s; - - if (Quote_illegal) { - wrputc('\'', writewch); - while (*ws) { - wchar_t ch = *ws++; - write_quoted(ch, '\'', writewch); - } - wrputc('\'', writewch); - } else { - wrputws(ws, writewch); - } - return; - } + atom_or_symbol = AtomIsSymbols(s); if (lastw == atom_or_symbol && atom_or_symbol != separator /* solo */) - wrputc(' ', writewch); + wrputc(' ', stream); lastw = atom_or_symbol; if (Quote_illegal && !legalAtom(s)) { - wrputc('\'', writewch); + wrputc('\'', stream); while (*s) { wchar_t ch = *s++; - write_quoted(ch, '\'', writewch); + write_quoted(ch, '\'', stream); } - wrputc('\'', writewch); + wrputc('\'', stream); } else { - wrputs((char *)s, writewch); + wrputs((char *)s, stream); } } @@ -501,43 +543,46 @@ IsStringTerm(Term string) /* checks whether this is a string */ return(TRUE); } +/* writes a string */ static void -putString(Term string, wrf writewch) /* writes a string */ +putString(Term string, struct write_globs *wglb) { - CACHE_REGS - wrputc('"', writewch); + wrf stream = wglb->stream; + wrputc('"', stream); while (string != TermNil) { int ch = IntOfTerm(HeadOfTerm(string)); - write_quoted(ch, '"', writewch); + write_quoted(ch, '"', stream); string = TailOfTerm(string); } - wrputc('"', writewch); + wrputc('"', stream); lastw = alphanum; } +/* writes a string */ static void -putUnquotedString(Term string, wrf writewch) /* writes a string */ +putUnquotedString(Term string, struct write_globs *wglb) { - CACHE_REGS + wrf stream = wglb->stream; while (string != TermNil) { int ch = IntOfTerm(HeadOfTerm(string)); - wrputc(ch, writewch); + wrputc(ch, stream); string = TailOfTerm(string); } lastw = alphanum; } +/* writes an unbound variable */ static void write_var(CELL *t, struct write_globs *wglb, struct rewind_term *rwt) { CACHE_REGS if (lastw == alphanum) { - wrputc(' ', wglb->writewch); + wrputc(' ', wglb->stream); } - wrputc('_', wglb->writewch); + wrputc('_', wglb->stream); /* make sure we don't get no creepy spaces where they shouldn't be */ lastw = separator; if (IsAttVar(t)) { @@ -553,31 +598,31 @@ write_var(CELL *t, struct write_globs *wglb, struct rewind_term *rwt) Int sl = 0; Term l = attv->Atts; - wrputs("$AT(",wglb->writewch); + wrputs("$AT(",wglb->stream); write_var(t, wglb, rwt); - wrputc(',', wglb->writewch); - if (wglb->keep_terms) { + wrputc(',', wglb->stream); + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot((CELL)attv PASS_REGS); } writeTerm((Term)&(attv->Value), 999, 1, FALSE, wglb, rwt); - wrputc(',', wglb->writewch); + wrputc(',', wglb->stream); writeTerm(l, 999, 1, FALSE, wglb, rwt); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { attv = (attvar_record *)Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); } Yap_Portray_delays = TRUE; return; } #endif - wrputc('D', wglb->writewch); - wrputn(vcount,wglb->writewch); + wrputc('D', wglb->stream); + wrputn(vcount,wglb); #endif } else { - wrputn(((Int) (t- H0)),wglb->writewch); + wrputn(((Int) (t- H0)),wglb); } } @@ -592,7 +637,7 @@ from_pointer(CELL *ptr, struct rewind_term *rwt, struct write_globs *wglb) t = *ptr; if (!IsVarTerm(t) && !IsAtomOrIntTerm(t)) { struct rewind_term *x = rwt->parent; - if (wglb->keep_terms) { + if (wglb->Keep_terms) { rwt->u.s.old = Yap_InitSlot(t PASS_REGS); rwt->u.s.ptr = Yap_InitSlot((CELL)ptr PASS_REGS); while (x) { @@ -619,7 +664,7 @@ static Term check_infinite_loop(Term t, struct rewind_term *x, struct write_globs *wglb) { CACHE_REGS - if (wglb->keep_terms) { + if (wglb->Keep_terms) { while (x) { if (Yap_GetFromSlot(x->u.s.old PASS_REGS) == t) return TermFoundVar; @@ -642,8 +687,7 @@ restore_from_write(struct rewind_term *rwt, struct write_globs *wglb) Term t; if (rwt->u.s.ptr) { CELL *ptr; - if (wglb->keep_terms) { - ptr = (CELL *)Yap_GetPtrFromSlot(rwt->u.s.ptr PASS_REGS); + if (wglb->Keep_terms) { t = Yap_GetPtrFromSlot(rwt->u.s.old PASS_REGS); Yap_RecoverSlots(2 PASS_REGS); } else { @@ -668,13 +712,13 @@ write_list(Term t, int direction, int depth, struct write_globs *wglb, struct re int ndirection; int do_jump; - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(from_pointer(RepPair(t), &nrwt, wglb), 999, depth+1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } @@ -689,16 +733,16 @@ write_list(Term t, int direction, int depth, struct write_globs *wglb, struct re if (ndirection > 0) { do_jump = (direction <= 0); } else if (ndirection == 0) { - wrputc(',', wglb->writewch); - putAtom(AtomFoundVar, wglb->Quote_illegal, wglb->writewch); + wrputc(',', wglb->stream); + putAtom(AtomFoundVar, wglb->Quote_illegal, wglb); lastw = separator; return; } else { do_jump = (direction >= 0); } if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) { - wrputc('|', wglb->writewch); - putAtom(Atom3Dots, wglb->Quote_illegal, wglb->writewch); + wrputc('|', wglb->stream); + putAtom(Atom3Dots, wglb->Quote_illegal, wglb); return; } lastw = separator; @@ -706,23 +750,23 @@ write_list(Term t, int direction, int depth, struct write_globs *wglb, struct re depth++; if (do_jump) break; - wrputc(',', wglb->writewch); + wrputc(',', wglb->stream); t = ti; } if (IsPairTerm(ti)) { Term nt = from_pointer(RepPair(t)+1, &nrwt, wglb); /* we found an infinite loop */ if (IsAtomTerm(nt)) { - wrputc('|', wglb->writewch); + wrputc('|', wglb->stream); writeTerm(nt, 999, depth, FALSE, wglb, rwt); } else { /* keep going on the list */ - wrputc(',', wglb->writewch); + wrputc(',', wglb->stream); write_list(nt, direction, depth, wglb, &nrwt); } restore_from_write(&nrwt, wglb); } else if (ti != MkAtomTerm(AtomNil)) { - wrputc('|', wglb->writewch); + wrputc('|', wglb->stream); lastw = separator; writeTerm(from_pointer(RepPair(t)+1, &nrwt, wglb), 999, depth, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); @@ -741,7 +785,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str nrwt.u.s.ptr = 0; if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) { - putAtom(Atom3Dots, wglb->Quote_illegal, wglb->writewch); + putAtom(Atom3Dots, wglb->Quote_illegal, wglb); return; } if (EX) @@ -750,39 +794,39 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str if (IsVarTerm(t)) { write_var((CELL *)t, wglb, &nrwt); } else if (IsIntTerm(t)) { - wrputn((Int) IntOfTerm(t),wglb->writewch); + wrputn((Int) IntOfTerm(t),wglb); } else if (IsAtomTerm(t)) { - putAtom(AtomOfTerm(t), wglb->Quote_illegal, wglb->writewch); + putAtom(AtomOfTerm(t), wglb->Quote_illegal, wglb); } else if (IsPairTerm(t)) { if (wglb->Ignore_ops) { Int sl = 0; - wrputs("'.'(",wglb->writewch); + wrputs("'.'(",wglb->stream); lastw = separator; - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(HeadOfTerm(t), 999, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } - wrputs(",",wglb->writewch); - if (wglb->keep_terms) { + wrputs(",",wglb->stream); + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(TailOfTerm(t), 999, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; return; } @@ -803,13 +847,13 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str return; } if (yap_flags[WRITE_QUOTED_STRING_FLAG] && IsStringTerm(t)) { - putString(t, wglb->writewch); + putString(t, wglb); } else { - wrputc('[', wglb->writewch); + wrputc('[', wglb->stream); lastw = separator; /* we assume t was already saved in the stack */ write_list(t, 0, depth, wglb, rwt); - wrputc(']', wglb->writewch); + wrputc(']', wglb->stream); lastw = separator; } } else { /* compound term */ @@ -821,16 +865,16 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str if (IsExtensionFunctor(functor)) { switch((CELL)functor) { case (CELL)FunctorDouble: - wrputf(FloatOfTerm(t),wglb->writewch); + wrputf(FloatOfTerm(t),wglb); return; case (CELL)FunctorAttVar: write_var(RepAppl(t)+1, wglb, &nrwt); return; case (CELL)FunctorDBRef: - wrputref(RefOfTerm(t), wglb->Quote_illegal, wglb->writewch); + wrputref(RefOfTerm(t), wglb->Quote_illegal, wglb); return; case (CELL)FunctorLongInt: - wrputn(LongIntOfTerm(t),wglb->writewch); + wrputn(LongIntOfTerm(t),wglb); return; /* case (CELL)FunctorBigInt: */ default: @@ -844,35 +888,35 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str if (Arity == SFArity) { int argno = 1; CELL *p = ArgsOfSFTerm(t); - putAtom(atom, wglb->Quote_illegal, wglb->writewch); - wrputc('(', wglb->writewch); + putAtom(atom, wglb->Quote_illegal, wglb); + wrputc('(', wglb->stream); lastw = separator; while (*p) { Int sl = 0; while (argno < *p) { - wrputc('_', wglb->writewch), wrputc(',', wglb->writewch); + wrputc('_', wglb->stream), wrputc(',', wglb->stream); ++argno; } *p++; lastw = separator; /* cannot use the term directly with the SBA */ - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot((CELL)p); } writeTerm(from_pointer(p++, &nrwt, wglb), 999, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ p = (CELL *)Yap_GetFromSlot(sl); Yap_RecoverSlots(1); } if (*p) - wrputc(',', wglb->writewch); + wrputc(',', wglb->stream); argno++; } - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; return; } @@ -911,23 +955,23 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str if (op > p) { /* avoid stuff such as \+ (a,b) being written as \+(a,b) */ if (lastw != separator && !rinfixarg) - wrputc(' ', wglb->writewch); - wrputc('(', wglb->writewch); + wrputc(' ', wglb->stream); + wrputc('(', wglb->stream); lastw = separator; } - putAtom(atom, wglb->Quote_illegal, wglb->writewch); + putAtom(atom, wglb->Quote_illegal, wglb); if (bracket_right) { - wrputc('(', wglb->writewch); + wrputc('(', wglb->stream); lastw = separator; } writeTerm(from_pointer(RepAppl(t)+1, &nrwt, wglb), rp, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); if (bracket_right) { - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } if (op > p) { - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } } else if (!wglb->Ignore_ops && @@ -941,32 +985,32 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str if (op > p) { /* avoid stuff such as \+ (a,b) being written as \+(a,b) */ if (lastw != separator && !rinfixarg) - wrputc(' ', wglb->writewch); - wrputc('(', wglb->writewch); + wrputc(' ', wglb->stream); + wrputc('(', wglb->stream); lastw = separator; } if (bracket_left) { - wrputc('(', wglb->writewch); + wrputc('(', wglb->stream); lastw = separator; } - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(from_pointer(RepAppl(t)+1, &nrwt, wglb), lp, depth + 1, rinfixarg, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } if (bracket_left) { - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } - putAtom(atom, wglb->Quote_illegal, wglb->writewch); + putAtom(atom, wglb->Quote_illegal, wglb); if (op > p) { - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } } else if (!wglb->Ignore_ops && @@ -985,167 +1029,167 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str if (op > p) { /* avoid stuff such as \+ (a,b) being written as \+(a,b) */ if (lastw != separator && !rinfixarg) - wrputc(' ', wglb->writewch); - wrputc('(', wglb->writewch); + wrputc(' ', wglb->stream); + wrputc('(', wglb->stream); lastw = separator; } if (bracket_left) { - wrputc('(', wglb->writewch); + wrputc('(', wglb->stream); lastw = separator; } - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(from_pointer(RepAppl(t)+1, &nrwt, wglb), lp, depth + 1, rinfixarg, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } if (bracket_left) { - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } /* avoid quoting commas */ if (strcmp(RepAtom(atom)->StrOfAE,",")) - putAtom(atom, wglb->Quote_illegal, wglb->writewch); + putAtom(atom, wglb->Quote_illegal, wglb); else { - wrputc(',', wglb->writewch); + wrputc(',', wglb->stream); lastw = separator; } if (bracket_right) { - wrputc('(', wglb->writewch); + wrputc('(', wglb->stream); lastw = separator; } writeTerm(from_pointer(RepAppl(t)+2, &nrwt, wglb), rp, depth + 1, TRUE, wglb, &nrwt); restore_from_write(&nrwt, wglb); if (bracket_right) { - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } if (op > p) { - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } } else if (wglb->Handle_vars && functor == FunctorVar) { Term ti = ArgOfTerm(1, t); if (lastw == alphanum) { - wrputc(' ', wglb->writewch); + wrputc(' ', wglb->stream); } - if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsStringTerm(ti))) { + if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsStringTerm(ti) || IsAtomTerm(ti))) { if (IsIntTerm(ti)) { Int k = IntOfTerm(ti); if (k == -1) { - wrputc('_', wglb->writewch); + wrputc('_', wglb->stream); lastw = alphanum; return; } else { - wrputc((k % 26) + 'A', wglb->writewch); + wrputc((k % 26) + 'A', wglb->stream); if (k >= 26) { /* make sure we don't get confused about our context */ lastw = separator; - wrputn( k / 26 ,wglb->writewch); + wrputn( k / 26 ,wglb); } else lastw = alphanum; } + } else if (IsAtomTerm(ti)) { + putAtom(AtomOfTerm(ti), FALSE, wglb); } else { - putUnquotedString(ti, wglb->writewch); + putUnquotedString(ti, wglb); } } else { Int sl = 0; - wrputs("'$VAR'(",wglb->writewch); + wrputs("'$VAR'(",wglb->stream); lastw = separator; - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(from_pointer(RepAppl(t)+1, &nrwt, wglb), 999, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } } else if (!wglb->Ignore_ops && functor == FunctorBraces) { - wrputc('{', wglb->writewch); + wrputc('{', wglb->stream); lastw = separator; writeTerm(from_pointer(RepAppl(t)+1, &nrwt, wglb), 1200, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - wrputc('}', wglb->writewch); + wrputc('}', wglb->stream); lastw = separator; } else if (atom == AtomArray) { Int sl = 0; - wrputc('{', wglb->writewch); + wrputc('{', wglb->stream); lastw = separator; for (op = 1; op <= Arity; ++op) { if (op == wglb->MaxArgs) { - wrputc('.', wglb->writewch); - wrputc('.', wglb->writewch); - wrputc('.', wglb->writewch); + wrputs("...", wglb->stream); break; } - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(from_pointer(RepAppl(t)+op, &nrwt, wglb), 999, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } if (op != Arity) { - wrputc(',', wglb->writewch); + wrputc(',', wglb->stream); lastw = separator; } } - wrputc('}', wglb->writewch); + wrputc('}', wglb->stream); lastw = separator; } else { - putAtom(atom, wglb->Quote_illegal, wglb->writewch); + putAtom(atom, wglb->Quote_illegal, wglb); lastw = separator; - wrputc('(', wglb->writewch); + wrputc('(', wglb->stream); for (op = 1; op <= Arity; ++op) { Int sl = 0; if (op == wglb->MaxArgs) { - wrputc('.', wglb->writewch); - wrputc('.', wglb->writewch); - wrputc('.', wglb->writewch); + wrputc('.', wglb->stream); + wrputc('.', wglb->stream); + wrputc('.', wglb->stream); break; } - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ sl = Yap_InitSlot(t PASS_REGS); } writeTerm(from_pointer(RepAppl(t)+op, &nrwt, wglb), 999, depth + 1, FALSE, wglb, &nrwt); restore_from_write(&nrwt, wglb); - if (wglb->keep_terms) { + if (wglb->Keep_terms) { /* garbage collection may be called */ t = Yap_GetFromSlot(sl PASS_REGS); Yap_RecoverSlots(1 PASS_REGS); } if (op != Arity) { - wrputc(',', wglb->writewch); + wrputc(',', wglb->stream); lastw = separator; } } - wrputc(')', wglb->writewch); + wrputc(')', wglb->stream); lastw = separator; } } } void -Yap_plwrite(Term t, int (*mywrite) (int, wchar_t), int flags, int priority) +Yap_plwrite(Term t, void *mywrite, int max_depth, int flags, int priority) /* term to be written */ /* consumer */ /* write options */ @@ -1153,19 +1197,24 @@ Yap_plwrite(Term t, int (*mywrite) (int, wchar_t), int flags, int priority) struct write_globs wglb; struct rewind_term rwt; - wglb.writewch = mywrite; - lastw = separator; + if (!mywrite) + wglb.stream = Serror; + else + wglb.stream = mywrite; + + wglb.lw = separator; wglb.Quote_illegal = flags & Quote_illegal_f; wglb.Handle_vars = flags & Handle_vars_f; wglb.Use_portray = flags & Use_portray_f; - wglb.MaxDepth = 15L; - wglb.MaxArgs = 15L; + wglb.MaxDepth = max_depth; + wglb.MaxArgs = max_depth; /* notice: we must have ASP well set when using portray, otherwise we cannot make recursive Prolog calls */ - wglb.keep_terms = (flags & (Use_portray_f|To_heap_f)); + wglb.Keep_terms = (flags & (Use_portray_f|To_heap_f)); /* initialise wglb */ rwt.parent = NULL; wglb.Ignore_ops = flags & Ignore_ops_f; + wglb.Write_strings = flags & BackQuote_String_f; /* protect slots for portray */ writeTerm(from_pointer(&t, &rwt, &wglb), priority, 1, FALSE, &wglb, &rwt); restore_from_write(&rwt, &wglb); diff --git a/H/Yap.h b/H/Yap.h index b2dbda484..e79af7927 100644 --- a/H/Yap.h +++ b/H/Yap.h @@ -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" diff --git a/H/Yapproto.h b/H/Yapproto.h index 43e55867c..7d6c2030f 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -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 diff --git a/H/iatoms.h b/H/iatoms.h index c1ec9e52a..af72f9f4d 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -272,6 +272,7 @@ AtomStaticClause = Yap_FullLookupAtom("$static_clause"); AtomStaticProcedure = Yap_LookupAtom("static_procedure"); AtomStream = Yap_FullLookupAtom("$stream"); + AtomSWIStream = Yap_FullLookupAtom(""); AtomVStream = Yap_LookupAtom("stream"); AtomStreams = Yap_LookupAtom("streams"); AtomStreamOrAlias = Yap_LookupAtom("stream_or_alias"); diff --git a/H/pl-yap.h b/H/pl-yap.h index b474639f2..2a7f89521 100644 --- a/H/pl-yap.h +++ b/H/pl-yap.h @@ -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) diff --git a/H/ratoms.h b/H/ratoms.h index e7bad9b88..7f7124d5b 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -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); diff --git a/H/tatoms.h b/H/tatoms.h index 94dd6d799..ce5498ff0 100644 --- a/H/tatoms.h +++ b/H/tatoms.h @@ -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_; diff --git a/H/yapio.h b/H/yapio.h index 1b2f0abd8..f2ff4ede0 100644 --- a/H/yapio.h +++ b/H/yapio.h @@ -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 diff --git a/LGPL/Makefile.in b/LGPL/Makefile.in index 6468ec972..0c91843a9 100644 --- a/LGPL/Makefile.in +++ b/LGPL/Makefile.in @@ -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 \ diff --git a/LGPL/README b/LGPL/README index c4ddb1f11..82999076d 100644 --- a/LGPL/README +++ b/LGPL/README @@ -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. diff --git a/LGPL/pairs.pl b/LGPL/pairs.pl new file mode 100644 index 000000000..ab5b66cbf --- /dev/null +++ b/LGPL/pairs.pl @@ -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 + ]). + +/** 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). + diff --git a/LGPL/predicate_options.pl b/LGPL/predicate_options.pl new file mode 100644 index 000000000..297a20625 --- /dev/null +++ b/LGPL/predicate_options.pl @@ -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(:). + +/** 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)). diff --git a/LGPL/predopts.pl b/LGPL/predopts.pl new file mode 100644 index 000000000..b9653626b --- /dev/null +++ b/LGPL/predopts.pl @@ -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). diff --git a/LGPL/prolog_clause.pl b/LGPL/prolog_clause.pl new file mode 100644 index 000000000..06afeff85 --- /dev/null +++ b/LGPL/prolog_clause.pl @@ -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. + +/** 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 and +% +% 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 = [''=IVar|Names], + Out is Arity + 1, + memberchk(Out=OVar, Offsets), + Names2 = [''=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) * + *******************************/ + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + (Receiver, ... Arg ...) :-> + Body + +mapped to: + + send_implementation(Id, (...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(_, ''). diff --git a/LGPL/prolog_colour.pl b/LGPL/prolog_colour.pl new file mode 100644 index 000000000..8b4fe1cfe --- /dev/null +++ b/LGPL/prolog_colour.pl @@ -0,0 +1,1508 @@ +/* Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: J.Wielemaker@cs.vu.nl + WWW: http://www.swi-prolog.org/projects/xpce/ + 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_colour, + [ prolog_colourise_stream/3, % +Stream, +SourceID, :ColourItem + prolog_colourise_term/4, % +Stream, +SourceID, :ColourItem, +Options + syntax_colour/2, % +Class, -Attributes + syntax_message//1 % +Class + ]). +:- use_module(library(prolog_xref)). +:- use_module(library(predicate_options)). +:- use_module(library(prolog_source)). +:- use_module(library(lists)). +:- use_module(library(operators)). +:- use_module(library(debug)). +:- use_module(library(edit)). +:- use_module(library(error)). +:- use_module(library(option)). +:- use_module(library(record)). +:- if(exists_source(library(pce_meta))). +:- use_module(library(pce_meta)). +:- endif. + +:- meta_predicate + prolog_colourise_stream(+, +, 3), + prolog_colourise_term(+, +, 3, +). + +:- predicate_options(prolog_colourise_term/4, 4, + [ subterm_positions(-any) + ]). + +/** Prolog syntax colouring support. + +This module defines reusable code to colourise Prolog source. + +@tbd: The one-term version +*/ + + +:- multifile + style/2, % +ColourClass, -Attributes + message//1, % +ColourClass + term_colours/2, % +SourceTerm, -ColourSpec + goal_colours/2, % +Goal, -ColourSpec + directive_colours/2, % +Goal, -ColourSpec + goal_classification/2. % +Goal, -Class + + +:- record + colour_state(source_id, + closure, + singletons). + +%% prolog_colourise_stream(+Stream, +SourceID, :ColourItem) is det. +% +% Determine colour fragments for the data on Stream. SourceID is +% the canonical identifier of the input as known to the +% cross-referencer, i.e., as created using xref_source(SourceID). +% +% ColourItem is a closure that is called for each identified +% fragment with three additional arguments: +% +% * The syntactical category +% * Start position (character offset) of the fragment +% * Length of the fragment (in characters). + +prolog_colourise_stream(Fd, SourceId, ColourItem) :- + make_colour_state([ source_id(SourceId), + closure(ColourItem) + ], + TB), + setup_call_cleanup( + save_settings(State), + colourise_stream(Fd, TB), + restore_settings(State)). + +colourise_stream(Fd, TB) :- + ( peek_char(Fd, #) % skip #! script line + -> skip(Fd, 10) + ; true + ), + repeat, + '$set_source_module'(SM, SM), + character_count(Fd, Start), + catch(read_term(Fd, Term, + [ subterm_positions(TermPos), + singletons(Singletons), + module(SM), + comments(Comments) + ]), + E, + read_error(E, TB, Fd, Start)), + fix_operators(Term, TB), + colour_state_singletons(TB, Singletons), + ( colourise_term(Term, TB, TermPos, Comments) + -> true + ; arg(1, TermPos, From), + print_message(warning, + format('Failed to colourise ~p at index ~d~n', + [Term, From])) + ), + Term == end_of_file, !. + +save_settings(state(Style, Esc)) :- + push_operators([]), + current_prolog_flag(character_escapes, Esc), + '$style_check'(Style, Style). + +restore_settings(state(Style, Esc)) :- + set_prolog_flag(character_escapes, Esc), + '$style_check'(_, Style), + pop_operators. + +%% read_error(+Error, +TB, +Stream, +Start) is failure. +% +% If this is a syntax error, create a syntax-error fragment. + +read_error(Error, TB, Stream, Start) :- + ( Error = error(syntax_error(Id), stream(_S, _Line, _LinePos, CharNo)) + -> message_to_string(error(syntax_error(Id), _), Msg), + character_count(Stream, End), + show_syntax_error(TB, CharNo:Msg, Start-End), + fail + ; throw(Error) + ). + +%% colour_item(+Class, +TB, +Pos) is det. + +colour_item(Class, TB, Pos) :- + arg(1, Pos, Start), + arg(2, Pos, End), + Len is End - Start, + colour_state_closure(TB, Closure), + call(Closure, Class, Start, Len). + + +%% safe_push_op(+Prec, +Type, :Name) +% +% Define operators into the default source module and register +% them to be undone by pop_operators/0. + +safe_push_op(P, T, N0) :- + ( N0 = _:_ + -> N = N0 + ; '$set_source_module'(M, M), + N = M:N0 + ), + push_op(P, T, N), + debug(colour, ':- ~w.', [op(P,T,N)]). + +%% fix_operators(+Term, +Src) is det. +% +% Fix flags that affect the syntax, such as operators and some +% style checking options. Src is the canonical source as required +% by the cross-referencer. + +fix_operators((:- Directive), Src) :- + catch(process_directive(Directive, Src), _, true), !. +fix_operators(_, _). + +process_directive(style_check(X), _) :- !, + style_check(X). +process_directive(op(P,T,N), _) :- !, + safe_push_op(P, T, N). +process_directive(module(_Name, Export), _) :- !, + forall(member(op(P,A,N), Export), + safe_push_op(P,A,N)). +process_directive(use_module(Spec), Src) :- !, + catch(process_use_module(Spec, Src), _, true). +process_directive(Directive, Src) :- + prolog_source:expand((:-Directive), Src, _). + +%% process_use_module(+Imports, +Src) +% +% Get the exported operators from the referenced files. + +process_use_module([], _) :- !. +process_use_module([H|T], Src) :- !, + process_use_module(H, Src), + process_use_module(T, Src). +process_use_module(File, Src) :- + ( xref_public_list(File, _Path, Public, Src) + -> forall(member(op(P,T,N), Public), + safe_push_op(P,T,N)) + ; true + ). + +%% prolog_colourise_term(+Stream, +SourceID, :ColourItem, +Options) +% +% Colourise the next term on Stream. Unlike +% prolog_colourise_stream/3, this predicate assumes it is reading +% a single term rather than the entire stream. This implies that +% it cannot adjust syntax according to directives that preceed it. +% +% Options: +% +% * subterm_positions(-TermPos) +% Return complete term-layout. If an error is read, this is a +% term error_position(StartClause, EndClause, ErrorPos) + +prolog_colourise_term(Stream, SourceId, ColourItem, Options) :- + make_colour_state([ source_id(SourceId), + closure(ColourItem) + ], + TB), + option(subterm_positions(TermPos), Options, _), + findall(Op, xref_op(SourceId, Op), Ops), + character_count(Stream, Start), + read_source_term_at_location( + Stream, Term, + [ module(prolog_colour), + operators(Ops), + error(Error), + subterm_positions(TermPos), + singletons(Singletons), + comments(Comments) + ]), + ( var(Error) + -> colour_state_singletons(TB, Singletons), + colour_item(range, TB, TermPos), % Call to allow clearing + colourise_term(Term, TB, TermPos, Comments) + ; character_count(Stream, End), + TermPos = error_position(Start, End, Pos), + colour_item(range, TB, TermPos), + show_syntax_error(TB, Error, Start-End), + Error = Pos:_Message + ). + +show_syntax_error(TB, Pos:Message, Range) :- + End is Pos + 1, + colour_item(syntax_error(Message, Range), TB, Pos-End). + + +singleton(Var, TB) :- + colour_state_singletons(TB, Singletons), + member_var(Var, Singletons). + +member_var(V, [_=V2|_]) :- + V == V2, !. +member_var(V, [_|T]) :- + member_var(V, T). + +%% colourise_term(+Term, +TB, +Termpos, +Comments) + +colourise_term(Term, TB, TermPos, Comments) :- + colourise_comments(Comments, TB), + colourise_term(Term, TB, TermPos). + +colourise_comments(-, _). +colourise_comments([], _). +colourise_comments([H|T], TB) :- + colourise_comment(H, TB), + colourise_comments(T, TB). + +colourise_comment(Pos-Comment, TB) :- + stream_position_data(char_count, Pos, Start), + string_length(Comment, Len), + End is Start + Len + 1, + colour_item(comment, TB, Start-End). + +colourise_term(Term, TB, Pos) :- + term_colours(Term, FuncSpec-ArgSpecs), !, + Pos = term_position(_,_,FF,FT,ArgPos), + specified_item(FuncSpec, Term, TB, FF-FT), + specified_items(ArgSpecs, Term, TB, ArgPos). +colourise_term((Head :- Body), TB, + term_position(F,T,FF,FT,[HP,BP])) :- !, + colour_item(clause, TB, F-T), + colour_item(neck(clause), TB, FF-FT), + colourise_clause_head(Head, TB, HP), + colourise_body(Body, Head, TB, BP). +colourise_term((Head --> Body), TB, % TBD: expansion! + term_position(F,T,FF,FT,[HP,BP])) :- !, + colour_item(grammar_rule, TB, F-T), + colour_item(neck(grammar_rule), TB, FF-FT), + colourise_extended_head(Head, 2, TB, HP), + colourise_dcg(Body, Head, TB, BP). +colourise_term(:->(Head, Body), TB, + term_position(F,T,FF,FT,[HP,BP])) :- !, + colour_item(method, TB, F-T), + colour_item(neck(method(send)), TB, FF-FT), + colour_method_head(send(Head), TB, HP), + colourise_method_body(Body, TB, BP). +colourise_term(:<-(Head, Body), TB, + term_position(F,T,FF,FT,[HP,BP])) :- !, + colour_item(method, TB, F-T), + colour_item(neck(method(get)), TB, FF-FT), + colour_method_head(get(Head), TB, HP), + colourise_method_body(Body, TB, BP). +colourise_term((:- Directive), TB, Pos) :- !, + colour_item(directive, TB, Pos), + arg(5, Pos, [ArgPos]), + colourise_directive(Directive, TB, ArgPos). +colourise_term((?- Directive), TB, Pos) :- !, + colourise_term((:- Directive), TB, Pos). +colourise_term(end_of_file, _, _) :- !. +colourise_term(Fact, TB, Pos) :- !, + colour_item(clause, TB, Pos), + colourise_clause_head(Fact, TB, Pos). + +%% colourise_extended_head(+Head, +ExtraArgs, +TB, +Pos) is det. +% +% Colourise a clause-head that is extended by term_expansion, +% getting ExtraArgs more arguments (e.g., DCGs add two more +% arguments. + +colourise_extended_head(Head, N, TB, Pos) :- + extend(Head, N, TheHead), + colourise_clause_head(TheHead, TB, Pos). + +extend(M:Head, N, M:ExtHead) :- + nonvar(Head), !, + extend(Head, N, ExtHead). +extend(Head, N, ExtHead) :- + callable(Head), !, + Head =.. List, + length(Extra, N), + append(List, Extra, List1), + ExtHead =.. List1. +extend(Head, _, Head). + + +colourise_clause_head(Head, TB, Pos) :- + head_colours(Head, ClassSpec-ArgSpecs), !, + functor_position(Pos, FPos, ArgPos), + ( ClassSpec == classify + -> classify_head(TB, Head, Class) + ; Class = ClassSpec + ), + colour_item(head(Class), TB, FPos), + specified_items(ArgSpecs, Head, TB, ArgPos). +colourise_clause_head(Head, TB, Pos) :- + functor_position(Pos, FPos, _), + classify_head(TB, Head, Class), + colour_item(head(Class), TB, FPos), + colourise_term_args(Head, TB, Pos). + +% colourise_extern_head(+Head, +Module, +TB, +Pos) +% +% Colourise the head specified as Module:Head. Normally used for +% adding clauses to multifile predicates in other modules. + +colourise_extern_head(Head, M, TB, Pos) :- + functor_position(Pos, FPos, _), + colour_item(head(extern(M)), TB, FPos), + colourise_term_args(Head, TB, Pos). + +colour_method_head(SGHead, TB, Pos) :- + arg(1, SGHead, Head), + functor(SGHead, SG, _), + functor_position(Pos, FPos, _), + colour_item(method(SG), TB, FPos), + colourise_term_args(Head, TB, Pos). + +% functor_position(+Term, -FunctorPos, -ArgPosList) +% +% Get the position of a functor and its argument. Unfortunately +% this goes wrong for lists, who have two `functor-positions'. + +functor_position(term_position(_,_,FF,FT,ArgPos), FF-FT, ArgPos) :- !. +functor_position(list_position(F,_T,Elms,none), F-FT, Elms) :- !, + FT is F + 1. +functor_position(Pos, Pos, []). + + +%% colourise_directive(+Body, +TB, +Pos) +% +% Colourise the body of a directive. + +colourise_directive((A,B), TB, term_position(_,_,_,_,[PA,PB])) :- !, + colourise_directive(A, TB, PA), + colourise_directive(B, TB, PB). +colourise_directive(Body, TB, Pos) :- + nonvar(Body), + directive_colours(Body, ClassSpec-ArgSpecs), !, % specified + functor_position(Pos, FPos, ArgPos), + ( ClassSpec == classify + -> goal_classification(TB, Body, [], Class) + ; Class = ClassSpec + ), + colour_item(goal(Class, Body), TB, FPos), + specified_items(ArgSpecs, Body, TB, ArgPos). +colourise_directive(Body, TB, Pos) :- + colourise_body(Body, TB, Pos). + + +% colourise_body(+Body, +TB, +Pos) +% +% Breaks down to colourise_goal/3. + +colourise_body(Body, TB, Pos) :- + colourise_body(Body, [], TB, Pos). + +colourise_body(Body, Origin, TB, Pos) :- + colour_item(body, TB, Pos), + colourise_goals(Body, Origin, TB, Pos). + +%% colourise_method_body(+MethodBody, +TB, +Pos) +% +% Colourise the optional "comment":: as pce(comment) and proceed +% with the body. +% +% @tbd Get this handled by a hook. + +colourise_method_body(::(_Comment,Body), TB, + term_position(_F,_T,_FF,_FT,[CP,BP])) :- !, + colour_item(comment, TB, CP), + colourise_body(Body, TB, BP). +colourise_method_body(Body, TB, Pos) :- % deal with pri(::) < 1000 + Body =.. [F,A,B], + control_op(F), !, + Pos = term_position(_F,_T,_FF,_FT, + [ AP, + BP + ]), + colourise_method_body(A, TB, AP), + colourise_body(B, TB, BP). +colourise_method_body(Body, TB, Pos) :- + colourise_body(Body, TB, Pos). + +control_op(','). +control_op((;)). +control_op((->)). +control_op((*->)). + +colourise_goals(Body, Origin, TB, term_position(_,_,_,_,ArgPos)) :- + body_compiled(Body), !, + colourise_subgoals(ArgPos, 1, Body, Origin, TB). +colourise_goals(Goal, Origin, TB, Pos) :- + colourise_goal(Goal, Origin, TB, Pos). + +colourise_subgoals([], _, _, _, _). +colourise_subgoals([Pos|T], N, Body, Origin, TB) :- + arg(N, Body, Arg), + colourise_goals(Arg, Origin, TB, Pos), + NN is N + 1, + colourise_subgoals(T, NN, Body, Origin, TB). + +% colourise_dcg(+Body, +Head, +TB, +Pos) +% +% Breaks down to colourise_dcg_goal/3. + +colourise_dcg(Body, Head, TB, Pos) :- + colour_item(dcg, TB, Pos), + dcg_extend(Head, Origin), + colourise_dcg_goals(Body, Origin, TB, Pos). + +colourise_dcg_goals(Var, _, TB, Pos) :- + var(Var), !, + colour_item(goal(meta,Var), TB, Pos). +colourise_dcg_goals({Body}, Origin, TB, brace_term_position(F,T,Arg)) :- !, + colour_item(dcg(plain), TB, F-T), + colourise_goals(Body, Origin, TB, Arg). +colourise_dcg_goals([], _, TB, Pos) :- !, + colour_item(dcg(list), TB, Pos). +colourise_dcg_goals(List, _, TB, Pos) :- + List = [_|_], !, + colour_item(dcg(list), TB, Pos), + colourise_term_args(List, TB, Pos). +colourise_dcg_goals(Body, Origin, TB, term_position(_,_,_,_,ArgPos)) :- + body_compiled(Body), !, + colourise_dcg_subgoals(ArgPos, 1, Body, Origin, TB). +colourise_dcg_goals(Goal, Origin, TB, Pos) :- + colourise_dcg_goal(Goal, Origin, TB, Pos), + colourise_term_args(Goal, TB, Pos). + +colourise_dcg_subgoals([], _, _, _, _). +colourise_dcg_subgoals([Pos|T], N, Body, Origin, TB) :- + arg(N, Body, Arg), + colourise_dcg_goals(Arg, Origin, TB, Pos), + NN is N + 1, + colourise_dcg_subgoals(T, NN, Body, Origin, TB). + +dcg_extend(Term, _) :- + var(Term), !, fail. +dcg_extend(M:Term, M:Goal) :- + dcg_extend(Term, Goal). +dcg_extend(Term, Goal) :- + callable(Term), + Term =.. List, + append(List, [_,_], List2), + Goal =.. List2. + +% colourise_dcg_goal(+Goal, +Origin, +TB, +Pos). + +colourise_dcg_goal(!, Origin, TB, TermPos) :- !, + colourise_goal(!, Origin, TB, TermPos). +colourise_dcg_goal(Goal, Origin, TB, TermPos) :- + dcg_extend(Goal, TheGoal), !, + colourise_goal(TheGoal, Origin, TB, TermPos). +colourise_dcg_goal(Goal, _, TB, Pos) :- + colourise_term_args(Goal, TB, Pos). + + +% colourise_goal(+Goal, +Origin, +TB, +Pos) +% +% Colourise access to a single goal. + + % Deal with list as goal (consult) +colourise_goal(Goal, _, TB, list_position(F,T,Elms,_)) :- !, + FT is F + 1, + AT is T - 1, + colour_item(goal(built_in, Goal), TB, F-FT), + colour_item(goal(built_in, Goal), TB, AT-T), + colourise_file_list(Goal, TB, Elms). +colourise_goal(Goal, Origin, TB, Pos) :- + nonvar(Goal), + goal_colours(Goal, ClassSpec-ArgSpecs), !, % specified + functor_position(Pos, FPos, ArgPos), + ( ClassSpec == classify + -> goal_classification(TB, Goal, Origin, Class) + ; Class = ClassSpec + ), + colour_item(goal(Class, Goal), TB, FPos), + specified_items(ArgSpecs, Goal, TB, ArgPos). +colourise_goal(Module:Goal, _Origin, TB, term_position(_,_,_,_,[PM,PG])) :- !, + colour_item(module(Module), TB, PM), + ( PG = term_position(_,_,FF,FT,_) + -> FP = FF-FT + ; FP = PG + ), + colour_item(goal(extern(Module), Goal), TB, FP), + colourise_goal_args(Goal, TB, PG). +colourise_goal(Goal, Origin, TB, Pos) :- + goal_classification(TB, Goal, Origin, Class), + ( Pos = term_position(_,_,FF,FT,_ArgPos) + -> FPos = FF-FT + ; FPos = Pos + ), + colour_item(goal(Class, Goal), TB, FPos), + colourise_goal_args(Goal, TB, Pos). + +%% colourise_goal_args(+Goal, +TB, +Pos) +% +% Colourise the arguments to a goal. This predicate deals with +% meta- and database-access predicates. + +colourise_goal_args(Goal, TB, term_position(_,_,_,_,ArgPos)) :- + colourise_options(Goal, TB, ArgPos), + meta_args(Goal, MetaArgs), !, + colourise_meta_args(1, Goal, MetaArgs, TB, ArgPos). +colourise_goal_args(Goal, TB, Pos) :- + Pos = term_position(_,_,_,_,ArgPos), !, + colourise_options(Goal, TB, ArgPos), + colourise_term_args(Goal, TB, Pos). +colourise_goal_args(_, _, _). % no arguments + +colourise_meta_args(_, _, _, _, []) :- !. +colourise_meta_args(N, Goal, MetaArgs, TB, [P0|PT]) :- + arg(N, Goal, Arg), + arg(N, MetaArgs, MetaSpec), + colourise_meta_arg(MetaSpec, Arg, TB, P0), + NN is N + 1, + colourise_meta_args(NN, Goal, MetaArgs, TB, PT). + +colourise_meta_arg(MetaSpec, Arg, TB, Pos) :- + expand_meta(MetaSpec, Arg, Expanded), !, + colourise_goal(Expanded, [], TB, Pos). % TBD: recursion +colourise_meta_arg(_, Arg, TB, Pos) :- + colourise_term_arg(Arg, TB, Pos). + +% meta_args(+Goal, -ArgSpec) +% +% Return a copy of Goal, where each meta-argument is an integer +% representing the number of extra arguments. The non-meta +% arguments are unbound variables. +% +% E.g. meta_args(maplist(foo,x,y), X) --> X = maplist(2,_,_) +% +% NOTE: this could be cached if performance becomes an issue. + +meta_args(Goal, VarGoal) :- + xref_meta(Goal, _), + functor(Goal, Name, Arity), + functor(VarGoal, Name, Arity), + xref_meta(VarGoal, MetaArgs), + instantiate_meta(MetaArgs). + +instantiate_meta([]). +instantiate_meta([H|T]) :- + ( var(H) + -> H = 0 + ; H = V+N + -> V = N + ), + instantiate_meta(T). + +% expand_meta(+MetaSpec, +Goal, -Expanded) +% +% Add extra arguments to the goal if the meta-specifier is an +% integer (see above). + +expand_meta(MetaSpec, Goal, Goal) :- + MetaSpec == 0. +expand_meta(MetaSpec, M:Goal, M:Expanded) :- + atom(M), !, + expand_meta(MetaSpec, Goal, Expanded). +expand_meta(MetaSpec, Goal, Expanded) :- + integer(MetaSpec), + callable(Goal), !, + length(Extra, MetaSpec), + Goal =.. List0, + append(List0, Extra, List), + Expanded =.. List. + +%% colourise_setof(+Term, +TB, +Pos) +% +% Colourise the 2nd argument of setof/bagof + +colourise_setof(Var^G, TB, term_position(_,_,FF,FT,[VP,GP])) :- !, + colourise_term_arg(Var, TB, VP), + colour_item(built_in, TB, FF-FT), + colourise_setof(G, TB, GP). +colourise_setof(Term, TB, Pos) :- + colourise_goal(Term, [], TB, Pos). + +% colourise_db(+Arg, +TB, +Pos) +% +% Colourise database modification calls (assert/1, retract/1 and +% friends. + +colourise_db((Head:-_Body), TB, term_position(_,_,_,_,[HP,_])) :- !, + colourise_db(Head, TB, HP). +colourise_db(Module:Head, TB, term_position(_,_,_,_,[MP,HP])) :- !, + colour_item(module(Module), TB, MP), + ( atom(Module), + colour_state_source_id(TB, SourceId), + xref_module(SourceId, Module) + -> colourise_db(Head, TB, HP) + ; true % TBD: Modifying in other module + ). +colourise_db(Head, TB, Pos) :- + colourise_goal(Head, '', TB, Pos). + + +%% colourise_options(+Goal, +TB, +ArgPos) +% +% Colourise predicate options + +colourise_options(Goal, TB, ArgPos) :- + ( compound(Goal), + functor(Goal, Name, Arity), + ( colour_state_source_id(TB, SourceId), + xref_module(SourceId, Module) + -> true + ; Module = user + ), + current_predicate_options(Module:Name/Arity, Arg, OptionDecl), + debug(emacs, 'Colouring option-arg ~w of ~p', + [Arg, Module:Name/Arity]), + arg(Arg, Goal, Options0), + nth1(Arg, ArgPos, Pos0), + strip_option_module_qualifier(Goal, Module, Arg, TB, + Options0, Pos0, Options, Pos), + ( Pos = list_position(_, _, ElmPos, TailPos) + -> colourise_option_list(Options, OptionDecl, TB, ElmPos, TailPos) + ; ( var(Options) + ; Options == [] + ) + -> colourise_term_arg(Options, TB, Pos) + ; colour_item(type_error(list), TB, Pos) + ), + fail + ; true + ). + +strip_option_module_qualifier(Goal, Module, Arg, TB, + M:Options, term_position(_,_,_,_,[MP,Pos]), + Options, Pos) :- + predicate_property(Module:Goal, meta_predicate(Head)), + arg(Arg, Head, :), !, + colour_item(module(M), TB, MP). +strip_option_module_qualifier(_, _, _, _, + Options, Pos, Options, Pos). + + +colourise_option_list(_, _, _, [], none). +colourise_option_list(Tail, _, TB, [], TailPos) :- + colourise_term_arg(Tail, TB, TailPos). +colourise_option_list([H|T], OptionDecl, TB, [HPos|TPos], TailPos) :- + colourise_option(H, OptionDecl, TB, HPos), + colourise_option_list(T, OptionDecl, TB, TPos, TailPos). + +colourise_option(Opt, _, TB, Pos) :- + var(Opt), !, + colourise_term_arg(Opt, TB, Pos). +colourise_option(Opt, OptionDecl, TB, term_position(_,_,FF,FT,ValPosList)) :- !, + functor(Opt, Name, Arity), + functor(GenOpt, Name, Arity), + ( memberchk(GenOpt, OptionDecl) + -> colour_item(option_name, TB, FF-FT), + Opt =.. [Name|Values], + GenOpt =.. [Name|Types], + colour_option_values(Values, Types, TB, ValPosList) + ; colour_item(no_option_name, TB, FF-FT) + ). +colourise_option(_, _, TB, Pos) :- + colour_item(type_error(option), TB, Pos). + +colour_option_values([], [], _, _). +colour_option_values([V0|TV], [T0|TT], TB, [P0|TP]) :- + ( ( var(V0) + ; is_of_type(T0, V0) + ) + -> colourise_term_arg(V0, TB, P0) + ; callable(V0), + ( T0 = callable + -> N = 0 + ; T0 = (callable+N) + ) + -> colourise_meta_arg(N, V0, TB, P0) + ; colour_item(type_error(T0), TB, P0) + ), + colour_option_values(TV, TT, TB, TP). + + +%% colourise_files(+Arg, +TB, +Pos) +% +% Colourise the argument list of one of the file-loading predicates. + +colourise_files(List, TB, list_position(_,_,Elms,_)) :- !, + colourise_file_list(List, TB, Elms). +colourise_files(M:Spec, TB, term_position(_,_,_,_,[MP,SP])) :- !, + colour_item(module(M), TB, MP), + colourise_files(Spec, TB, SP). +colourise_files(Var, TB, P) :- + var(Var), !, + colour_item(var, TB, P). +colourise_files(Spec0, TB, Pos) :- + strip_module(Spec0, _, Spec), + ( colour_state_source_id(TB, Source), + prolog_canonical_source(Source, SourceId), + catch(xref_source_file(Spec, Path, SourceId), _, fail) + -> colour_item(file(Path), TB, Pos) + ; colour_item(nofile, TB, Pos) + ). + +colourise_file_list([], _, _). +colourise_file_list([H|T], TB, [PH|PT]) :- + colourise_files(H, TB, PH), + colourise_file_list(T, TB, PT). + + +%% colourise_directory(+Arg, +TB, +Pos) +% +% Colourise argument that should be an existing directory. + +colourise_directory(Spec, TB, Pos) :- + ( colour_state_source_id(TB, SourceId), + catch(xref_source_file(Spec, Path, SourceId, + [file_type(directory)]), + _, fail) + -> colour_item(directory(Path), TB, Pos) + ; colour_item(nofile, TB, Pos) + ). + + +%% colourise_class(ClassName, TB, Pos) +% +% Colourise an XPCE class. + +colourise_class(ClassName, TB, Pos) :- + colour_state_source_id(TB, SourceId), + classify_class(SourceId, ClassName, Classification), + colour_item(class(Classification, ClassName), TB, Pos). + +%% classify_class(+SourceId, +ClassName, -Classification). + +classify_class(SourceId, Name, Class) :- + xref_defined_class(SourceId, Name, Class), !. +:- if(current_predicate(classify_class/2)). +classify_class(_, Name, Class) :- + classify_class(Name, Class). +:- endif. + +%% colourise_term_args(+Term, +TB, +Pos) +% +% colourise head/body principal terms. + +colourise_term_args(Term, TB, + term_position(_,_,_,_,ArgPos)) :- !, + colourise_term_args(ArgPos, 1, Term, TB). +colourise_term_args(_, _, _). + +colourise_term_args([], _, _, _). +colourise_term_args([Pos|T], N, Term, TB) :- + arg(N, Term, Arg), + colourise_term_arg(Arg, TB, Pos), + NN is N + 1, + colourise_term_args(T, NN, Term, TB). + +colourise_term_arg(Var, TB, Pos) :- % variable + var(Var), !, + ( singleton(Var, TB) + -> colour_item(singleton, TB, Pos) + ; colour_item(var, TB, Pos) + ). +colourise_term_arg(List, TB, list_position(_, _, Elms, Tail)) :- !, + colourise_list_args(Elms, Tail, List, TB, classify). % list +colourise_term_arg(Compound, TB, Pos) :- % compound + compound(Compound), !, + colourise_term_args(Compound, TB, Pos). +colourise_term_arg(_, TB, string_position(F, T)) :- !, % string + colour_item(string, TB, F-T). +colourise_term_arg(Atom, TB, Pos) :- % single quoted atom + atom(Atom), !, + colour_item(atom, TB, Pos). +colourise_term_arg(_Arg, _TB, _Pos) :- + true. + +colourise_list_args([HP|TP], Tail, [H|T], TB, How) :- + specified_item(How, H, TB, HP), + colourise_list_args(TP, Tail, T, TB, How). +colourise_list_args([], none, _, _, _) :- !. +colourise_list_args([], TP, T, TB, How) :- + specified_item(How, T, TB, TP). + + +% colourise_exports(+List, +TB, +Pos) +% +% Colourise the module export-list (or any other list holding +% terms of the form Name/Arity referring to predicates). + +colourise_exports([], _, _) :- !. +colourise_exports(List, TB, list_position(_,_,ElmPos,Tail)) :- !, + ( Tail == none + -> true + ; colour_item(type_error(list), TB, Tail) + ), + colourise_exports2(List, TB, ElmPos). +colourise_exports(_, TB, Pos) :- + colour_item(type_error(list), TB, Pos). + +colourise_exports2([G0|GT], TB, [P0|PT]) :- !, + colourise_declaration(G0, TB, P0), + colourise_exports2(GT, TB, PT). +colourise_exports2(_, _, _). + + +% colourise_imports(+List, +File, +TB, +Pos) +% +% Colourise import list from use_module/2, importing from File. + +colourise_imports(List, File, TB, Pos) :- + ( colour_state_source_id(TB, SourceId), + catch(xref_public_list(File, Path, Public, SourceId), _, fail) + -> true + ; Public = [] + ), + colourise_imports(List, Path, Public, TB, Pos). + +colourise_imports([], _, _, _, _). +colourise_imports(List, File, Public, TB, list_position(_,_,ElmPos,Tail)) :- !, + ( Tail == none + -> true + ; colour_item(type_error(list), TB, Tail) + ), + colourise_imports2(List, File, Public, TB, ElmPos). +colourise_imports(except(Except), File, Public, TB, + term_position(_,_,FF,FT,[LP])) :- !, + colour_item(keyword(except), TB, FF-FT), + colourise_imports(Except, File, Public, TB, LP). +colourise_imports(_, _, _, TB, Pos) :- + colour_item(type_error(list), TB, Pos). + +colourise_imports2([G0|GT], File, Public, TB, [P0|PT]) :- !, + colourise_import(G0, File, TB, P0), + colourise_imports2(GT, File, Public, TB, PT). +colourise_imports2(_, _, _, _, _). + + +colourise_import(PI as Name, File, TB, term_position(_,_,FF,FT,[PP,NP])) :- + pi_to_term(PI, Goal), !, + colour_item(goal(imported(File), Goal), TB, PP), + functor(Goal, _, Arity), + functor(NewGoal, Name, Arity), + goal_classification(TB, NewGoal, [], Class), + colour_item(goal(Class, NewGoal), TB, NP), + colour_item(keyword(as), TB, FF-FT). +colourise_import(PI, _, TB, Pos) :- + colourise_declaration(PI, TB, Pos). + + +%% colourise_declarations(+Term, +TB, +Pos) +% +% Colourise the Predicate indicator lists of dynamic, multifile, etc +% declarations. + +colourise_declarations((Head,Tail), TB, + term_position(_,_,_,_,[PH,PT])) :- !, + colourise_declaration(Head, TB, PH), + colourise_declarations(Tail, TB, PT). +colourise_declarations(Last, TB, Pos) :- + colourise_declaration(Last, TB, Pos). + +colourise_declaration(PI, TB, Pos) :- + pi_to_term(PI, Goal), !, + goal_classification(TB, Goal, [], Class), + colour_item(goal(Class, Goal), TB, Pos). +colourise_declaration(Module:PI, TB, + term_position(_,_,_,_,[PM,PG])) :- + atom(Module), pi_to_term(PI, Goal), !, + colour_item(module(M), TB, PM), + colour_item(goal(extern(M), Goal), TB, PG). +colourise_declaration(op(_,_,_), TB, Pos) :- + colour_item(exported_operator, TB, Pos). +colourise_declaration(_, TB, Pos) :- + colour_item(type_error(export_declaration), TB, Pos). + +pi_to_term(Name/Arity, Term) :- + atom(Name), integer(Arity), !, + functor(Term, Name, Arity). +pi_to_term(Name//Arity0, Term) :- + atom(Name), integer(Arity0), !, + Arity is Arity0 + 2, + functor(Term, Name, Arity). + +%% colourise_prolog_flag_name(+Name, +TB, +Pos) +% +% Colourise the name of a Prolog flag + +colourise_prolog_flag_name(Name, TB, Pos) :- + atom(Name), !, + ( current_prolog_flag(Name, _) + -> colour_item(flag_name(Name), TB, Pos) + ; colour_item(no_flag_name(Name), TB, Pos) + ). +colourise_prolog_flag_name(Name, TB, Pos) :- + colourise_term(Name, TB, Pos). + + + /******************************* + * CONFIGURATION * + *******************************/ + +% body_compiled(+Term) +% +% Succeeds if term is a construct handled by the compiler. + +body_compiled((_,_)). +body_compiled((_->_)). +body_compiled((_*->_)). +body_compiled((_;_)). +body_compiled(\+_). + +% goal_classification(+TB, +Goal, +Origin, -Class) +% +% Classify Goal appearing in TB and called from a clause with head +% Origin. For directives Origin is []. + +goal_classification(_, Goal, _, meta) :- + var(Goal), !. +goal_classification(_, Goal, Origin, recursion) :- + callable(Goal), + functor(Goal, Name, Arity), + functor(Origin, Name, Arity), !. +goal_classification(TB, Goal, _, How) :- + colour_state_source_id(TB, SourceId), + xref_defined(SourceId, Goal, How), + How \= public(_), !. +goal_classification(_TB, Goal, _, Class) :- + goal_classification(Goal, Class), !. +goal_classification(_TB, _Goal, _, undefined). + +% goal_classification(+Goal, -Class) +% +% Multifile hookable classification for non-local goals. + +goal_classification(Goal, built_in) :- + built_in_predicate(Goal), !. +goal_classification(Goal, autoload) :- % SWI-Prolog + functor(Goal, Name, Arity), + '$in_library'(Name, Arity, _Path), !. +goal_classification(Goal, global) :- % SWI-Prolog + current_predicate(_, user:Goal), !. +goal_classification(SS, expanded) :- % XPCE (TBD) + functor(SS, send_super, A), + A >= 2, !. +goal_classification(SS, expanded) :- % XPCE (TBD) + functor(SS, get_super, A), + A >= 3, !. + +classify_head(TB, Goal, exported) :- + colour_state_source_id(TB, SourceId), + xref_exported(SourceId, Goal), !. +classify_head(_TB, Goal, hook) :- + xref_hook(Goal), !. +classify_head(TB, Goal, hook) :- + colour_state_source_id(TB, SourceId), + xref_module(SourceId, M), + xref_hook(M:Goal), !. +classify_head(TB, Goal, unreferenced) :- + colour_state_source_id(TB, SourceId), + \+ (xref_called(SourceId, Goal, By), By \= Goal), !. +classify_head(TB, Goal, How) :- + colour_state_source_id(TB, SourceId), + xref_defined(SourceId, Goal, How), !. +classify_head(_TB, Goal, built_in) :- + built_in_predicate(Goal), !. +classify_head(_TB, _Goal, undefined). + +built_in_predicate(Goal) :- + predicate_property(system:Goal, built_in), !. +built_in_predicate(module(_, _)). +built_in_predicate(if(_)). +built_in_predicate(elif(_)). +built_in_predicate(else). +built_in_predicate(endif). + +% Specify colours for individual goals. + +goal_colours(module(_,_), built_in-[identifier,exports]). +goal_colours(use_module(_), built_in-[file]). +goal_colours(use_module(File,_), built_in-[file,imports(File)]). +goal_colours(reexport(_), built_in-[file]). +goal_colours(reexport(File,_), built_in-[file,imports(File)]). +goal_colours(dynamic(_), built_in-[predicates]). +goal_colours(thread_local(_), built_in-[predicates]). +goal_colours(module_transparent(_), built_in-[predicates]). +goal_colours(multifile(_), built_in-[predicates]). +goal_colours(volatile(_), built_in-[predicates]). +goal_colours(public(_), built_in-[predicates]). +goal_colours(consult(_), built_in-[file]). +goal_colours(include(_), built_in-[file]). +goal_colours(ensure_loaded(_), built_in-[file]). +goal_colours(load_files(_,_), built_in-[file,classify]). +goal_colours(setof(_,_,_), built_in-[classify,setof,classify]). +goal_colours(bagof(_,_,_), built_in-[classify,setof,classify]). +goal_colours(predicate_options(_,_,_), built_in-[predicate,classify,classify]). +% Database access +goal_colours(assert(_), built_in-[db]). +goal_colours(asserta(_), built_in-[db]). +goal_colours(assertz(_), built_in-[db]). +goal_colours(assert(_,_), built_in-[db,classify]). +goal_colours(asserta(_,_), built_in-[db,classify]). +goal_colours(assertz(_,_), built_in-[db,classify]). +goal_colours(retract(_), built_in-[db]). +goal_colours(retractall(_), built_in-[db]). +goal_colours(clause(_,_), built_in-[db,classify]). +goal_colours(clause(_,_,_), built_in-[db,classify,classify]). +% misc +goal_colours(set_prolog_flag(_,_), built_in-[prolog_flag_name,classify]). +goal_colours(current_prolog_flag(_,_), built_in-[prolog_flag_name,classify]). +% XPCE stuff +goal_colours(pce_autoload(_,_), classify-[classify,file]). +goal_colours(pce_image_directory(_), classify-[directory]). +goal_colours(new(_, _), built_in-[classify,pce_new]). +goal_colours(send_list(_,_,_), built_in-pce_arg_list). +goal_colours(send(_,_), built_in-[pce_arg,pce_selector]). +goal_colours(get(_,_,_), built_in-[pce_arg,pce_selector,pce_arg]). +goal_colours(send_super(_,_), built_in-[pce_arg,pce_selector]). +goal_colours(get_super(_,_), built_in-[pce_arg,pce_selector,pce_arg]). +goal_colours(get_chain(_,_,_), built_in-[pce_arg,pce_selector,pce_arg]). +goal_colours(Pce, built_in-pce_arg) :- + compound(Pce), + functor(Pce, Functor, _), + pce_functor(Functor). + +pce_functor(send). +pce_functor(get). +pce_functor(send_super). +pce_functor(get_super). + + + /******************************* + * SPECIFIC HEADS * + *******************************/ + +head_colours(file_search_path(_,_), hook-[identifier,classify]). +head_colours(library_directory(_), hook-[file]). +head_colours(resource(_,_,_), hook-[identifier,classify,file]). + +head_colours(Var, _) :- + var(Var), !, + fail. +head_colours(M:H, Colours) :- + atom(M), callable(H), + xref_hook(M:H), !, + Colours = hook - [ hook, hook-classify ]. +head_colours(M:H, Colours) :- + M == user, + head_colours(H, HC), + HC = hook - _, !, + Colours = hook - [ hook, HC ]. +head_colours(M:_, meta-[module(M),extern(M)]). + + + /******************************* + * STYLES * + *******************************/ + +%% def_style(+Pattern, -Style) +% +% Define the style used for the given pattern. Definitions here +% can be overruled by defining rules for +% emacs_prolog_colours:style/2 + +def_style(goal(built_in,_), [colour(blue)]). +def_style(goal(imported(_),_), [colour(blue)]). +def_style(goal(autoload,_), [colour(navy_blue)]). +def_style(goal(global,_), [colour(navy_blue)]). +def_style(goal(undefined,_), [colour(red)]). +def_style(goal(thread_local(_),_), [colour(magenta), underline(true)]). +def_style(goal(dynamic(_),_), [colour(magenta)]). +def_style(goal(multifile(_),_), [colour(navy_blue)]). +def_style(goal(expanded,_), [colour(blue), underline(true)]). +def_style(goal(extern(_),_), [colour(blue), underline(true)]). +def_style(goal(recursion,_), [underline(true)]). +def_style(goal(meta,_), [colour(red4)]). +def_style(goal(foreign(_),_), [colour(darkturquoise)]). +def_style(goal(local(_),_), []). +def_style(goal(constraint(_),_), [colour(darkcyan)]). + +def_style(option_name, [colour('#3434ba')]). +def_style(no_option_name, [colour(red)]). + +def_style(head(exported), [colour(blue), bold(true)]). +def_style(head(public(_)), [colour('#016300'), bold(true)]). +def_style(head(extern(_)), [colour(blue), bold(true)]). +def_style(head(dynamic), [colour(magenta), bold(true)]). +def_style(head(multifile), [colour(navy_blue), bold(true)]). +def_style(head(unreferenced), [colour(red), bold(true)]). +def_style(head(hook), [colour(blue), underline(true)]). +def_style(head(meta), []). +def_style(head(constraint(_)), [colour(darkcyan), bold(true)]). +def_style(head(_), [bold(true)]). +def_style(module(_), [colour(dark_slate_blue)]). +def_style(comment, [colour(dark_green)]). + +def_style(directive, [background(grey90)]). +def_style(method(_), [bold(true)]). + +def_style(var, [colour(red4)]). +def_style(singleton, [bold(true), colour(red4)]). +def_style(unbound, [colour(red), bold(true)]). +def_style(quoted_atom, [colour(navy_blue)]). +def_style(string, [colour(navy_blue)]). +def_style(nofile, [colour(red)]). +def_style(file(_), [colour(blue), underline(true)]). +def_style(directory(_), [colour(blue)]). +def_style(class(built_in,_), [colour(blue), underline(true)]). +def_style(class(library(_),_), [colour(navy_blue), underline(true)]). +def_style(class(local(_,_,_),_), [underline(true)]). +def_style(class(user(_),_), [underline(true)]). +def_style(class(user,_), [underline(true)]). +def_style(class(undefined,_), [colour(red), underline(true)]). +def_style(prolog_data, [colour(blue), underline(true)]). +def_style(flag_name(_), [colour(blue)]). +def_style(no_flag_name(_), [colour(red)]). + +def_style(keyword(_), [colour(blue)]). +def_style(identifier, [bold(true)]). +def_style(delimiter, [bold(true)]). +def_style(expanded, [colour(blue), underline(true)]). + +def_style(hook, [colour(blue), underline(true)]). + +def_style(error, [background(orange)]). +def_style(type_error(_), [background(orange)]). +def_style(syntax_error(_,_), [background(orange)]). + +%% syntax_colour(?Class, ?Attributes) is nondet. +% +% True when a range classified Class must be coloured using +% Attributes. Attributes is a list of: +% +% * colour(ColourName) +% * background(ColourName) +% * bold(Boolean) +% * underline(Boolean) +% +% Attributes may be the empty list. This is used for cases where +% -for example- a menu is associated with the fragment. If +% syntax_colour/2 fails, no fragment is created for the region. + +syntax_colour(Class, Attributes) :- + ( style(Class, Attributes) % user hook + ; def_style(Class, Attributes) % system default + ). + + +%% term_colours(+Term, -FunctorColour, -ArgColours) +% +% Define colourisation for specific terms. + +term_colours((?- Directive), Colours) :- + term_colours((:- Directive), Colours). +term_colours((prolog:Head --> _), + expanded - [ expanded - [ expanded, + expanded - [ identifier + ] + ], + classify + ]) :- + prolog_message_hook(Head). + +prolog_message_hook(message(_)). +prolog_message_hook(error_message(_)). +prolog_message_hook(message_context(_)). +prolog_message_hook(message_location(_)). + +% XPCE rules + +term_colours(variable(_, _, _, _), + expanded - [ identifier, + classify, + classify, + comment + ]). +term_colours(variable(_, _, _), + expanded - [ identifier, + classify, + atom + ]). +term_colours(handle(_, _, _), + expanded - [ classify, + classify, + classify + ]). +term_colours(handle(_, _, _, _), + expanded - [ classify, + classify, + classify, + classify + ]). +term_colours(class_variable(_,_,_,_), + expanded - [ identifier, + pce(type), + pce(default), + comment + ]). +term_colours(class_variable(_,_,_), + expanded - [ identifier, + pce(type), + pce(default) + ]). +term_colours(delegate_to(_), + expanded - [ classify + ]). +term_colours((:- encoding(_)), + expanded - [ expanded - [ classify + ] + ]). +term_colours((:- pce_begin_class(_, _, _)), + expanded - [ expanded - [ identifier, + pce_new, + comment + ] + ]). +term_colours((:- pce_begin_class(_, _)), + expanded - [ expanded - [ identifier, + pce_new + ] + ]). +term_colours((:- pce_extend_class(_)), + expanded - [ expanded - [ identifier + ] + ]). +term_colours((:- pce_end_class), + expanded - [ expanded + ]). +term_colours((:- pce_end_class(_)), + expanded - [ expanded - [ identifier + ] + ]). +term_colours((:- use_class_template(_)), + expanded - [ expanded - [ pce_new + ] + ]). +term_colours((:- emacs_begin_mode(_,_,_,_,_)), + expanded - [ expanded - [ identifier, + classify, + classify, + classify, + classify + ] + ]). +term_colours((:- emacs_extend_mode(_,_)), + expanded - [ expanded - [ identifier, + classify + ] + ]). +term_colours((:- pce_group(_)), + expanded - [ expanded - [ identifier + ] + ]). +term_colours((:- pce_global(_, new(_))), + expanded - [ expanded - [ identifier, + pce_arg + ] + ]). +term_colours((:- emacs_end_mode), + expanded - [ expanded + ]). +term_colours(pce_ifhostproperty(_,_), + expanded - [ classify, + classify + ]). +term_colours((_,_), + error - [ classify, + classify + ]). + +specified_item(_, Var, TB, Pos) :- + var(Var), !, + colourise_term_arg(Var, TB, Pos). + % generic classification +specified_item(classify, Term, TB, Pos) :- !, + colourise_term_arg(Term, TB, Pos). + % classify as head +specified_item(head, Term, TB, Pos) :- !, + colourise_clause_head(Term, TB, Pos). + % expanded head (DCG=2, ...) +specified_item(head(+N), Term, TB, Pos) :- !, + colourise_extended_head(Term, N, TB, Pos). + % M:Head +specified_item(extern(M), Term, TB, Pos) :- !, + colourise_extern_head(Term, M, TB, Pos). + % classify as body +specified_item(body, Term, TB, Pos) :- !, + colourise_body(Term, TB, Pos). +specified_item(setof, Term, TB, Pos) :- !, + colourise_setof(Term, TB, Pos). +specified_item(meta(MetaSpec), Term, TB, Pos) :- !, + colourise_meta_arg(MetaSpec, Term, TB, Pos). + % DCG goal in body +specified_item(dcg, Term, TB, Pos) :- !, + colourise_dcg(Term, [], TB, Pos). + % assert/retract arguments +specified_item(db, Term, TB, Pos) :- !, + colourise_db(Term, TB, Pos). + % files +specified_item(file, Term, TB, Pos) :- !, + colourise_files(Term, TB, Pos). + % directory +specified_item(directory, Term, TB, Pos) :- !, + colourise_directory(Term, TB, Pos). + % [Name/Arity, ...] +specified_item(exports, Term, TB, Pos) :- !, + colourise_exports(Term, TB, Pos). + % [Name/Arity, ...] +specified_item(imports(File), Term, TB, Pos) :- !, + colourise_imports(Term, File, TB, Pos). + % Name/Arity, ... +specified_item(predicates, Term, TB, Pos) :- !, + colourise_declarations(Term, TB, Pos). + % Name/Arity +specified_item(predicate, Term, TB, Pos) :- !, + colourise_declaration(Term, TB, Pos). + % set_prolog_flag(Name, _) +specified_item(prolog_flag_name, Term, TB, Pos) :- !, + colourise_prolog_flag_name(Term, TB, Pos). + % XPCE new argument +specified_item(pce_new, Term, TB, Pos) :- !, + ( atom(Term) + -> colourise_class(Term, TB, Pos) + ; compound(Term) + -> functor(Term, Class, _), + Pos = term_position(_,_,FF, FT, ArgPos), + colourise_class(Class, TB, FF-FT), + specified_items(pce_arg, Term, TB, ArgPos) + ; colourise_term_arg(Term, TB, Pos) + ). + % Generic XPCE arguments +specified_item(pce_arg, new(X), TB, + term_position(_,_,_,_,[ArgPos])) :- !, + specified_item(pce_new, X, TB, ArgPos). +specified_item(pce_arg, new(X, T), TB, + term_position(_,_,_,_,[P1, P2])) :- !, + colourise_term_arg(X, TB, P1), + specified_item(pce_new, T, TB, P2). +specified_item(pce_arg, @(Ref), TB, Pos) :- !, + colourise_term_arg(@(Ref), TB, Pos). +specified_item(pce_arg, prolog(Term), TB, + term_position(_,_,FF,FT,[ArgPos])) :- !, + colour_item(prolog_data, TB, FF-FT), + colourise_term_arg(Term, TB, ArgPos). +specified_item(pce_arg, Term, TB, Pos) :- + compound(Term), + Term \= [_|_], !, + specified_item(pce_new, Term, TB, Pos). +specified_item(pce_arg, Term, TB, Pos) :- !, + colourise_term_arg(Term, TB, Pos). + % List of XPCE arguments +specified_item(pce_arg_list, List, TB, list_position(_,_,Elms,Tail)) :- !, + colourise_list_args(Elms, Tail, List, TB, pce_arg). +specified_item(pce_arg_list, Term, TB, Pos) :- !, + specified_item(pce_arg, Term, TB, Pos). + % XPCE selector +specified_item(pce_selector, Term, TB, + term_position(_,_,_,_,ArgPos)) :- !, + specified_items(pce_arg, Term, TB, ArgPos). +specified_item(pce_selector, Term, TB, Pos) :- + colourise_term_arg(Term, TB, Pos). + % Nested specification +specified_item(FuncSpec-ArgSpecs, Term, TB, + term_position(_,_,FF,FT,ArgPos)) :- !, + specified_item(FuncSpec, Term, TB, FF-FT), + specified_items(ArgSpecs, Term, TB, ArgPos). + % Nested for {...} +specified_item(FuncSpec-[ArgSpec], {Term}, TB, + brace_term_position(F,T,ArgPos)) :- !, + specified_item(FuncSpec, {Term}, TB, F-T), + specified_item(ArgSpec, Term, TB, ArgPos). + % Specified +specified_item(FuncSpec-ElmSpec, List, TB, list_position(F,T,ElmPos,TailPos)) :- !, + FT is F + 1, + AT is T - 1, + colour_item(FuncSpec, TB, F-FT), + colour_item(FuncSpec, TB, AT-T), + specified_list(ElmSpec, List, TB, ElmPos, TailPos). +specified_item(Class, _, TB, Pos) :- + colour_item(Class, TB, Pos). + +% specified_items(+Spec, +T, +TB, +PosList) + +specified_items(Specs, Term, TB, PosList) :- + is_list(Specs), !, + specified_arglist(Specs, 1, Term, TB, PosList). +specified_items(Spec, Term, TB, PosList) :- + specified_argspec(PosList, Spec, 1, Term, TB). + + +specified_arglist([], _, _, _, _). +specified_arglist(_, _, _, _, []) :- !. % Excess specification args +specified_arglist([S0|ST], N, T, TB, [P0|PT]) :- + arg(N, T, Term), + specified_item(S0, Term, TB, P0), + NN is N + 1, + specified_arglist(ST, NN, T, TB, PT). + +specified_argspec([], _, _, _, _). +specified_argspec([P0|PT], Spec, N, T, TB) :- + arg(N, T, Term), + specified_item(Spec, Term, TB, P0), + NN is N + 1, + specified_argspec(PT, Spec, NN, T, TB). + + +% specified_list(+Spec, +List, +TB, +PosList, TailPos) + +specified_list([], [], _, [], _). +specified_list([HS|TS], [H|T], TB, [HP|TP], TailPos) :- !, + specified_item(HS, H, TB, HP), + specified_list(TS, T, TB, TP, TailPos). +specified_list(Spec, [H|T], TB, [HP|TP], TailPos) :- + specified_item(Spec, H, TB, HP), + specified_list(Spec, T, TB, TP, TailPos). +specified_list(_, _, _, [], none) :- !. +specified_list(Spec, Tail, TB, [], TailPos) :- + specified_item(Spec, Tail, TB, TailPos). + + + /******************************* + * DESCRIPTIONS * + *******************************/ + +syntax_message(Class) --> + message(Class), !. +syntax_message(goal(Class, Goal)) --> !, + goal_message(Class, Goal). +syntax_message(class(Type, Class)) --> !, + xpce_class_message(Type, Class). + +goal_message(meta, _) --> + [ 'Meta call' ]. +goal_message(recursion, _) --> + [ 'Recursive call' ]. +goal_message(undefined, _) --> + [ 'Call to undefined predicate' ]. +goal_message(expanded, _) --> + [ 'Expanded goal' ]. +goal_message(global, _) --> + [ 'Auto-imported from module user' ]. +goal_message(Class, Goal) --> + { predicate_name(Goal, PI) }, + [ 'Call to ~w predicate ~q'-[Class,PI] ]. + +xpce_class_message(Type, Class) --> + [ 'XPCE ~w class ~q'-[Type, Class] ]. diff --git a/LGPL/settings.pl b/LGPL/settings.pl index d3386bf39..f27a4cfd3 100644 --- a/LGPL/settings.pl +++ b/LGPL/settings.pl @@ -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) % diff --git a/Makefile.in b/Makefile.in index 34c40ca89..56df06079 100644 --- a/Makefile.in +++ b/Makefile.in @@ -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) ########## diff --git a/OPTYap/opt.preds.c b/OPTYap/opt.preds.c index 4cafc5fd1..909dfd201 100644 --- a/OPTYap/opt.preds.c +++ b/OPTYap/opt.preds.c @@ -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); diff --git a/OPTYap/tab.tries.c b/OPTYap/tab.tries.c index 3a031601e..0ce1533e9 100644 --- a/OPTYap/tab.tries.c +++ b/OPTYap/tab.tries.c @@ -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; diff --git a/configure b/configure index aa5d072ad..7efd8c4de 100755 --- a/configure +++ b/configure @@ -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" ;; diff --git a/configure.in b/configure.in index dbe35360c..d92cb3bae 100755 --- a/configure.in +++ b/configure.in @@ -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 diff --git a/docs/yap.tex b/docs/yap.tex index 6b59b8a05..2d3730475 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -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) @* diff --git a/library/Makefile.in b/library/Makefile.in index 1e135fd88..c510d7506 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -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 \ diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index 4709f48ad..5441d65a9 100644 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -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; } diff --git a/library/dialect/swi/syspred_options.pl b/library/dialect/swi/syspred_options.pl new file mode 100644 index 000000000..f3387a4e5 --- /dev/null +++ b/library/dialect/swi/syspred_options.pl @@ -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)). + +/** 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) + ]). + diff --git a/library/random.yap b/library/random.yap index 15597a95b..403410073 100644 --- a/library/random.yap +++ b/library/random.yap @@ -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), !, - random(X), - R is L+((U-L)*X). + ( integer(L), integer(U) -> + U > L, + random(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. diff --git a/misc/ATOMS b/misc/ATOMS index f5b660565..aa8c4edf6 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -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 "" A VStream N "stream" A Streams N "streams" A StreamOrAlias N "stream_or_alias" diff --git a/misc/Yap.spec b/misc/Yap.spec index 1a1991398..8c7a9bccb 100644 --- a/misc/Yap.spec +++ b/misc/Yap.spec @@ -3,7 +3,7 @@ Name: yap Summary: Prolog Compiler -Version: 6.3.1 +Version: 6.3.2 Packager: Vitor Santos Costa Release: 1 Source: http://www.dcc.fc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz diff --git a/misc/Yap64.spec b/misc/Yap64.spec index 88c4328ac..700b23ac7 100644 --- a/misc/Yap64.spec +++ b/misc/Yap64.spec @@ -3,7 +3,7 @@ Name: yap Summary: Prolog Compiler -Version: 6.3.1 +Version: 6.3.2 Packager: Vitor Santos Costa Release: 1 Source: http://www.dcc.fc.up.pt/~vsc/Yap/%{name}-%{version}.tar.gz diff --git a/misc/yap.nsi b/misc/yap.nsi index 6d1ba6428..c3a3432f3 100644 --- a/misc/yap.nsi +++ b/misc/yap.nsi @@ -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" diff --git a/misc/yap64.nsi b/misc/yap64.nsi index 5efb402e8..59378f4bd 100755 --- a/misc/yap64.nsi +++ b/misc/yap64.nsi @@ -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" diff --git a/os/pl-file.c b/os/pl-file.c index 300211c3d..898d2719c 100644 --- a/os/pl-file.c +++ b/os/pl-file.c @@ -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()); diff --git a/os/pl-write.c b/os/pl-write.c index 230663ffb..6b7c5813e 100644 --- a/os/pl-write.c +++ b/os/pl-write.c @@ -42,6 +42,14 @@ #define HAVE_FPCLASSIFY 1 #endif +#if __YAP_PROLOG__ + +#define _PL_WRITE_ 1 + +#include "yapio.h" + +#endif + typedef struct visited { Word address; /* we have done this address */ struct visited *next; /* next already visited */ @@ -52,666 +60,27 @@ typedef struct int max_depth; /* depth limit */ int depth; /* current depth */ atom_t spacing; /* Where to insert spaces */ - Module module; /* Module for operators */ + Term module; /* Module for operators */ IOSTREAM *out; /* stream to write to */ visited *visited; /* visited (attributed-) variables */ } write_options; -static bool writeTerm2(term_t term, int prec, - write_options *options, bool arg) WUNUSED; -static bool writeTerm(term_t t, int prec, - write_options *options) WUNUSED; -static bool writeArgTerm(term_t t, int prec, - write_options *options, bool arg) WUNUSED; +word +pl_nl1(term_t stream) +{ IOSTREAM *s; -#if __YAP_PROLOG__ -static Word -address_of(term_t t) -{ - return YAP_AddressFromSlot(t); /* non-recursive structure */ -} -#else -static Word -address_of(term_t t) -{ GET_LD - Word adr = valTermRef(t); - - deRef(adr); - switch(tag(*adr)) - { case TAG_ATTVAR: - return adr; - case TAG_COMPOUND: - return valPtr(*adr); - default: - return NULL; /* non-recursive structure */ - } -} -#endif - - -static int -has_visited(visited *v, Word addr) -{ for( ; v; v=v->next ) - { if ( v->address == addr ) - succeed; + if ( getOutputStream(stream, &s) ) + { Sputcode('\n', s); + return streamStatus(s); } fail; } - -char * -varName(term_t t, char *name) -#if __YAP_PROLOG__ -{ - YAP_Int adr = YAP_VarSlotToNumber(t); - - if (adr < 0) - Ssprintf(name, "_L%ld", -adr); - else - Ssprintf(name, "_G%ld", adr); - - return name; +word +pl_nl(void) +{ return pl_nl1(0); } -#else -{ GET_LD - Word adr = valTermRef(t); - - deRef(adr); - - if (adr > (Word) lBase) - Ssprintf(name, "_L%ld", (Word)adr - (Word)lBase); - else - Ssprintf(name, "_G%ld", (Word)adr - (Word)gBase); - - return name; -} -#endif - - -#define AT_LOWER 0 -#define AT_QUOTE 1 -#define AT_FULLSTOP 2 -#define AT_SYMBOL 3 -#define AT_SOLO 4 -#define AT_SPECIAL 5 - -/* Note: this only deals with ISO Latin-1 atoms; wide atoms are handled - by writeUCSAtom() -*/ - -static int -atomType(atom_t a, IOSTREAM *fd) -{ Atom atom = atomValue(a); - char *s = atomName(atom); - size_t len = atomLength(atom); - - if ( len == 0 ) - return AT_QUOTE; - - if ( isLower(*s) ) - { for(++s; --len > 0 && isAlpha(*s) && Scanrepresent(*s, fd)==0; s++) - ; - return len == 0 ? AT_LOWER : AT_QUOTE; - } - - if ( a == ATOM_dot ) - return AT_FULLSTOP; - - if ( isSymbol(*s) ) - { if ( len >= 2 && s[0] == '/' && s[1] == '*' ) - return AT_QUOTE; - - for(++s; --len > 0 && isSymbol(*s) && Scanrepresent(*s, fd)==0; s++) - ; - - return len == 0 ? AT_SYMBOL : AT_QUOTE; - } - - /* % should be quoted! */ - if ( len == 1 && *s != '%' ) - { if ( isSolo(*s) ) - return AT_SOLO; - } - - if ( a == ATOM_nil || a == ATOM_curl ) - return AT_SPECIAL; - - return AT_QUOTE; -} - - - /******************************* - * PRIMITIVE WRITES * - *******************************/ - -#define TRUE_WITH_SPACE 2 /* OK, and emitted leading space before token */ - -static bool -Putc(int c, IOSTREAM *s) -{ return Sputcode(c, s) == EOF ? FALSE : TRUE; -} - - -static bool -PutString(const char *str, IOSTREAM *s) -{ const unsigned char *q = (const unsigned char *)str; - - for( ; *q != EOS; q++ ) - { if ( Sputcode(*q, s) == EOF ) - return FALSE; - } - - return TRUE; -} - - -static bool -PutComma(write_options *options) -{ if ( options->spacing == ATOM_next_argument ) - return PutString(", ", options->out); - else - return PutString(",", options->out); -} - - -static bool -PutStringN(const char *str, size_t length, IOSTREAM *s) -{ size_t i; - const unsigned char *q = (const unsigned char *)str; - - for(i=0; ilastc = EOF; - return FALSE; - } else if ( s->lastc != EOF && - ((isAlphaW(s->lastc) && isAlphaW(c)) || - (isSymbolW(s->lastc) && isSymbolW(c)) || - (s->lastc != '(' && !isBlank(s->lastc) && c == '(') || - (c == '\'' && isDigit(s->lastc))) ) - { return TRUE; - } - - return FALSE; -} - - -static int -PutOpenToken(int c, IOSTREAM *s) -{ if ( needSpace(c, s) ) - { TRY(Putc(' ', s)); - return TRUE_WITH_SPACE; - } - - return TRUE; -} - - -static int -PutToken(const char *s, IOSTREAM *stream) -{ if ( s[0] ) - { int rc; - - TRY(rc=PutOpenToken(s[0]&0xff, stream)); - TRY(PutString(s, stream)); - - return rc; - } - - return TRUE; -} - -static int -PutTokenN(const char *s, size_t len, IOSTREAM *stream) -{ if ( len > 0 ) - { int rc; - - TRY(rc=PutOpenToken(s[0]&0xff, stream)); - TRY(PutStringN(s, len, stream)); - - return rc; - } - - return TRUE; -} - -#if __YAP_PROLOG__ -static bool -PutWideStringN(const wchar_t *str, size_t length, IOSTREAM *s) -{ size_t i; - const wchar_t *q = (const wchar_t *)str; - - for(i=0; i 0 ) - { int rc; - - TRY(rc=PutOpenToken(s[0]&0xff, stream)); - TRY(PutWideStringN(s, len, stream)); - - return rc; - } - - return TRUE; -} - -#endif - - -/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -PutOpenBrace()/PutCloseBrace() are used to put additional braces around -a term to avoid an operator precedence problem. If the last emitted -character is alphanumerical, there should be a space before the -openbrace to avoid interpretation as a term. E.g. not (a,b) instead of -not(a,b). Reported by Stefan.Mueller@dfki.de. -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ - -static int -PutOpenBrace(IOSTREAM *s) -{ int rc; - - TRY(rc=PutOpenToken('(', s)); - TRY(Putc('(', s)); - - return rc; -} - - -static bool -PutCloseBrace(IOSTREAM *s) -{ return Putc(')', s); -} - - -static bool -putQuoted(int c, int quote, int flags, IOSTREAM *stream) -{ if ( (flags & PL_WRT_CHARESCAPES) ) - { if ( !(c < 0xff && isControl(c)) && c != quote && c != '\\' ) - { TRY(Putc(c, stream)); - } else - { char esc[8]; - - esc[1] = EOS; - - if ( c == quote ) - { esc[0] = c; - } else - { switch(c) - { case 7: - esc[0] = 'a'; - break; - case '\b': - esc[0] = 'b'; - break; - case '\t': - esc[0] = 't'; - break; - case '\n': - esc[0] = 'n'; - break; - case 11: - esc[0] = 'v'; - break; - case '\r': - esc[0] = 'r'; - break; - case '\f': - esc[0] = 'f'; - break; - case '\\': - esc[0] = '\\'; - break; - default: - if ( c <= 0xff ) - Ssprintf(esc, "%03o\\", c); - else - assert(0); /* to be done */ - } - } - if ( !Putc('\\', stream) || - !PutString(esc, stream) ) - fail; - } - } else - { if ( !Putc(c, stream) ) - fail; - if ( c == quote || c == '\\' ) /* write '' or \\ */ - { if ( !Putc(c, stream) ) - fail; - } - } - - return TRUE; -} - - - -static bool -writeQuoted(IOSTREAM *stream, const char *text, size_t len, int quote, - write_options *options) -{ const unsigned char *s = (const unsigned char *)text; - - TRY(Putc(quote, stream)); - - while(len-- > 0) - { TRY(putQuoted(*s++, quote, options->flags, stream)); - } - - return Putc(quote, stream); -} - - -#if O_ATTVAR -static bool -writeAttVar(term_t av, write_options *options) -{ GET_LD - char buf[32]; - - TRY(PutToken(varName(av, buf), options->out)); - - if ( (options->flags & PL_WRT_ATTVAR_DOTS) ) - { return PutString("{...}", options->out); - } else if ( (options->flags & PL_WRT_ATTVAR_WRITE) ) - { fid_t fid; - term_t a; - visited v; - - if ( !(fid = PL_open_foreign_frame()) ) - return FALSE; - - v.address = address_of(av); - if ( has_visited(options->visited, v.address) ) - succeed; - v.next = options->visited; - options->visited = &v; - Sputcode('{', options->out); - a = PL_new_term_ref(); - PL_get_attr__LD(av, a PASS_LD); - if ( !writeTerm(a, 1200, options) ) - goto error; - Sputcode('}', options->out); - PL_discard_foreign_frame(fid); - - options->visited = v.next; - succeed; - - error: - options->visited = v.next; - fail; - } else if ( (options->flags & PL_WRT_ATTVAR_PORTRAY) && - GD->cleaning <= CLN_PROLOG ) - { fid_t fid; - predicate_t pred; - IOSTREAM *old; - - if ( !(fid = PL_open_foreign_frame()) ) - return FALSE; - - pred = _PL_predicate("portray_attvar", 1, "$attvar", - &GD->procedures.portray_attvar1); - - old = Scurout; - Scurout = options->out; - PL_call_predicate(NULL, PL_Q_NODEBUG, pred, av); - Scurout = old; - - PL_discard_foreign_frame(fid); - } - - succeed; -} -#endif - - -static bool -writeBlob(atom_t a, write_options *options) -{ Atom atom = atomValue(a); - unsigned char const *s, *e; - - TRY(PutString("<#", options->out)); - s = (unsigned char const *)atomName(atom); - for (e = s + atomLength(atom); s != e; s++) - { static char *digits = "0123456789abcdef"; - - TRY(Putc(digits[(*s >> 4) & 0xf], options->out)); - TRY(Putc(digits[(*s ) & 0xf], options->out)); - } - - return PutString(">", options->out); -} - - -static int /* FALSE, TRUE or TRUE_WITH_SPACE */ -writeAtom(atom_t a, write_options *options) -{ Atom atom = atomValue(a); - - if ( (options->flags & PL_WRT_BLOB_PORTRAY) && - false(atomBlobType(atom), PL_BLOB_TEXT) && - GD->cleaning <= CLN_PROLOG ) - { GET_LD - int rc; - fid_t fid; - predicate_t pred; - IOSTREAM *old; - term_t av; - - if ( !(fid = PL_open_foreign_frame()) ) - return FALSE; - av = PL_new_term_ref(); - PL_put_atom(av, a); - - pred = _PL_predicate("portray", 1, "user", - &GD->procedures.portray); - - old = Scurout; - Scurout = options->out; - rc = PL_call_predicate(NULL, PL_Q_NODEBUG, pred, av); - Scurout = old; - - PL_discard_foreign_frame(fid); - if ( rc == TRUE ) - return TRUE; - } - - if ( atomBlobType(atom)->write ) - return (*atomBlobType(atom)->write)(options->out, a, options->flags); - if ( false(atomBlobType(atom), PL_BLOB_TEXT) ) - return writeBlob(a, options); -#if __YAP_PROLOG__ - if (isWideAtom(atom)) { - return writeUCSAtom(options->out, a, options->flags); - } -#endif - - if ( true(options, PL_WRT_QUOTED) ) - { switch( atomType(a, options->out) ) - { case AT_LOWER: - case AT_SYMBOL: - case AT_SOLO: - case AT_SPECIAL: - return PutToken(nameOfAtom(atom), options->out); - case AT_QUOTE: - case AT_FULLSTOP: - default: - { int rc; - - TRY(rc=PutOpenToken('\'', options->out)); - TRY(writeQuoted(options->out, - nameOfAtom(atom), - atomLength(atom), - '\'', options)); - return rc; - } - } - } else { - return PutTokenN(nameOfAtom(atom), atomLength(atom), options->out); - } -} - - -int -writeAtomToStream(IOSTREAM *s, atom_t atom) -{ write_options options; - - memset(&options, 0, sizeof(options)); - options.out = s; - options.module = MODULE_user; - - return writeAtom(atom, &options); -} - - -int -writeUCSAtom(IOSTREAM *fd, atom_t atom, int flags) -{ Atom a = atomValue(atom); - pl_wchar_t *s = (pl_wchar_t*)atomName(a); - size_t len = atomLength(a)/sizeof(pl_wchar_t); - pl_wchar_t *e = &s[len]; - - if ( flags & PL_WRT_QUOTED ) - { pl_wchar_t quote = L'\''; - int rc; - - if ( isLowerW(*s) ) - { pl_wchar_t *q; - - for(q=s; qencoding) - { case ENC_ISO_LATIN_1: - return t->text.t[index]&0xff; - case ENC_WCHAR: - return t->text.w[index]; - default: - assert(0); - return 0; - } -} - - -static int -writeString(term_t t, write_options *options) -{ GET_LD - PL_chars_t txt; - - PL_get_text(t, &txt, CVT_STRING); - - if ( true(options, PL_WRT_QUOTED) ) - { int quote; - unsigned int i; - - if ( true(options, PL_WRT_BACKQUOTED_STRING) ) - quote = '`'; - else - quote = '"'; - - TRY(Putc(quote, options->out)); - - for(i=0; iflags, options->out)); - } - - return Putc(quote, options->out); - } else - { unsigned int i; - - for(i=0; iout)); - } - } - - succeed; -} - -#endif /*O_STRING*/ - /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Formatting a float. This used to use sprintf(), but there are two @@ -797,528 +166,61 @@ format_float(double f, char *buf) } -static bool -WriteNumber(Number n, write_options *options) -{ GET_LD +char * +varName(term_t t, char *name) +{ + CACHE_REGS + CELL *adr = (CELL *)Yap_GetFromSlot(t PASS_REGS); - switch(n->type) - { case V_INTEGER: - { char buf[32]; - - sprintf(buf, INT64_FORMAT, n->value.i); - return PutToken(buf, options->out); - } -#ifdef O_GMP - case V_MPZ: - { char tmp[1024]; - char *buf; - size_t sz = mpz_sizeinbase(n->value.mpz, 10) + 2; - bool rc; - - if ( sz <= sizeof(tmp) ) - buf = tmp; - else - buf = PL_malloc(sz); - - /* mpz_get_str() can perform large intermediate allocations :-( */ - EXCEPTION_GUARDED({ LD->gmp.persistent++; - mpz_get_str(buf, 10, n->value.mpz); - LD->gmp.persistent--; - }, - { LD->gmp.persistent--; - rc = PL_rethrow(); - }) - rc = PutToken(buf, options->out); - if ( buf != tmp ) - PL_free(buf); - - return rc; - } - case V_MPQ: /* should not get here */ -#endif - case V_FLOAT: - assert(0); + if (IsAttVar(adr)) { + Ssprintf(name, "_D%ld", (CELL)adr - (CELL)H0); + } else { + Ssprintf(name, "_%ld", (CELL)adr - (CELL)H0); } - fail; + return name; } - -static bool -writePrimitive(term_t t, write_options *options) -{ GET_LD - double f; - atom_t a; - char buf[32]; - IOSTREAM *out = options->out; - -#if O_ATTVAR - if ( PL_is_attvar(t) ) - return writeAttVar(t, options); -#endif - - if ( PL_is_variable(t) ) - return PutToken(varName(t, buf), out); - - if ( PL_get_atom(t, &a) ) - return writeAtom(a, options); - - if ( PL_is_integer(t) ) /* beware of automatic conversion */ - { number n; - - PL_get_number(t, &n); - - return WriteNumber(&n, options); - } - - if ( PL_get_float(t, &f) ) - { char *s = NULL; - -#ifdef HAVE_FPCLASSIFY - switch(fpclassify(f)) - { case FP_NAN: - s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); - break; - case FP_INFINITE: - s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); - break; - } -#else -#ifdef HAVE_FPCLASS - switch(fpclass(f)) - { case FP_SNAN: - case FP_QNAN: - s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); - break; - case FP_NINF: - case FP_PINF: - s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); - break; - case FP_NDENORM: /* pos/neg denormalized non-zero */ - case FP_PDENORM: - case FP_NNORM: /* pos/neg normalized non-zero */ - case FP_PNORM: - case FP_NZERO: /* pos/neg zero */ - case FP_PZERO: - break; - } -#else -#ifdef HAVE__FPCLASS - switch(_fpclass(f)) - { case _FPCLASS_SNAN: - case _FPCLASS_QNAN: - s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); - break; - case _FPCLASS_NINF: - case _FPCLASS_PINF: - s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); - break; - } -#else -#ifdef HAVE_ISINF - if ( isinf(f) ) - { s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); - } else -#endif -#ifdef HAVE_ISNAN - if ( isnan(f) ) - { s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); - } -#endif -#endif /*HAVE__FPCLASS*/ -#endif /*HAVE_FPCLASS*/ -#endif /*HAVE_FPCLASSIFY*/ - - if ( s ) - { return PutToken(s, out); - } else - { char buf[100]; - - format_float(f, buf); - - return PutToken(buf, out); - } - } - -#if O_STRING - if ( PL_is_string(t) ) - return writeString(t, options); -#endif /* O_STRING */ - -#if __YAP_PROLOG__ - { - Opaque_CallOnWrite f; - - if ( (f = Yap_blob_write_handler_from_slot(t)) ) { - return (f)(options->out, Yap_blob_tag_from_slot(t), Yap_blob_info_from_slot(t), options->flags); - } else { - number n; - n.type = V_INTEGER; - n.value.i = 0; - return WriteNumber(&n, options); - } - } -#endif - - assert(0); - fail; -} - - -word -pl_nl1(term_t stream) -{ IOSTREAM *s; - - if ( getOutputStream(stream, &s) ) - { Sputcode('\n', s); - return streamStatus(s); - } - - fail; -} - -word -pl_nl(void) -{ return pl_nl1(0); -} - -/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Call user:portray/1 if defined. -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ - -static int -callPortray(term_t arg, write_options *options) -{ predicate_t portray; - - if ( GD->cleaning > CLN_PROLOG ) - fail; /* avoid dangerous callbacks */ - - portray = _PL_predicate("portray", 1, "user", &GD->procedures.portray); - - if ( predicateHasClauses(portray) ) - { GET_LD - wakeup_state wstate; - IOSTREAM *old = Scurout; - int rval; - - if ( !saveWakeup(&wstate, TRUE PASS_LD) ) - return FALSE; - Scurout = options->out; - rval = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION, - portray, arg); - if ( !rval && PL_exception(0) ) - rval = -1; - Scurout = old; - restoreWakeup(&wstate PASS_LD); - - return rval; - } - - fail; -} - - -static bool -writeArgTerm(term_t t, int prec, write_options *options, bool arg) -{ int rval; - int levelSave = options->depth; - fid_t fid; - - if ( !(fid = PL_open_foreign_frame()) ) - return FALSE; - - if ( PL_handle_signals() < 0 ) - { rval = FALSE; - goto out; - } - - if ( ++options->depth > options->max_depth && options->max_depth ) - rval = PutString("...", options->out); - else if ( PL_is_compound(t) ) - { visited v; - - v.address = address_of(t); - if ( has_visited(options->visited, v.address) ) - { rval = PutString("**", options->out); - } else - { v.next = options->visited; - options->visited = &v; - rval = writeTerm2(t, prec, options, arg); - options->visited = v.next; - } - } else - { rval = writeTerm2(t, prec, options, arg); - } - -out: - options->depth = levelSave; - PL_close_foreign_frame(fid); - - return rval; -} - static bool writeTerm(term_t t, int prec, write_options *options) { - return writeArgTerm(t, prec, options, FALSE); + CACHE_REGS + UInt yap_flag = Use_SWI_Stream_f; + int flags = options->flags; + Term old_module; + + if (flags & PL_WRT_QUOTED) + yap_flag |= Quote_illegal_f; + if (options->flags & PL_WRT_NUMBERVARS) + yap_flag |= Handle_vars_f; + if (options->flags & PL_WRT_IGNOREOPS) + yap_flag |= Ignore_ops_f; + if (flags & PL_WRT_PORTRAY) + yap_flag |= Use_portray_f; + if (flags & PL_WRT_BACKQUOTED_STRING) + yap_flag |= BackQuote_String_f; + if (flags & PL_WRT_ATTVAR_IGNORE) + yap_flag |= 0L; + if (flags & PL_WRT_ATTVAR_DOTS) + yap_flag |= AttVar_Dots_f; + if (flags & PL_WRT_ATTVAR_PORTRAY) + yap_flag |= AttVar_Portray_f; + if (flags & PL_WRT_BLOB_PORTRAY) + yap_flag |= Blob_Portray_f; + old_module = CurrentModule; + CurrentModule = options->module; + Yap_plwrite(Yap_GetFromSlot(t PASS_REGS), options->out, options->max_depth, yap_flag, prec); + CurrentModule = old_module; + return TRUE; } -static bool -writeList2(term_t list, write_options *options, int cyclic) -{ GET_LD - term_t head = PL_new_term_ref(); - term_t l = PL_copy_term_ref(list); - - TRY(Putc('[', options->out)); - for(;;) - { PL_get_list(l, head, l); - TRY(writeArgTerm(head, 999, options, TRUE)); - - if ( PL_get_nil(l) ) - break; - if ( ++options->depth >= options->max_depth && options->max_depth ) - return PutString("|...]", options->out); - if ( !PL_is_functor(l, FUNCTOR_dot2) ) - { TRY(Putc('|', options->out)); - TRY(writeArgTerm(l, 999, options, TRUE)); - break; - } - - /* cycle detection */ - { Word addr = address_of(l); - - if ( has_visited(options->visited, addr) ) - { return PutString("|**]", options->out); - } else if ( cyclic ) - { visited *v = alloca(sizeof(*v)); - v->address = addr; - v->next = options->visited; - options->visited = v; - } - } - - TRY(PutComma(options)); - } - - return Putc(']', options->out); +int +writeAtomToStream(IOSTREAM *s, atom_t atom) +{ Yap_plwrite(MkAtomTerm(YAP_AtomFromSWIAtom(atom)), s, 0, 0, 1200); + return 1; } - -static bool -writeList(term_t list, write_options *options) -{ GET_LD - visited *v = options->visited; - Word tail; - int rc; - - skip_list(valTermRef(list), &tail PASS_LD); - rc = writeList2(list, options, isList(*tail)); - options->visited = v; - - return rc; -} - - - -static bool -writeTerm2(term_t t, int prec, write_options *options, bool arg) -{ GET_LD - atom_t functor; - int arity, n; - int op_type, op_pri; - atom_t a; - IOSTREAM *out = options->out; - - if ( !PL_is_variable(t) && - true(options, PL_WRT_PORTRAY) ) - { switch( callPortray(t, options) ) - { case TRUE: - return TRUE; - case FALSE: - break; - default: - return FALSE; - } - } - -#if __YAP_PROLOG__ - t = Yap_CvtTerm(t); -#endif - if ( PL_get_atom(t, &a) ) - { if ( !arg && prec < 1200 && priorityOperator((Module)NULL, a) > 0 ) - { if ( PutOpenBrace(out) && - writeAtom(a, options) && - PutCloseBrace(out) ) - succeed; - } else - return writeAtom(a, options); - } - - if ( !PL_get_name_arity(t, &functor, &arity) ) - { return writePrimitive(t, options); - } else - { if ( arity == 1 && - functor == ATOM_isovar && /* $VAR/1 */ - true(options, PL_WRT_NUMBERVARS) ) - { int n; - atom_t a; - term_t arg = PL_new_term_ref(); - - _PL_get_arg(1, t, arg); -#if __YAP_PROLOG__ - /* YAP supports $VAR(-1) as a quick hack to write singleton variables */ -#define MIN_DOLLAR_VAR -1 -#else -#define MIN_DOLLAR_VAR 0 -#endif - if ( PL_get_integer(arg, &n) && n >= MIN_DOLLAR_VAR ) - { int i = n % 26; - int j = n / 26; - char buf[16]; - -#if __YAP_PROLOG__ - if ( n == -1 ) { - buf[0] = '_'; - buf[1] = EOS; - } else -#endif - if ( j == 0 ) - { buf[0] = i+'A'; - buf[1] = EOS; - } else - { sprintf(buf, "%c%d", i+'A', j); - } - - return PutToken(buf, out); - } - if ( PL_get_atom(arg, &a) ) - { write_options o2 = *options; - clear(&o2, PL_WRT_QUOTED); - - return writeAtom(a, &o2); - } - } - - - if ( false(options, PL_WRT_IGNOREOPS) ) - { term_t arg = PL_new_term_ref(); - - if ( arity == 1 ) - { if ( functor == ATOM_curl ) /* {a,b,c} */ - { _PL_get_arg(1, t, arg); - TRY(Putc('{', out)); - TRY(writeTerm(arg, 1200, options) && - Putc('}', out)); - - succeed; - } - - /* op */ - if ( currentOperator(options->module, functor, OP_PREFIX, - &op_type, &op_pri) ) - { term_t arg = PL_new_term_ref(); - int embrace; - - embrace = ( op_pri > prec ); - - _PL_get_arg(1, t, arg); - if ( embrace ) - { TRY(PutOpenBrace(out)); - } - TRY(writeAtom(functor, options)); - - /* +/-(Number) : avoid parsing as number */ - if ( (functor == ATOM_minus || functor == ATOM_plus) && - PL_is_number(arg) ) - { TRY(Putc('(', out)); - TRY(writeTerm(arg, 999, options)); - TRY(Putc(')', out)); - } else - { TRY(writeTerm(arg, - op_type == OP_FX ? op_pri-1 : op_pri, - options)); - } - if ( embrace ) - { TRY(PutCloseBrace(out)); - } - - succeed; - } - - /* op */ - if ( currentOperator(options->module, functor, OP_POSTFIX, - &op_type, &op_pri) ) - { term_t arg = PL_new_term_ref(); - - _PL_get_arg(1, t, arg); - if ( op_pri > prec ) - TRY(PutOpenBrace(out)); - TRY(writeTerm(arg, - op_type == OP_XF ? op_pri-1 : op_pri, - options)); - TRY(writeAtom(functor, options)); - if (op_pri > prec) - TRY(PutCloseBrace(out)); - - succeed; - } - } else if ( arity == 2 ) - { if ( functor == ATOM_dot ) /* [...] */ - return writeList(t, options); - - /* op */ - if ( currentOperator(options->module, functor, OP_INFIX, - &op_type, &op_pri) ) - { term_t l = PL_new_term_ref(); - term_t r = PL_new_term_ref(); - - _PL_get_arg(1, t, l); - _PL_get_arg(2, t, r); - - if ( op_pri > prec ) - TRY(PutOpenBrace(out)); - TRY(writeTerm(l, - op_type == OP_XFX || op_type == OP_XFY - ? op_pri-1 : op_pri, - options)); - if ( functor == ATOM_comma ) - { TRY(PutComma(options)); - } else - { switch(writeAtom(functor, options)) - { case FALSE: - fail; - case TRUE_WITH_SPACE: - TRY(Putc(' ', out)); - } - } - TRY(writeTerm(r, - op_type == OP_XFX || op_type == OP_YFX - ? op_pri-1 : op_pri, - options)); - if ( op_pri > prec ) - TRY(PutCloseBrace(out)); - succeed; - } - } - } - /* functor( ...) */ - { term_t a = PL_new_term_ref(); - - TRY(writeAtom(functor, options) && - Putc('(', out)); - for(n=0; n 0) - TRY(PutComma(options)); - _PL_get_arg(n+1, t, a); - TRY(writeArgTerm(a, 999, options, TRUE)); - } - return Putc(')', out); - } - } -} - - int writeAttributeMask(atom_t a) { if ( a == ATOM_ignore ) @@ -1362,6 +264,59 @@ static const opt_spec write_term_options[] = { NULL_ATOM, 0 } }; +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +PutOpenToken() inserts a space in the output stream if the last-written +and given character require a space to ensure a token-break. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +#define TRUE_WITH_SPACE 2 /* OK, and emitted leading space before token */ + +static bool +Putc(int c, IOSTREAM *s) +{ return Sputcode(c, s) == EOF ? FALSE : TRUE; +} + +#define LAST_C_RESERVED 0x110000 /* Above Unicode range */ +#define PREFIX_SIGN (LAST_C_RESERVED+1) + +#define isquote(c) ((c) == '\'' || (c) == '"') + +static bool +needSpace(int c, IOSTREAM *s) +{ if ( c == EOF ) + { s->lastc = EOF; + return FALSE; + } + + if ( s->lastc == PREFIX_SIGN ) /* avoid passing to is*W() functions */ + { if ( isDigit(c) || isSymbolW(c) ) + return TRUE; + return FALSE; + } + + if ( s->lastc != EOF && + ((isAlphaW(s->lastc) && isAlphaW(c)) || + (isSymbolW(s->lastc) && isSymbolW(c)) || + (s->lastc != '(' && !isBlank(s->lastc) && c == '(') || + (c == '\'' && (isDigit(s->lastc))) || + (isquote(c) && s->lastc == c) + ) ) + return TRUE; + + return FALSE; +} + + +static int +PutOpenToken(int c, IOSTREAM *s) +{ if ( needSpace(c, s) ) + { TRY(Putc(' ', s)); + return TRUE_WITH_SPACE; + } + + return TRUE; +} + word pl_write_term3(term_t stream, term_t term, term_t opts) { GET_LD @@ -1471,7 +426,7 @@ PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags) memset(&options, 0, sizeof(options)); options.flags = flags; options.out = s; - options.module = MODULE_user; + options.module = USER_MODULE; //MODULE_user; PutOpenToken(EOF, s); /* reset this */ return writeTerm(term, precedence, &options); @@ -1490,7 +445,7 @@ do_write2(term_t stream, term_t term, int flags) memset(&options, 0, sizeof(options)); options.flags = flags; options.out = s; - options.module = MODULE_user; + options.module = USER_MODULE; // MODULE_user; // if ( options.module && true(options.module, CHARESCAPE) ) if (charEscapeWriteOption(options)) options.flags |= PL_WRT_CHARESCAPES; @@ -1574,30 +529,10 @@ pl_writeln(term_t term) } -static -PRED_IMPL("$put_token", 2, put_token, 0) -{ char *s; - size_t len; - IOSTREAM *out; - - if ( !PL_get_stream_handle(A1, &out) ) - fail; - if ( !PL_get_nchars(A2, &len, &s, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) ) - fail; - - if ( PutTokenN(s, len, out) ) - return PL_release_stream(out); - - PL_release_stream(out); - fail; -} - - /******************************* * PUBLISH PREDICATES * *******************************/ BeginPredDefs(write) - PRED_DEF("$put_token", 2, put_token, 0) EndPredDefs diff --git a/packages/Dialect.defs.in b/packages/Dialect.defs.in index bc3aff68a..4fed10632 100644 --- a/packages/Dialect.defs.in +++ b/packages/Dialect.defs.in @@ -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) diff --git a/packages/Makefile.defs.in b/packages/Makefile.defs.in index 59972c2c7..c5182db88 100644 --- a/packages/Makefile.defs.in +++ b/packages/Makefile.defs.in @@ -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 diff --git a/packages/R b/packages/R index a9c5837d2..8fced60cf 160000 --- a/packages/R +++ b/packages/R @@ -1 +1 @@ -Subproject commit a9c5837d21002a02a73edf2517cb900c56a8f5bc +Subproject commit 8fced60cfb7dec6828506bdcd407adbee7bbf20f diff --git a/packages/RDF b/packages/RDF index ed9354de8..2d0bbe41c 160000 --- a/packages/RDF +++ b/packages/RDF @@ -1 +1 @@ -Subproject commit ed9354de882fe59da1906f19fd1c60a943d91641 +Subproject commit 2d0bbe41cd30c569856ea27c0934ad8a96ce2352 diff --git a/packages/chr b/packages/chr index 59f3bce3c..118e4bf76 160000 --- a/packages/chr +++ b/packages/chr @@ -1 +1 @@ -Subproject commit 59f3bce3c819d7a9459ec26bfb41c78f7dd9a500 +Subproject commit 118e4bf761362c72cb899ae433b002df7b54f5eb diff --git a/packages/clib b/packages/clib index e6b682d90..18e06cc6d 160000 --- a/packages/clib +++ b/packages/clib @@ -1 +1 @@ -Subproject commit e6b682d909a4d63ee876af70c738d900449625fb +Subproject commit 18e06cc6da47e99ce57043a710ce216842b42160 diff --git a/packages/clpqr b/packages/clpqr index f71221999..a05f9a19f 160000 --- a/packages/clpqr +++ b/packages/clpqr @@ -1 +1 @@ -Subproject commit f71221999d3f30f748c71750c5b77aa769613087 +Subproject commit a05f9a19facb1cfd137b8929c74c03433886a66d diff --git a/packages/http b/packages/http index b83111f01..c51532c21 160000 --- a/packages/http +++ b/packages/http @@ -1 +1 @@ -Subproject commit b83111f016365560dbd770a6b03868fcf7fb8144 +Subproject commit c51532c21e1ff5d3547a1020f4f23936c0d2e962 diff --git a/packages/jpl b/packages/jpl index 4742393c9..5857584a3 160000 --- a/packages/jpl +++ b/packages/jpl @@ -1 +1 @@ -Subproject commit 4742393c919d372b28df044754d6034d653967e1 +Subproject commit 5857584a3e69fe50f612f8279b2fd3ac02e346c6 diff --git a/packages/meld/Makefile.in b/packages/meld/Makefile.in index 64756d21d..df16fbc53 100644 --- a/packages/meld/Makefile.in +++ b/packages/meld/Makefile.in @@ -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 diff --git a/packages/pldoc b/packages/pldoc index 504bef629..d02a0bda2 160000 --- a/packages/pldoc +++ b/packages/pldoc @@ -1 +1 @@ -Subproject commit 504bef629eeb636945c951b946bc13b97406d0f8 +Subproject commit d02a0bda23ec6f38c86632e235bd20188f162447 diff --git a/packages/plunit b/packages/plunit index c969e90cb..b0fafe205 160000 --- a/packages/plunit +++ b/packages/plunit @@ -1 +1 @@ -Subproject commit c969e90cb0470c045a0d6e7d48ef9efcfa34e235 +Subproject commit b0fafe2051550dd37a9882b2fcc0026a11067760 diff --git a/packages/real b/packages/real index f4c629b19..3db8d8e80 160000 --- a/packages/real +++ b/packages/real @@ -1 +1 @@ -Subproject commit f4c629b195e560662d211ad11054dda458de4ddb +Subproject commit 3db8d8e80fcf41d41312f9ffe1a468c2f8c6275d diff --git a/packages/semweb b/packages/semweb index 9c1ccd0d2..239e87f78 160000 --- a/packages/semweb +++ b/packages/semweb @@ -1 +1 @@ -Subproject commit 9c1ccd0d294b450b3322823c2a1fde10a31b23eb +Subproject commit 239e87f783dccb65d9754fa8a0a870d5567a019b diff --git a/packages/sgml b/packages/sgml index 27608a1fc..5cf4dd854 160000 --- a/packages/sgml +++ b/packages/sgml @@ -1 +1 @@ -Subproject commit 27608a1fc2bcf0285891bd0aea559e7ef9335b98 +Subproject commit 5cf4dd85419ad175a1a44b66d1c7e3298a256728 diff --git a/packages/xml/Makefile.in b/packages/xml/Makefile.in new file mode 100644 index 000000000..9f86f75ee --- /dev/null +++ b/packages/xml/Makefile.in @@ -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 + diff --git a/packages/xml/xml.iso.pl b/packages/xml/xml.iso.pl new file mode 100644 index 000000000..1b0a31a49 --- /dev/null +++ b/packages/xml/xml.iso.pl @@ -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; + * - Path is a string encoding a list of SubTerm's ancestor elements in the + * form {(id)}* where is the element tag and is the value + * of any attribute _named_ id. + */ +xml_exception( Message, Document, Culprit, Path ) :- + throw( + application_error('XML Parse: ~s in ~q~nCulprit: ~q~nPath: ~s', + [Message,Document,Culprit,Path] ) + ). + +append( [], L, L ). +append( [H|T0], L, [H|T1] ) :- + append( T0, L, T1 ). + +otherwise. + +/* 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 List0 + * with Element removed. + */ +select( H, [H|T], T ). +select( Element, [H|T0], [H|T1] ):- + select( Element, T0, T1 ). + +end_of_file. + +/* is_list( +List ) holds when List is a list. Built-in? + */ +is_list( List ) :- + nonvar( List ), + is_list1( List ). + +is_list1( [] ). +is_list1( [_|_] ). diff --git a/packages/xml/xml.lpa.pl b/packages/xml/xml.lpa.pl new file mode 100644 index 000000000..c87c7e559 --- /dev/null +++ b/packages/xml/xml.lpa.pl @@ -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 ). + +number_codes( Number, Codes ) :- + number_chars( Number, Codes ). + +/* 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; + * - Path is a string encoding a list of SubTerm's ancestor elements in the + * form {(id)}* where is the element tag and is the value + * of any attribute _named_ id. + */ +xml_exception( Message, Document, Culprit, Path ) :- + throw( 23, xml_error([Message,Document,Culprit,Path] ) ). + +/* select( ?Element, ?List0, ?List1 ) is true if List1 is equal to List0 + * with Element removed. + */ +select( H, [H|T], T ). +select( Element, [H|T0], [H|T1] ):- + select( Element, T0, T1 ). + +/* is_list( +List ) holds when List is a list. + */ +is_list( List ) :- + nonvar( List ), + is_list1( List ). + +is_list1( [] ). +is_list1( [_|_] ). + diff --git a/packages/xml/xml.pl b/packages/xml/xml.pl new file mode 100644 index 000000000..4c7fe1373 --- /dev/null +++ b/packages/xml/xml.pl @@ -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 ). + +%number_codes( Number, Codes ) :- +% number_chars( Number, Codes ). + +/* 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; + * - Path is a string encoding a list of SubTerm's ancestor elements in the + * form {(id)}* where is the element tag and is the value + * of any attribute _named_ id. + */ +xml_exception( Message, Document, Culprit, Path ) :- + raise_exception( + application_error('XML Parse: ~s in ~q~nCulprit: ~q~nPath: ~s', + [Message,Document,Culprit,Path] ) + ). + +/* 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 List0 + * with Element removed. + */ +select( H, [H|T], T ). +select( Element, [H|T0], [H|T1] ):- + select( Element, T0, T1 ). + +/* is_list( +List ) holds when List is a list. + */ +%is_list( List ) :- +% nonvar( List ), +% is_list1( List ). + +%is_list1( [] ). +%is_list1( [_|_] ). + diff --git a/packages/xml/xml_acquisition.pl b/packages/xml/xml_acquisition.pl new file mode 100644 index 000000000..8f475c77d --- /dev/null +++ b/packages/xml/xml_acquisition.pl @@ -0,0 +1,1117 @@ +/* xml_acquisition.pl : XML -> Document translation. + * + * 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. + */ + +:- ensure_loaded( xml_utilities ). + +/* xml_to_document( +Controls, +XML, ?Document ) translates the list of + * character codes XML into the Prolog term Document. Controls is a list + * of terms controlling the treatment of layout characters and character + * entities. + */ +xml_to_document( Controls, XML, Document ) :- + initial_context( Controls, Context ), + ( xml_declaration( Attributes0, XML, XML1 ) -> + Attributes = Attributes0 + ; otherwise -> + XML1 = XML, + Attributes = [] + ), + xml_to_document( XML1, Context, Terms, [], WellFormed ), + xml_to_document1( WellFormed, Attributes, Terms, Document ). + +xml_to_document1( true, Attributes, Terms, xml(Attributes, Terms) ). +xml_to_document1( false, Attributes, Terms, malformed(Attributes, Terms) ). + +% unparsed( +Unparsed, +Context, ?Terms, ?Residue, ?WellFormed ) +unparsed( Unparsed, _Context, [unparsed(Unparsed)], [], false ). + +xml_declaration( Attributes ) --> + spaces, + "". + +xml_to_document( [], Context, Terms, [], WF ) :- + close_context( Context, Terms, WF ). +xml_to_document( [Char|Chars], Context, Terms, Residue, WF ) :- + ( Char =:= "<" -> + xml_markup_structure( Chars, Context, Terms, Residue, WF ) + ; Char =:= "&" -> + entity_reference( Chars, Context, Terms, Residue, WF ) + ; Char =< " ", + \+ space_preserve( Context ) -> + layouts( Chars, Context, [Char|T], T, Terms, Residue, WF ) + ; void_context( Context ) -> + unparsed( [Char|Chars], Context, Terms, Residue, WF ) + ; otherwise -> + Terms = [pcdata([Char|Chars1])|Terms1], + acquire_pcdata( Chars, Context, Chars1, Terms1, Residue, WF ) + ). + +layouts( [], Context, _Plus, _Minus, Terms, [], WF ) :- + close_context( Context, Terms, WF ). +layouts( [Char|Chars], Context, Plus, Minus, Terms, Residue, WF ) :- + ( Char =:= "<" -> + xml_markup_structure( Chars, Context, Terms, Residue, WF ) + ; Char =:= "&" -> + reference_in_layout( Chars, Context, Plus, Minus, Terms, Residue, WF ) + ; Char =< " " -> + Minus = [Char|Minus1], + layouts( Chars, Context, Plus, Minus1, Terms, Residue, WF ) + ; void_context( Context ) -> + unparsed( [Char|Chars], Context, Terms, Residue, WF ) + ; otherwise -> + Terms = [pcdata(Plus)|Terms1], + Minus = [Char|Chars1], + context_update( space_preserve, Context, true, Context1 ), + acquire_pcdata( Chars, Context1, Chars1, Terms1, Residue, WF ) + ). + +acquire_pcdata( [], Context, [], Terms, [], WF ) :- + close_context( Context, Terms, WF ). +acquire_pcdata( [Char|Chars], Context, Chars1, Terms, Residue, WF ) :- + ( Char =:= "<" -> + Chars1 = [], + xml_markup_structure( Chars, Context, Terms, Residue, WF ) + ; Char =:= "&" -> + reference_in_pcdata( Chars, Context, Chars1, Terms, Residue, WF ) + ; otherwise -> + Chars1 = [Char|Chars2], + acquire_pcdata( Chars, Context, Chars2, Terms, Residue, WF ) + ). + +xml_markup_structure( [], Context, Terms, Residue, WF ) :- + unparsed( "<", Context, Terms, Residue, WF ). +xml_markup_structure( Chars, Context, Terms, Residue, WF ) :- + Chars = [Char|Chars1], + ( Char =:= "/" -> + closing_tag( Context, Chars1, Terms, Residue, WF ) + ; Char =:= "?" -> + pi_acquisition( Chars1, Context, Terms, Residue, WF ) + ; Char =:= "!" -> + declaration_acquisition( Chars1, Context, Terms, Residue, WF ) + ; open_tag(Tag,Context,Attributes,Type, Chars, Chars2 ) -> + push_tag( Tag, Chars2, Context, Attributes, Type, Terms, Residue, WF ) + ; otherwise -> + unparsed( [0'<|Chars], Context, Terms, Residue, WF ) %' + ). + +push_tag( Tag, Chars, Context, Attributes, Type, Terms, Residue, WF ) :- + new_element(Tag, Chars, Context, Attributes, Type, Term, Rest, WF0), + push_tag1( WF0, Context, Term, Rest, Terms, Residue, WF ). + +push_tag1( true, Context, Term, Chars, [Term|Terms], Residue, WF ) :- + xml_to_document( Chars, Context, Terms, Residue, WF ). +push_tag1( false, _Context, Term, Chars, [Term], Chars, false ). + +new_element( TagChars, Chars, Context, Attributes0, Type, Term, Residue, WF ) :- + namespace_attributes( Attributes0, Context, Context1, Attributes1 ), + ( append( NSChars, [0':|TagChars1], TagChars ), %' + specific_namespace( NSChars, Context1, SpecificNamespace ) -> + Namespace0 = SpecificNamespace + ; otherwise -> + NSChars = "", + TagChars1 = TagChars, + default_namespace( Context1, Namespace0 ) + ), + current_namespace( Context1, CurrentNamespace ), + ( Namespace0 == CurrentNamespace -> + Term = element(Tag, Attributes, Contents), + Context2 = Context1 + ; otherwise -> + Term = namespace( Namespace0, NSChars, + element(Tag, Attributes, Contents) + ), + context_update( current_namespace, Context1, Namespace0, Context2 ) + ), + input_attributes( Attributes1, Context2, Attributes ), + atom_codes( Tag, TagChars1 ), + close_tag( Type, Chars, Context2, Contents, Residue, WF ). + +close_tag( empty, Residue, _Context, [], Residue, true ). +close_tag( push(Tag), Chars, Context0, Contents, Residue, WF ) :- + context_update( element, Context0, Tag, Context1 ), + xml_to_document( Chars, Context1, Contents, Residue, WF ). + +pi_acquisition( Chars, Context, Terms, Residue, WellFormed ) :- + ( inline_instruction(Target, Processing, Chars, Rest ), + Target \== xml -> + Terms = [instructions(Target, Processing)|Terms1], + xml_to_document( Rest, Context, Terms1, Residue, WellFormed ) + ; otherwise -> + unparsed( [0'<,0'?|Chars], Context, Terms, Residue, WellFormed ) + ). + +declaration_acquisition( Chars, Context, Terms, Residue, WF ) :- + ( declaration_type( Chars, Type, Chars1 ), + declaration_parse( Type, Context, Term, Context1, Chars1, Rest ) -> + Terms = [Term|Terms1], + xml_to_document( Rest, Context1, Terms1, Residue, WF ) + ; otherwise -> + unparsed( [0'<,0'!|Chars], Context, Terms, Residue, WF ) + ). + +open_tag( Tag, Namespaces, Attributes, Termination ) --> + nmtoken_chars( Tag ), + attributes( Attributes, [], Namespaces ), + spaces, + open_tag_terminator( Tag, Termination ). + +open_tag_terminator( Tag, push(Tag) ) --> + ">". +open_tag_terminator( _Tag, empty ) --> + "/>". + +declaration_parse( comment, Namespaces, comment(Comment), Namespaces ) --> + comment(Comment). +declaration_parse( cdata, Namespaces, cdata(CData), Namespaces ) --> + cdata( CData ). +declaration_parse( doctype, Namespaces0, doctype(Name, Names), Namespaces ) --> + doctype( Name, Names, Namespaces0, Namespaces ), + spaces, + ">". + +inline_instruction( Target, Processing, Plus, Minus ) :- + nmtoken(Target, Plus, Mid0 ), + spaces( Mid0, Mid1 ), + append( Processing, [0'?,0'>|Minus], Mid1 ), + !. + +entity_reference_name( Reference ) --> + nmtoken_chars( Reference ), + ";". + +declaration_type( [Char1,Char2|Chars1], Class, Rest ) :- + Chars = [Char1,Char2|Chars1], + ( declaration_type1( Char1, Char2, Chars1, Class0, Residue ) -> + Class = Class0, + Rest = Residue + ; otherwise -> + Class = generic, + Rest = Chars + ). + +declaration_type1( 0'-, 0'-, Chars, comment, Chars ). +declaration_type1( 0'[, 0'C, Chars, cdata, Residue ) :- + append( "DATA[", Residue, Chars ). +declaration_type1( 0'D, 0'O, Chars, doctype, Residue ) :- + append( "CTYPE", Residue, Chars ). + +closing_tag( Context, Chars, Terms, Residue, WellFormed ) :- + ( closing_tag_name( Tag, Chars, Rest ), + current_tag( Context, Tag ) -> + Terms = [], + Residue = Rest, + WellFormed = true + ; otherwise -> + unparsed( [0'<,0'/|Chars], Context, Terms, Residue, WellFormed ) + ). + +closing_tag_name( Tag ) --> + nmtoken_chars( Tag ), + spaces, + ">". + +entity_reference( Chars, Context, Terms, Residue, WF ) :- + reference_in_layout( Chars, Context, L, L, Terms, Residue, WF ). + +reference_in_layout( Chars, Context, Plus, Minus, Terms, Residue, WF ) :- + ( standard_character_entity( Char, Chars, Rest ) -> + Minus = [Char|Chars1], + Terms = [pcdata(Plus)|Terms1], + acquire_pcdata( Rest, Context, Chars1, Terms1, Residue, WF ) + ; entity_reference_name( Reference, Chars, Rest ), + defined_entity( Reference, Context, String ) -> + append( String, Rest, Full ), + xml_to_document( Full, Context, Terms, Residue, WF ) + ; allow_ampersand( Context ) -> + Minus = [0'&|Chars1], %' + Terms = [pcdata(Plus)|Terms1], + acquire_pcdata( Chars, Context, Chars1, Terms1, Residue, WF ) + ; otherwise -> + unparsed( [0'&|Chars], Context, Terms, Residue, WF ) %' + ). + +reference_in_pcdata( Chars0, Context, Chars1, Terms, Residue, WF ) :- + ( standard_character_entity( Char, Chars0, Rest ) -> + Chars1 = [Char|Chars2], + acquire_pcdata( Rest, Context, Chars2, Terms, Residue, WF ) + ; entity_reference_name( Reference, Chars0, Rest ), + defined_entity( Reference, Context, String ) -> + append( String, Rest, Full ), + acquire_pcdata( Full, Context, Chars1, Terms, Residue, WF ) + ; allow_ampersand( Context ) -> + Chars1 = [0'&|Chars2], + acquire_pcdata( Chars0, Context, Chars2, Terms, Residue, WF ) + ; otherwise -> + Chars1 = [], + unparsed( [0'&|Chars0], Context, Terms, Residue, WF ) + ). + +namespace_attributes( [], Context, Context, [] ). +namespace_attributes( Attributes0, Context0, Context, Attributes ) :- + Attributes0 = [_|_], + append( "xmlns:", Unqualified, QualifiedNameChars ), + ( select( "xmlns"=Value, Attributes0, Attributes1 ) -> + atom_codes( URI, Value ), + context_update( default_namespace, Context0, URI, Context1 ), + namespace_attributes( Attributes1, Context1, Context, Attributes ) + ; select( QualifiedNameChars=Value, Attributes0, Attributes1 ) -> + Attributes = [QualifiedNameChars=Value|Attributes2], + atom_codes( URI, Value ), + context_update( ns_prefix(Unqualified), Context0, URI, Context1 ), + namespace_attributes( Attributes1, Context1, Context, Attributes2 ) + ; member( "xml:space"="preserve", Attributes0 ) -> + Attributes = Attributes0, + context_update( space_preserve, Context0, true, Context ) + ; otherwise -> + Context = Context0, + Attributes = Attributes0 + ). + +input_attributes( [], _Context, [] ). +input_attributes( [NameChars=Value|Attributes0], Context, + [Name=Value|Attributes] ) :- + ( remove_attribute_prefixes( Context ), + append( NSChars, [0':|NameChars1], NameChars ), %' + NSChars \== "xmlns", + specific_namespace( NSChars, Context, Namespace ), + current_namespace( Context, Namespace ) -> + atom_codes( Name, NameChars1 ) + ; otherwise -> + atom_codes( Name, NameChars ) + ), + input_attributes( Attributes0, Context, Attributes ). + +attributes( [Name=Value|Attributes], Seen, Namespaces ) --> + spaces, + nmtoken_chars( Name ), + {\+ member(Name, Seen)}, + spaces, + "=", + spaces, + attribute_value( Value, Namespaces ), + attributes( Attributes, [Name|Seen], Namespaces ). +attributes( [], _Seen, _Namespaces ) --> "". + +xml_declaration_attributes( [] ) --> "". +xml_declaration_attributes( [Name=Value|Attributes] ) --> + spaces, + nmtoken( Name ), + spaces, + "=", + spaces, + xml_string( Value ), + {xml_declaration_attribute_valid(Name, Value)}, + xml_declaration_attributes( Attributes ), + spaces. + +doctype( Name, External, Namespaces0, Namespaces1 ) --> + spaces, + nmtoken( Name ), + spaces, + doctype_id( External0 ), + spaces, + doctype1( Namespaces0, Literals, Namespaces1 ), + {doctype_extension(Literals, External0, External)}. + +doctype_extension( [], External, External ). +doctype_extension( [Literal|Literals], External0, External ) :- + extended_doctype( External0, [Literal|Literals], External ). + +extended_doctype( system(URL), Literals, system(URL,Literals) ). +extended_doctype( public(URN,URL), Literals, public(URN,URL,Literals) ). +extended_doctype( local, Literals, local(Literals) ). + +doctype1( Namespaces0, Literals, Namespaces1 ) --> + "[", + !, + dtd( Namespaces0, Literals, Namespaces1 ), + "]". +doctype1( Namespaces, [], Namespaces ) --> "". + +doctype_id( system(URL) ) --> + "SYSTEM", + spaces, + uri( URL ). +doctype_id( public(URN,URL) ) --> + "PUBLIC", + spaces, + uri( URN ), + spaces, + uri( URL ). +doctype_id( local ) --> "". + +dtd( Namespaces0, Literals, Namespaces1 ) --> + spaces, + "", + {(\+ character_entity( Name, StandardChar ) + ; String = [StandardChar], character_entity( Name, StandardChar ) + ), + % Don't allow < "e; etc. to be updated + context_update( entity(Name), Namespaces0, String, Namespaces2 ) + }, + dtd( Namespaces2, Literals, Namespaces1 ). +dtd( Namespaces0, Literals, Namespaces1 ) --> + spaces, + " + spaces, + " spaces. + +dtd_literal( [] ) --> ">", !. +dtd_literal( Chars ) --> + "--", + !, + dtd_comment, + dtd_literal( Chars ). +dtd_literal( [Char|Chars] ) --> + [Char], + dtd_literal( Chars ). + +dtd_comment( Plus, Minus ) :- + append( _Chars, [0'-,0'-|Minus], Plus ), + !. + +nmtokens( [Name|Names] ) --> + spaces, + nmtoken( Name ), + nmtokens( Names ). +nmtokens( [] ) --> []. + +entity_value( Quote, Namespaces, String, [Char|Plus], Minus ) :- + ( Char == Quote -> + String = [], + Minus = Plus + ; Char =:= "&" -> + reference_in_entity( Namespaces, Quote, String, Plus, Minus ) + ; otherwise -> + String = [Char|String1], + entity_value( Quote, Namespaces, String1, Plus, Minus ) + ). + +attribute_value( String, Namespaces ) --> + quote( Quote ), + attribute_leading_layouts( Quote, Namespaces, String ). + +attribute_leading_layouts( _Quote, _Namespace, [], [], [] ). +attribute_leading_layouts( Quote, Namespaces, String, [Char|Plus], Minus ) :- + ( Char == Quote -> + String = [], + Minus = Plus + ; Char =:= "&" -> + ref_in_attribute_layout( Namespaces, Quote, String, Plus, Minus ) + ; Char > 32, Char \== 160 -> + String = [Char|String1], + attribute_layouts( Quote, Namespaces, false, String1, Plus, Minus ) + ; otherwise -> + attribute_leading_layouts( Quote, Namespaces, String, Plus, Minus ) + ). + +attribute_layouts( _Quote, _Namespaces, _Layout, [], [], [] ). +attribute_layouts( Quote, Namespaces, Layout, String, [Char|Plus], Minus ) :- + ( Char == Quote -> + String = [], + Minus = Plus + ; Char =:= "&" -> + reference_in_value( Namespaces, Quote, Layout, String, Plus, Minus ) + ; Char > 32, Char \== 160 -> + ( Layout == true -> + String = [0' ,Char|String1] %' + ; otherwise -> + String = [Char|String1] + ), + attribute_layouts( Quote, Namespaces, false, String1, Plus, Minus ) + ; otherwise -> + attribute_layouts( Quote, Namespaces, true, String, Plus, Minus ) + ). + +ref_in_attribute_layout( NS, Quote, String, Plus, Minus ) :- + ( standard_character_entity( Char, Plus, Mid ) -> + String = [Char|String1], + attribute_layouts( Quote, NS, false, String1, Mid, Minus ) + ; entity_reference_name( Name, Plus, Suffix ), + defined_entity( Name, NS, Text ) -> + append( Text, Suffix, Mid ), + attribute_leading_layouts( Quote, NS, String, Mid, Minus ) + ; otherwise -> % Just & is okay in a value + String = [0'&|String1], %' + attribute_layouts( Quote, NS, false, String1, Plus, Minus ) + ). + +reference_in_value( Namespaces, Quote, Layout, String, Plus, Minus ) :- + ( standard_character_entity( Char, Plus, Mid ) -> + ( Layout == true -> + String = [0' ,Char|String1] %' + ; otherwise -> + String = [Char|String1] + ), + Layout1 = false + ; entity_reference_name( Name, Plus, Suffix ), + defined_entity( Name, Namespaces, Text ) -> + String = String1, + append( Text, Suffix, Mid ), + Layout1 = Layout + ; otherwise -> % Just & is okay in a value + Mid = Plus, + String = [0'&|String1], %' + Layout1 = false + ), + attribute_layouts( Quote, Namespaces, Layout1, String1, Mid, Minus ). + +/* References are resolved backwards in Entity defintions so that + * circularity is avoided. + */ +reference_in_entity( Namespaces, Quote, String, Plus, Minus ) :- + ( standard_character_entity( _SomeChar, Plus, _Rest ) -> + String = [0'&|String1], % ' Character entities are unparsed + Mid = Plus + ; entity_reference_name( Name, Plus, Suffix ), + defined_entity( Name, Namespaces, Text ) -> + String = String1, + append( Text, Suffix, Mid ) + ), + entity_value( Quote, Namespaces, String1, Mid, Minus ). + +standard_character_entity( Char ) --> + "#x", hex_character_reference( Char ), ";". +standard_character_entity( Char ) --> + "#", digit( Digit ), digits( Digits ), ";", + {number_chars( Char, [Digit|Digits])}. +standard_character_entity( C ) --> + chars( String ), + ";", + !, + {character_entity(String, C)}. + +uri( URI ) --> + quote( Quote ), + uri1( Quote, URI ). + +uri1( Quote, [] ) --> + quote( Quote ), + !. +uri1( Quote, [Char|Chars] ) --> + [Char], + uri1( Quote, Chars ). + +comment( Chars, Plus, Minus ) :- + append( Chars, [0'-,0'-,0'>|Minus], Plus ), %' + !. + +cdata( Chars, Plus, Minus ) :- + append( Chars, [0'],0'],0'>|Minus], Plus ), %' + !. +% Syntax Components + +hex_character_reference( Code ) --> + hex_character_reference1( 0, Code ). + +hex_character_reference1( Current, Code ) --> + hex_digit_char( Value ), + !, + {New is (Current << 4) + Value}, + hex_character_reference1( New, Code ). +hex_character_reference1( Code, Code ) --> "". + +hex_digit_char( 0 ) --> "0". +hex_digit_char( 1 ) --> "1". +hex_digit_char( 2 ) --> "2". +hex_digit_char( 3 ) --> "3". +hex_digit_char( 4 ) --> "4". +hex_digit_char( 5 ) --> "5". +hex_digit_char( 6 ) --> "6". +hex_digit_char( 7 ) --> "7". +hex_digit_char( 8 ) --> "8". +hex_digit_char( 9 ) --> "9". +hex_digit_char( 10 ) --> "A". +hex_digit_char( 11 ) --> "B". +hex_digit_char( 12 ) --> "C". +hex_digit_char( 13 ) --> "D". +hex_digit_char( 14 ) --> "E". +hex_digit_char( 15 ) --> "F". +hex_digit_char( 10 ) --> "a". +hex_digit_char( 11 ) --> "b". +hex_digit_char( 12 ) --> "c". +hex_digit_char( 13 ) --> "d". +hex_digit_char( 14 ) --> "e". +hex_digit_char( 15 ) --> "f". + +quote( 0'" ) --> %' + """". +quote( 0'' ) --> + "'". + +spaces( [], [] ). +spaces( [Char|Chars0], Chars1 ) :- + ( Char =< 32 -> + spaces( Chars0, Chars1 ) + ; otherwise -> + Chars1 = [Char|Chars0] + ). + +nmtoken( Name ) --> + nmtoken_chars( Chars ), + {atom_codes(Name, Chars)}. + +nmtoken_chars( [Char|Chars] ) --> + [Char], + {nmtoken_first( Char )}, + nmtoken_chars_tail( Chars ). + +nmtoken_chars_tail( [Char|Chars] ) --> + [Char], + {nmtoken_char(Char)}, + !, + nmtoken_chars_tail( Chars ). +nmtoken_chars_tail([]) --> "". + +nmtoken_first( 0': ). +nmtoken_first( 0'_ ). +nmtoken_first( Char ) :- + alphabet( Char ). + +nmtoken_char( 0'a ). +nmtoken_char( 0'b ). +nmtoken_char( 0'c ). +nmtoken_char( 0'd ). +nmtoken_char( 0'e ). +nmtoken_char( 0'f ). +nmtoken_char( 0'g ). +nmtoken_char( 0'h ). +nmtoken_char( 0'i ). +nmtoken_char( 0'j ). +nmtoken_char( 0'k ). +nmtoken_char( 0'l ). +nmtoken_char( 0'm ). +nmtoken_char( 0'n ). +nmtoken_char( 0'o ). +nmtoken_char( 0'p ). +nmtoken_char( 0'q ). +nmtoken_char( 0'r ). +nmtoken_char( 0's ). +nmtoken_char( 0't ). +nmtoken_char( 0'u ). +nmtoken_char( 0'v ). +nmtoken_char( 0'w ). +nmtoken_char( 0'x ). +nmtoken_char( 0'y ). +nmtoken_char( 0'z ). +nmtoken_char( 0'A ). +nmtoken_char( 0'B ). +nmtoken_char( 0'C ). +nmtoken_char( 0'D ). +nmtoken_char( 0'E ). +nmtoken_char( 0'F ). +nmtoken_char( 0'G ). +nmtoken_char( 0'H ). +nmtoken_char( 0'I ). +nmtoken_char( 0'J ). +nmtoken_char( 0'K ). +nmtoken_char( 0'L ). +nmtoken_char( 0'M ). +nmtoken_char( 0'N ). +nmtoken_char( 0'O ). +nmtoken_char( 0'P ). +nmtoken_char( 0'Q ). +nmtoken_char( 0'R ). +nmtoken_char( 0'S ). +nmtoken_char( 0'T ). +nmtoken_char( 0'U ). +nmtoken_char( 0'V ). +nmtoken_char( 0'W ). +nmtoken_char( 0'X ). +nmtoken_char( 0'Y ). +nmtoken_char( 0'Z ). +nmtoken_char( 0'0 ). +nmtoken_char( 0'1 ). +nmtoken_char( 0'2 ). +nmtoken_char( 0'3 ). +nmtoken_char( 0'4 ). +nmtoken_char( 0'5 ). +nmtoken_char( 0'6 ). +nmtoken_char( 0'7 ). +nmtoken_char( 0'8 ). +nmtoken_char( 0'9 ). +nmtoken_char( 0'. ). +nmtoken_char( 0'- ). +nmtoken_char( 0'_ ). +nmtoken_char( 0': ). + +xml_string( String ) --> + quote( Quote ), + xml_string1( Quote, String ). + +xml_string1( Quote, [] ) --> + quote( Quote ), + !. +xml_string1( Quote, [Char|Chars] ) --> + [Char], + xml_string1( Quote, Chars ). + +alphabet( 0'a ). +alphabet( 0'b ). +alphabet( 0'c ). +alphabet( 0'd ). +alphabet( 0'e ). +alphabet( 0'f ). +alphabet( 0'g ). +alphabet( 0'h ). +alphabet( 0'i ). +alphabet( 0'j ). +alphabet( 0'k ). +alphabet( 0'l ). +alphabet( 0'm ). +alphabet( 0'n ). +alphabet( 0'o ). +alphabet( 0'p ). +alphabet( 0'q ). +alphabet( 0'r ). +alphabet( 0's ). +alphabet( 0't ). +alphabet( 0'u ). +alphabet( 0'v ). +alphabet( 0'w ). +alphabet( 0'x ). +alphabet( 0'y ). +alphabet( 0'z ). +alphabet( 0'A ). +alphabet( 0'B ). +alphabet( 0'C ). +alphabet( 0'D ). +alphabet( 0'E ). +alphabet( 0'F ). +alphabet( 0'G ). +alphabet( 0'H ). +alphabet( 0'I ). +alphabet( 0'J ). +alphabet( 0'K ). +alphabet( 0'L ). +alphabet( 0'M ). +alphabet( 0'N ). +alphabet( 0'O ). +alphabet( 0'P ). +alphabet( 0'Q ). +alphabet( 0'R ). +alphabet( 0'S ). +alphabet( 0'T ). +alphabet( 0'U ). +alphabet( 0'V ). +alphabet( 0'W ). +alphabet( 0'X ). +alphabet( 0'Y ). +alphabet( 0'Z ). + +digit( C ) --> [C], {digit_table( C )}. + +digit_table( 0'0 ). +digit_table( 0'1 ). +digit_table( 0'2 ). +digit_table( 0'3 ). +digit_table( 0'4 ). +digit_table( 0'5 ). +digit_table( 0'6 ). +digit_table( 0'7 ). +digit_table( 0'8 ). +digit_table( 0'9 ). + +digits( [Digit|Digits] ) --> + digit( Digit ), + digits( Digits ). +digits( [] ) --> []. + +character_entity( "quot", 0'" ). %' +character_entity( "amp", 0'& ). %' +character_entity( "lt", 0'< ). %' +character_entity( "gt", 0'> ). %' +character_entity( "apos", 0'' ). + +end_of_file. + +/* For reference, this is a comprehensive recognizer for namechar, based on + * the definition of in http://www.w3.org/TR/2000/REC-xml-20001006 . + */ +namechar --> + ( letter + | unicode_digit + | "." + | "-" + | "_" + | ":" + | combiningchar + | extender + ). + +letter --> (basechar | ideographic). + +basechar --> + ( range( 16'0041, 16'005A ) + | range( 16'0061, 16'007A ) + | range( 16'00C0, 16'00D6 ) + | range( 16'00D8, 16'00F6 ) + | range( 16'00F8, 16'00FF ) + | range( 16'0100, 16'0131 ) + | range( 16'0134, 16'013E ) + | range( 16'0141, 16'0148 ) + | range( 16'014A, 16'017E ) + | range( 16'0180, 16'01C3 ) + | range( 16'01CD, 16'01F0 ) + | range( 16'01F4, 16'01F5 ) + | range( 16'01FA, 16'0217 ) + | range( 16'0250, 16'02A8 ) + | range( 16'02BB, 16'02C1 ) + | [16'0386] + | range( 16'0388, 16'038A ) + | [16'038C] + | range( 16'038E, 16'03A1 ) + | range( 16'03A3, 16'03CE ) + | range( 16'03D0, 16'03D6 ) + | [16'03DA] + | [16'03DC] + | [16'03DE] + | [16'03E0] + | range( 16'03E2, 16'03F3 ) + | range( 16'0401, 16'040C ) + | range( 16'040E, 16'044F ) + | range( 16'0451, 16'045C ) + | range( 16'045E, 16'0481 ) + | range( 16'0490, 16'04C4 ) + | range( 16'04C7, 16'04C8 ) + | range( 16'04CB, 16'04CC ) + | range( 16'04D0, 16'04EB ) + | range( 16'04EE, 16'04F5 ) + | range( 16'04F8, 16'04F9 ) + | range( 16'0531, 16'0556 ) + | [16'0559] + | range( 16'0561, 16'0586 ) + | range( 16'05D0, 16'05EA ) + | range( 16'05F0, 16'05F2 ) + | range( 16'0621, 16'063A ) + | range( 16'0641, 16'064A ) + | range( 16'0671, 16'06B7 ) + | range( 16'06BA, 16'06BE ) + | range( 16'06C0, 16'06CE ) + | range( 16'06D0, 16'06D3 ) + | [16'06D5] + | range( 16'06E5, 16'06E6 ) + | range( 16'0905, 16'0939 ) + | [16'093D] + | range( 16'0958, 16'0961 ) + | range( 16'0985, 16'098C ) + | range( 16'098F, 16'0990 ) + | range( 16'0993, 16'09A8 ) + | range( 16'09AA, 16'09B0 ) + | [16'09B2] + | range( 16'09B6, 16'09B9 ) + | range( 16'09DC, 16'09DD ) + | range( 16'09DF, 16'09E1 ) + | range( 16'09F0, 16'09F1 ) + | range( 16'0A05, 16'0A0A ) + | range( 16'0A0F, 16'0A10 ) + | range( 16'0A13, 16'0A28 ) + | range( 16'0A2A, 16'0A30 ) + | range( 16'0A32, 16'0A33 ) + | range( 16'0A35, 16'0A36 ) + | range( 16'0A38, 16'0A39 ) + | range( 16'0A59, 16'0A5C ) + | [16'0A5E] + | range( 16'0A72, 16'0A74 ) + | range( 16'0A85, 16'0A8B ) + | [16'0A8D] + | range( 16'0A8F, 16'0A91 ) + | range( 16'0A93, 16'0AA8 ) + | range( 16'0AAA, 16'0AB0 ) + | range( 16'0AB2, 16'0AB3 ) + | range( 16'0AB5, 16'0AB9 ) + | [16'0ABD] + | [16'0AE0] + | range( 16'0B05, 16'0B0C ) + | range( 16'0B0F, 16'0B10 ) + | range( 16'0B13, 16'0B28 ) + | range( 16'0B2A, 16'0B30 ) + | range( 16'0B32, 16'0B33 ) + | range( 16'0B36, 16'0B39 ) + | [16'0B3D] + | range( 16'0B5C, 16'0B5D ) + | range( 16'0B5F, 16'0B61 ) + | range( 16'0B85, 16'0B8A ) + | range( 16'0B8E, 16'0B90 ) + | range( 16'0B92, 16'0B95 ) + | range( 16'0B99, 16'0B9A ) + | [16'0B9C] + | range( 16'0B9E, 16'0B9F ) + | range( 16'0BA3, 16'0BA4 ) + | range( 16'0BA8, 16'0BAA ) + | range( 16'0BAE, 16'0BB5 ) + | range( 16'0BB7, 16'0BB9 ) + | range( 16'0C05, 16'0C0C ) + | range( 16'0C0E, 16'0C10 ) + | range( 16'0C12, 16'0C28 ) + | range( 16'0C2A, 16'0C33 ) + | range( 16'0C35, 16'0C39 ) + | range( 16'0C60, 16'0C61 ) + | range( 16'0C85, 16'0C8C ) + | range( 16'0C8E, 16'0C90 ) + | range( 16'0C92, 16'0CA8 ) + | range( 16'0CAA, 16'0CB3 ) + | range( 16'0CB5, 16'0CB9 ) + | [16'0CDE] + | range( 16'0CE0, 16'0CE1 ) + | range( 16'0D05, 16'0D0C ) + | range( 16'0D0E, 16'0D10 ) + | range( 16'0D12, 16'0D28 ) + | range( 16'0D2A, 16'0D39 ) + | range( 16'0D60, 16'0D61 ) + | range( 16'0E01, 16'0E2E ) + | [16'0E30] + | range( 16'0E32, 16'0E33 ) + | range( 16'0E40, 16'0E45 ) + | range( 16'0E81, 16'0E82 ) + | [16'0E84] + | range( 16'0E87, 16'0E88 ) + | [16'0E8A] + | [16'0E8D] + | range( 16'0E94, 16'0E97 ) + | range( 16'0E99, 16'0E9F ) + | range( 16'0EA1, 16'0EA3 ) + | [16'0EA5] + | [16'0EA7] + | range( 16'0EAA, 16'0EAB ) + | range( 16'0EAD, 16'0EAE ) + | [16'0EB0] + | range( 16'0EB2, 16'0EB3 ) + | [16'0EBD] + | range( 16'0EC0, 16'0EC4 ) + | range( 16'0F40, 16'0F47 ) + | range( 16'0F49, 16'0F69 ) + | range( 16'10A0, 16'10C5 ) + | range( 16'10D0, 16'10F6 ) + | [16'1100] + | range( 16'1102, 16'1103 ) + | range( 16'1105, 16'1107 ) + | [16'1109] + | range( 16'110B, 16'110C ) + | range( 16'110E, 16'1112 ) + | [16'113C] + | [16'113E] + | [16'1140] + | [16'114C] + | [16'114E] + | [16'1150] + | range( 16'1154, 16'1155 ) + | [16'1159] + | range( 16'115F, 16'1161 ) + | [16'1163] + | [16'1165] + | [16'1167] + | [16'1169] + | range( 16'116D, 16'116E ) + | range( 16'1172, 16'1173 ) + | [16'1175] + | [16'119E] + | [16'11A8] + | [16'11AB] + | range( 16'11AE, 16'11AF ) + | range( 16'11B7, 16'11B8 ) + | [16'11BA] + | range( 16'11BC, 16'11C2 ) + | [16'11EB] + | [16'11F0] + | [16'11F9] + | range( 16'1E00, 16'1E9B ) + | range( 16'1EA0, 16'1EF9 ) + | range( 16'1F00, 16'1F15 ) + | range( 16'1F18, 16'1F1D ) + | range( 16'1F20, 16'1F45 ) + | range( 16'1F48, 16'1F4D ) + | range( 16'1F50, 16'1F57 ) + | [16'1F59] + | [16'1F5B] + | [16'1F5D] + | range( 16'1F5F, 16'1F7D ) + | range( 16'1F80, 16'1FB4 ) + | range( 16'1FB6, 16'1FBC ) + | [16'1FBE] + | range( 16'1FC2, 16'1FC4 ) + | range( 16'1FC6, 16'1FCC ) + | range( 16'1FD0, 16'1FD3 ) + | range( 16'1FD6, 16'1FDB ) + | range( 16'1FE0, 16'1FEC ) + | range( 16'1FF2, 16'1FF4 ) + | range( 16'1FF6, 16'1FFC ) + | [16'2126] + | range( 16'212A, 16'212B ) + | [16'212E] + | range( 16'2180, 16'2182 ) + | range( 16'3041, 16'3094 ) + | range( 16'30A1, 16'30FA ) + | range( 16'3105, 16'312C ) + | range( 16'AC00, 16'D7A3 ) + ). +ideographic --> + ( range( 16'4E00, 16'9FA5 ) + | [16'3007] + | range( 16'3021, 16'3029 ) + ). +combiningchar --> + ( range( 16'0300, 16'0345 ) + | range( 16'0360, 16'0361 ) + | range( 16'0483, 16'0486 ) + | range( 16'0591, 16'05A1 ) + | range( 16'05A3, 16'05B9 ) + | range( 16'05BB, 16'05BD ) + | [16'05BF] + | range( 16'05C1, 16'05C2 ) + | [16'05C4] + | range( 16'064B, 16'0652 ) + | [16'0670] + | range( 16'06D6, 16'06DC ) + | range( 16'06DD, 16'06DF ) + | range( 16'06E0, 16'06E4 ) + | range( 16'06E7, 16'06E8 ) + | range( 16'06EA, 16'06ED ) + | range( 16'0901, 16'0903 ) + | [16'093C] + | range( 16'093E, 16'094C ) + | [16'094D] + | range( 16'0951, 16'0954 ) + | range( 16'0962, 16'0963 ) + | range( 16'0981, 16'0983 ) + | [16'09BC] + | [16'09BE] + | [16'09BF] + | range( 16'09C0, 16'09C4 ) + | range( 16'09C7, 16'09C8 ) + | range( 16'09CB, 16'09CD ) + | [16'09D7] + | range( 16'09E2, 16'09E3 ) + | [16'0A02] + | [16'0A3C] + | [16'0A3E] + | [16'0A3F] + | range( 16'0A40, 16'0A42 ) + | range( 16'0A47, 16'0A48 ) + | range( 16'0A4B, 16'0A4D ) + | range( 16'0A70, 16'0A71 ) + | range( 16'0A81, 16'0A83 ) + | [16'0ABC] + | range( 16'0ABE, 16'0AC5 ) + | range( 16'0AC7, 16'0AC9 ) + | range( 16'0ACB, 16'0ACD ) + | range( 16'0B01, 16'0B03 ) + | [16'0B3C] + | range( 16'0B3E, 16'0B43 ) + | range( 16'0B47, 16'0B48 ) + | range( 16'0B4B, 16'0B4D ) + | range( 16'0B56, 16'0B57 ) + | range( 16'0B82, 16'0B83 ) + | range( 16'0BBE, 16'0BC2 ) + | range( 16'0BC6, 16'0BC8 ) + | range( 16'0BCA, 16'0BCD ) + | [16'0BD7] + | range( 16'0C01, 16'0C03 ) + | range( 16'0C3E, 16'0C44 ) + | range( 16'0C46, 16'0C48 ) + | range( 16'0C4A, 16'0C4D ) + | range( 16'0C55, 16'0C56 ) + | range( 16'0C82, 16'0C83 ) + | range( 16'0CBE, 16'0CC4 ) + | range( 16'0CC6, 16'0CC8 ) + | range( 16'0CCA, 16'0CCD ) + | range( 16'0CD5, 16'0CD6 ) + | range( 16'0D02, 16'0D03 ) + | range( 16'0D3E, 16'0D43 ) + | range( 16'0D46, 16'0D48 ) + | range( 16'0D4A, 16'0D4D ) + | [16'0D57] + | [16'0E31] + | range( 16'0E34, 16'0E3A ) + | range( 16'0E47, 16'0E4E ) + | [16'0EB1] + | range( 16'0EB4, 16'0EB9 ) + | range( 16'0EBB, 16'0EBC ) + | range( 16'0EC8, 16'0ECD ) + | range( 16'0F18, 16'0F19 ) + | [16'0F35] + | [16'0F37] + | [16'0F39] + | [16'0F3E] + | [16'0F3F] + | range( 16'0F71, 16'0F84 ) + | range( 16'0F86, 16'0F8B ) + | range( 16'0F90, 16'0F95 ) + | [16'0F97] + | range( 16'0F99, 16'0FAD ) + | range( 16'0FB1, 16'0FB7 ) + | [16'0FB9] + | range( 16'20D0, 16'20DC ) + | [16'20E1] + | range( 16'302A, 16'302F ) + | [16'3099] + | [16'309A] + ). + +unicode_digit --> + ( range( 16'0030, 16'0039 ) + | range( 16'0660, 16'0669 ) + | range( 16'06F0, 16'06F9 ) + | range( 16'0966, 16'096F ) + | range( 16'09E6, 16'09EF ) + | range( 16'0A66, 16'0A6F ) + | range( 16'0AE6, 16'0AEF ) + | range( 16'0B66, 16'0B6F ) + | range( 16'0BE7, 16'0BEF ) + | range( 16'0C66, 16'0C6F ) + | range( 16'0CE6, 16'0CEF ) + | range( 16'0D66, 16'0D6F ) + | range( 16'0E50, 16'0E59 ) + | range( 16'0ED0, 16'0ED9 ) + | range( 16'0F20, 16'0F29 ) + ). + +extender --> + ( [16'00B7] + | [16'02D0] + | [16'02D1] + | [16'0387] + | [16'0640] + | [16'0E46] + | [16'0EC6] + | [16'3005] + | range( 16'3031, 16'3035 ) + | range( 16'309D, 16'309E ) + | range( 16'30FC, 16'30FE ) + ). + +range( Low, High ) --> + [Char], + {Char >= Low, Char =< High}. diff --git a/packages/xml/xml_diagnosis.pl b/packages/xml/xml_diagnosis.pl new file mode 100644 index 000000000..7988eaaf9 --- /dev/null +++ b/packages/xml/xml_diagnosis.pl @@ -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 {(id)}* where is the + * element tag and 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 ) :- + element_fault( Element, [0' |Indent], Culprit, Path, Message ). +xml_content_fault( Element, Indent, Culprit, Path, Message ) :- + element_fault( Element, [0' |Indent], Culprit, Path, Message ). +xml_content_fault( Term, Indent, Term, [], "Illegal Term" ) :- + \+ generation(Term, "", false, Indent, _Format, _Plus, _Minus ). + +element_fault( element(Tag, _Attributes, _Contents), _Indent, Tag, [], "Tag must be an atom" ) :- + \+ atom( Tag ). +element_fault( element(Tag, Attributes, _Contents), _Indent, Tag, [], "Attributes must be instantiated" ) :- + var( Attributes ). +element_fault( element(Tag, Attributes, _Contents), _Indent, Faulty, Path, Message ) :- + fault_path( Tag, Attributes, Path, [] ), + member( Attribute, Attributes ), + attribute_fault( Attribute, Faulty, Message ). +element_fault( element(Tag, Attributes, Contents), Indent, Culprit, Path, Message ) :- + fault_path( Tag, Attributes, Path, Path1 ), + xml_content_fault( Contents, Indent, Culprit, Path1, Message ). + +attribute_fault( Attribute, Attribute, "Illegal Variable" ) :- + var( Attribute ). +attribute_fault( Name=Value, Name=Value, "Attribute Name must be atom" ) :- + \+ atom(Name). +attribute_fault( Name=Value, Name=Value, "Attribute Value must be chars" ) :- + \+ is_chars( Value ). +attribute_fault( Attribute, Attribute, "Malformed Attribute" ) :- + \+ Attribute = (_Name=_Value). + +is_chars( Chars ) :- + is_list( Chars ), + \+ (member( Char, Chars ), \+ (integer(Char), Char >=0, Char =< 255)). + +fault_path( Tag, Attributes ) --> + {atom_codes( Tag, Chars )}, + chars( Chars ), + fault_id( Attributes ), + " ". + +fault_id( Attributes ) --> + {member( id=Chars, Attributes ), is_chars( Chars )}, + !, + "(", chars(Chars), ")". +fault_id( _Attributes ) --> "". diff --git a/packages/xml/xml_driver.pl b/packages/xml/xml_driver.pl new file mode 100644 index 000000000..d054e981a --- /dev/null +++ b/packages/xml/xml_driver.pl @@ -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(, ). is a list of + * = attributes from the (possibly implicit) XML signature of the + * document. is a (possibly empty) list comprising occurrences of : + * + * pcdata() : Text + * comment() : An xml comment; + * element(,,) : .. encloses + * : if empty + * instructions(, ) : Processing ?>" + * cdata( ) : ]]> + * doctype(, ) : DTD + * + * 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( ) : Text which has not been parsed + * out_of_context( ) : 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 + * {(id)}* where is the value of any attribute _named_ id. + * + * At this release, the Controls applying to in-bound (Chars -> Document) + * parsing are: + * + * extended_characters() : Use the extended character + * : entities for XHTML (default true) + * + * format() : Strip layouts when no character data + * : appears between elements. + * : (default true) + * + * remove_attribute_prefixes() : Remove namespace prefixes from + * : attributes when it's the same as the + * : prefix of the parent element + * : (default false). + * + * allow_ampersand() : Allow unescaped ampersand + * : characters (&) to occur in PCDATA. + * : (default false). + * + * [ is one of 'true' or 'false'] + * + * For out-bound (Document -> Chars) parsing, the only available option is: + * + * format() : Indent the element content + * : (default true) + * + * Different DCGs for input and output are used because input parsing is + * more flexible than output parsing. Errors in input are recorded as part + * of the data structure. Output parsing throws an exception if the document + * is not well-formed, diagnosis tries to identify the specific culprit term. + */ +xml_parse( Chars, Document ) :- + xml_parse( [], Chars, Document ). + +xml_parse( Controls, Chars, Document ) :- + ( ground( Chars ) -> + xml_to_document( Controls, Chars, Document ) + ; otherwise -> + document_to_xml( Controls, Document, Chars ) + ). + +document_to_xml( Controls, Document, Chars ) :- + ( member( format(false), Controls ) -> + Format = false + ; otherwise -> + Format = true + ), + ( ground( Document ), + document_generation(Format, Document, Chars0, [] ) -> + Chars = Chars0 + ; otherwise -> + xml_fault( Document, [], Culprit, Path, Message ), + xml_exception( Message, Document, Culprit, Path ) + ). + +/* xml_subterm( +XMLTerm, ?Subterm ) unifies Subterm with a sub-term of Term. + * Note that XMLTerm is a sub-term of itself. + */ +xml_subterm( Term, Term ). +xml_subterm( xml(_Attributes, Content), Term ) :- + xml_subterm( Content, Term ). +xml_subterm( [H|T], Term ) :- + ( xml_subterm( H, Term ) + ; xml_subterm( T, Term ) + ). +xml_subterm( element(_Name,_Attributes,Content), Term ) :- + xml_subterm( Content, Term ). +xml_subterm( namespace(_URI,_Prefix,Content), Term ) :- + xml_subterm( Content, Term ). + +/* 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_acquisition ). +:- ensure_loaded( xml_diagnosis ). +:- ensure_loaded( xml_generation ). +:- ensure_loaded( xml_pp ). +:- ensure_loaded( xml_utilities ). diff --git a/packages/xml/xml_example/bib.xml b/packages/xml/xml_example/bib.xml new file mode 100644 index 000000000..d7ac83138 --- /dev/null +++ b/packages/xml/xml_example/bib.xml @@ -0,0 +1,36 @@ + + + TCP/IP Illustrated + StevensW. + Addison-Wesley + 65.95 + + + + Advanced Programming in the Unix environment + StevensW. + Addison-Wesley + 65.95 + + + + Data on the Web + AbiteboulSerge + BunemanPeter + SuciuDan + Morgan Kaufmann Publishers + 39.95 + + + + The Economics of Technology and Content for Digital TV + + GerbargDarcy + CITI + + Kluwer Academic Publishers + 129.95 + + + + diff --git a/packages/xml/xml_example/books.xml b/packages/xml/xml_example/books.xml new file mode 100644 index 000000000..ec7357c49 --- /dev/null +++ b/packages/xml/xml_example/books.xml @@ -0,0 +1,15 @@ + + Data Model +
+ Syntax For Data Model +
+
+ XML +
+ Basic Syntax +
+
+ XML and Semistructured Data +
+
+ diff --git a/packages/xml/xml_example/misc.pl b/packages/xml/xml_example/misc.pl new file mode 100644 index 000000000..fcba9a447 --- /dev/null +++ b/packages/xml/xml_example/misc.pl @@ -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 = [] + ). + diff --git a/packages/xml/xml_example/prices.xml b/packages/xml/xml_example/prices.xml new file mode 100644 index 000000000..d0a188ba6 --- /dev/null +++ b/packages/xml/xml_example/prices.xml @@ -0,0 +1,32 @@ + + + Advanced Programming in the Unix environment + www.amazon.com + 65.95 + + + Advanced Programming in the Unix environment + www.bn.com + 65.95 + + + TCP/IP Illustrated + www.amazon.com + 65.95 + + + TCP/IP Illustrated + www.bn.com + 65.95 + + + Data on the Web + www.amazon.com + 34.95 + + + Data on the Web + www.bn.com + 39.95 + + diff --git a/packages/xml/xml_example/q1.xml b/packages/xml/xml_example/q1.xml new file mode 100644 index 000000000..aaa259d27 --- /dev/null +++ b/packages/xml/xml_example/q1.xml @@ -0,0 +1,9 @@ + + + + TCP/IP Illustrated + + + Advanced Programming in the Unix environment + + diff --git a/packages/xml/xml_example/q10.xml b/packages/xml/xml_example/q10.xml new file mode 100644 index 000000000..dbf0c7f7e --- /dev/null +++ b/packages/xml/xml_example/q10.xml @@ -0,0 +1,11 @@ + + + 65.95 + + + 65.95 + + + 34.95 + + diff --git a/packages/xml/xml_example/q11.xml b/packages/xml/xml_example/q11.xml new file mode 100644 index 000000000..18b9eef89 --- /dev/null +++ b/packages/xml/xml_example/q11.xml @@ -0,0 +1,35 @@ + + + TCP/IP Illustrated + + Stevens + W. + + + + Advanced Programming in the Unix environment + + Stevens + W. + + + + Data on the Web + + Abiteboul + Serge + + + Buneman + Peter + + + Suciu + Dan + + + + The Economics of Technology and Content for Digital TV + CITI + + \ No newline at end of file diff --git a/packages/xml/xml_example/q12.xml b/packages/xml/xml_example/q12.xml new file mode 100644 index 000000000..305fb1dc5 --- /dev/null +++ b/packages/xml/xml_example/q12.xml @@ -0,0 +1,6 @@ + + + TCP/IP Illustrated + Advanced Programming in the Unix environment + + \ No newline at end of file diff --git a/packages/xml/xml_example/q2.xml b/packages/xml/xml_example/q2.xml new file mode 100644 index 000000000..29def3448 --- /dev/null +++ b/packages/xml/xml_example/q2.xml @@ -0,0 +1,37 @@ + + + TCP/IP Illustrated + + Stevens + W. + + + + Advanced Programming in the Unix environment + + Stevens + W. + + + + Data on the Web + + Abiteboul + Serge + + + + Data on the Web + + Buneman + Peter + + + + Data on the Web + + Suciu + Dan + + + \ No newline at end of file diff --git a/packages/xml/xml_example/q3.xml b/packages/xml/xml_example/q3.xml new file mode 100644 index 000000000..763b3044a --- /dev/null +++ b/packages/xml/xml_example/q3.xml @@ -0,0 +1,34 @@ + + + TCP/IP Illustrated + + Stevens + W. + + + + Advanced Programming in the Unix environment + + Stevens + W. + + + + Data on the Web + + Abiteboul + Serge + + + Buneman + Peter + + + Suciu + Dan + + + + The Economics of Technology and Content for Digital TV + + diff --git a/packages/xml/xml_example/q4.xml b/packages/xml/xml_example/q4.xml new file mode 100644 index 000000000..3adb19c9b --- /dev/null +++ b/packages/xml/xml_example/q4.xml @@ -0,0 +1,31 @@ + + + + Stevens + W. + + TCP/IP Illustrated + Advanced Programming in the Unix environment + + + + Abiteboul + Serge + + Data on the Web + + + + Buneman + Peter + + Data on the Web + + + + Suciu + Dan + + Data on the Web + + diff --git a/packages/xml/xml_example/q5.xml b/packages/xml/xml_example/q5.xml new file mode 100644 index 000000000..fb2850e76 --- /dev/null +++ b/packages/xml/xml_example/q5.xml @@ -0,0 +1,18 @@ + + + + TCP/IP Illustrated + 65.95 + 65.95 + + + Advanced Programming in the Unix environment + 65.95 + 65.95 + + + Data on the Web + 34.95 + 39.95 + + \ No newline at end of file diff --git a/packages/xml/xml_example/q6.xml b/packages/xml/xml_example/q6.xml new file mode 100644 index 000000000..47cab0d30 --- /dev/null +++ b/packages/xml/xml_example/q6.xml @@ -0,0 +1,28 @@ + + + TCP/IP Illustrated + + Stevens + W. + + + + Advanced Programming in the Unix environment + + Stevens + W. + + + + Data on the Web + + Abiteboul + Serge + + + Buneman + Peter + + + + diff --git a/packages/xml/xml_example/q7.xml b/packages/xml/xml_example/q7.xml new file mode 100644 index 000000000..17ae65f7b --- /dev/null +++ b/packages/xml/xml_example/q7.xml @@ -0,0 +1,9 @@ + + + + Advanced Programming in the Unix environment + + + TCP/IP Illustrated + + \ No newline at end of file diff --git a/packages/xml/xml_example/q8.xml b/packages/xml/xml_example/q8.xml new file mode 100644 index 000000000..2058cf56b --- /dev/null +++ b/packages/xml/xml_example/q8.xml @@ -0,0 +1,10 @@ + + + + Data on the Web + + Suciu + Dan + + + \ No newline at end of file diff --git a/packages/xml/xml_example/q9.xml b/packages/xml/xml_example/q9.xml new file mode 100644 index 000000000..f28899cd0 --- /dev/null +++ b/packages/xml/xml_example/q9.xml @@ -0,0 +1,5 @@ + + + XML + XML and Semistructured Data + \ No newline at end of file diff --git a/packages/xml/xml_example/reviews.xml b/packages/xml/xml_example/reviews.xml new file mode 100644 index 000000000..f4eaf9719 --- /dev/null +++ b/packages/xml/xml_example/reviews.xml @@ -0,0 +1,25 @@ + + + + Data on the Web + 34.95 + + A very good discussion of semi-structured database + systems and XML. + + + + Advanced Programming in the Unix environment + 65.95 + + A clear and detailed discussion of UNIX programming. + + + + TCP/IP Illustrated + 65.95 + + One of the best books on TCP/IP. + + + \ No newline at end of file diff --git a/packages/xml/xml_example/xml_example.pl b/packages/xml/xml_example/xml_example.pl new file mode 100644 index 000000000..31ac4b7dc --- /dev/null +++ b/packages/xml/xml_example/xml_example.pl @@ -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". + * + * + * QueryId is one of q1…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 ). + + \ No newline at end of file diff --git a/packages/xml/xml_generation.pl b/packages/xml/xml_generation.pl new file mode 100644 index 000000000..6211b2954 --- /dev/null +++ b/packages/xml/xml_generation.pl @@ -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 ) + }, + "", + 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 ) --> + "". +generation( instructions(Target,Process), _Prefix, Format, Indent, Format ) --> + indent( Format, Indent ), + "". +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 ), + "". +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 ) --> + "", + {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_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] ) --> " + ", + 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 &, " + * and < 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 ). + +indent( false, _Indent ) --> []. +indent( true, Indent ) --> + [10], + chars( Indent ). + +apos --> "'". + +escaped_quote --> """. + +/* pcdata_generation( +Chars ) is a DCG representing Chars, a list of character + * codes as legal XML "Parsed character data" (PCDATA) string. Any codes + * which cannot be represented by a 7-bit character are replaced by their + * decimal numeric character entity e.g. code 160 (non-breaking space) is + * represented as  . Any character codes disallowed by the XML + * specification are not encoded. + */ +pcdata_generation( [], Plus, Plus ). +pcdata_generation( [Char|Chars], Plus, Minus ) :- + ( Char =< 127 -> + pcdata_7bit( Char, Plus, Mid ) + ; legal_xml_unicode( Char ) -> + number_codes( Char, Codes ), + pcdata_8bits_plus( Codes, Plus, Mid ) + ; otherwise -> + Plus = Mid + ), + pcdata_generation( Chars, Mid, Minus ). + +/* pcdata_7bit(+Char) represents the ascii character set in its + * simplest format, using the character entities & < and >. + */ +pcdata_7bit( 0 ) --> "". +pcdata_7bit( 1 ) --> "". +pcdata_7bit( 2 ) --> "". +pcdata_7bit( 3 ) --> "". +pcdata_7bit( 4 ) --> "". +pcdata_7bit( 5 ) --> "". +pcdata_7bit( 6 ) --> "". +pcdata_7bit( 7 ) --> "". +pcdata_7bit( 8 ) --> "". +pcdata_7bit( 9 ) --> [9]. +pcdata_7bit( 10 ) --> [10]. +pcdata_7bit( 11 ) --> "". +pcdata_7bit( 12 ) --> "". +pcdata_7bit( 13 ) --> [13]. +pcdata_7bit( 14 ) --> "". +pcdata_7bit( 15 ) --> "". +pcdata_7bit( 16 ) --> "". +pcdata_7bit( 17 ) --> "". +pcdata_7bit( 18 ) --> "". +pcdata_7bit( 19 ) --> "". +pcdata_7bit( 20 ) --> "". +pcdata_7bit( 21 ) --> "". +pcdata_7bit( 22 ) --> "". +pcdata_7bit( 23 ) --> "". +pcdata_7bit( 24 ) --> "". +pcdata_7bit( 25 ) --> "". +pcdata_7bit( 26 ) --> "". +pcdata_7bit( 27 ) --> "". +pcdata_7bit( 28 ) --> "". +pcdata_7bit( 29 ) --> "". +pcdata_7bit( 30 ) --> "". +pcdata_7bit( 31 ) --> "". +pcdata_7bit( 32 ) --> " ". +pcdata_7bit( 33 ) --> "!". +pcdata_7bit( 34 ) --> [34]. +pcdata_7bit( 35 ) --> "#". +pcdata_7bit( 36 ) --> "$". +pcdata_7bit( 37 ) --> "%". +pcdata_7bit( 38 ) --> "&". +pcdata_7bit( 39 ) --> "'". +pcdata_7bit( 40 ) --> "(". +pcdata_7bit( 41 ) --> ")". +pcdata_7bit( 42 ) --> "*". +pcdata_7bit( 43 ) --> "+". +pcdata_7bit( 44 ) --> ",". +pcdata_7bit( 45 ) --> "-". +pcdata_7bit( 46 ) --> ".". +pcdata_7bit( 47 ) --> "/". +pcdata_7bit( 48 ) --> "0". +pcdata_7bit( 49 ) --> "1". +pcdata_7bit( 50 ) --> "2". +pcdata_7bit( 51 ) --> "3". +pcdata_7bit( 52 ) --> "4". +pcdata_7bit( 53 ) --> "5". +pcdata_7bit( 54 ) --> "6". +pcdata_7bit( 55 ) --> "7". +pcdata_7bit( 56 ) --> "8". +pcdata_7bit( 57 ) --> "9". +pcdata_7bit( 58 ) --> ":". +pcdata_7bit( 59 ) --> ";". +pcdata_7bit( 60 ) --> "<". +pcdata_7bit( 61 ) --> "=". +pcdata_7bit( 62 ) --> ">". % escaping necessary to prevent ']]>' sequences in pcdata. +pcdata_7bit( 63 ) --> "?". +pcdata_7bit( 64 ) --> "@". +pcdata_7bit( 65 ) --> "A". +pcdata_7bit( 66 ) --> "B". +pcdata_7bit( 67 ) --> "C". +pcdata_7bit( 68 ) --> "D". +pcdata_7bit( 69 ) --> "E". +pcdata_7bit( 70 ) --> "F". +pcdata_7bit( 71 ) --> "G". +pcdata_7bit( 72 ) --> "H". +pcdata_7bit( 73 ) --> "I". +pcdata_7bit( 74 ) --> "J". +pcdata_7bit( 75 ) --> "K". +pcdata_7bit( 76 ) --> "L". +pcdata_7bit( 77 ) --> "M". +pcdata_7bit( 78 ) --> "N". +pcdata_7bit( 79 ) --> "O". +pcdata_7bit( 80 ) --> "P". +pcdata_7bit( 81 ) --> "Q". +pcdata_7bit( 82 ) --> "R". +pcdata_7bit( 83 ) --> "S". +pcdata_7bit( 84 ) --> "T". +pcdata_7bit( 85 ) --> "U". +pcdata_7bit( 86 ) --> "V". +pcdata_7bit( 87 ) --> "W". +pcdata_7bit( 88 ) --> "X". +pcdata_7bit( 89 ) --> "Y". +pcdata_7bit( 90 ) --> "Z". +pcdata_7bit( 91 ) --> "[". +pcdata_7bit( 92 ) --> [92]. +pcdata_7bit( 93 ) --> "]". +pcdata_7bit( 94 ) --> "^". +pcdata_7bit( 95 ) --> "_". +pcdata_7bit( 96 ) --> "`". +pcdata_7bit( 97 ) --> "a". +pcdata_7bit( 98 ) --> "b". +pcdata_7bit( 99 ) --> "c". +pcdata_7bit( 100 ) --> "d". +pcdata_7bit( 101 ) --> "e". +pcdata_7bit( 102 ) --> "f". +pcdata_7bit( 103 ) --> "g". +pcdata_7bit( 104 ) --> "h". +pcdata_7bit( 105 ) --> "i". +pcdata_7bit( 106 ) --> "j". +pcdata_7bit( 107 ) --> "k". +pcdata_7bit( 108 ) --> "l". +pcdata_7bit( 109 ) --> "m". +pcdata_7bit( 110 ) --> "n". +pcdata_7bit( 111 ) --> "o". +pcdata_7bit( 112 ) --> "p". +pcdata_7bit( 113 ) --> "q". +pcdata_7bit( 114 ) --> "r". +pcdata_7bit( 115 ) --> "s". +pcdata_7bit( 116 ) --> "t". +pcdata_7bit( 117 ) --> "u". +pcdata_7bit( 118 ) --> "v". +pcdata_7bit( 119 ) --> "w". +pcdata_7bit( 120 ) --> "x". +pcdata_7bit( 121 ) --> "y". +pcdata_7bit( 122 ) --> "z". +pcdata_7bit( 123 ) --> "{". +pcdata_7bit( 124 ) --> "|". +pcdata_7bit( 125 ) --> "}". +pcdata_7bit( 126 ) --> [126]. +pcdata_7bit( 127 ) --> "". + +pcdata_8bits_plus( Codes ) --> + "&#", chars( Codes ), ";". + +/* character_data_format( +Chars, +Format0, ?Format1 ) holds when Format0 and + * Format1 are the statuses of XML formatting before and after Chars - + * which may be null. + */ +character_data_format( [], Format, Format ). +character_data_format( [_Char|_Chars], _Format, false ). + +/* cdata_generation( +Chars ) is a DCG representing Chars, a list of character + * codes as a legal XML CDATA string. Any character codes disallowed by the XML + * specification are not encoded. + */ +cdata_generation( [] ) --> "". +cdata_generation( [Char|Chars] ) --> + ( {legal_xml_unicode( Char )}, !, [Char] + ; "" + ), + cdata_generation( Chars ). + +legal_xml_unicode( 9 ). +legal_xml_unicode( 10 ). +legal_xml_unicode( 13 ). +legal_xml_unicode( Code ) :- + Code >= 32, + Code =< 55295. +legal_xml_unicode( Code ) :- + Code >= 57344, + Code =< 65533. +legal_xml_unicode( Code ) :- + Code >= 65536, + Code =< 1114111. diff --git a/packages/xml/xml_pp.pl b/packages/xml/xml_pp.pl new file mode 100644 index 000000000..974d270ba --- /dev/null +++ b/packages/xml/xml_pp.pl @@ -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( [] ). +pp_attributes( [Attribute|Attributes], Indent ) :- + pp_indent( Indent ), write( '[' ), + pp_attributes1( Attributes, Attribute ), + write( ']' ). + +pp_attributes1( [], Name=Value ) :- + pp_name( Name ), pp_string( Value ). +pp_attributes1( [H|T], Name=Value ) :- + pp_name( Name ), pp_string( Value ), pp_comma_sp, + pp_attributes1( T, H ). + + +pp_name( Name ) :- + ( possible_operator( Name ) -> + write( '(' ), write( Name ), write( ')=' ) + ; otherwise -> + writeq( Name ), write( '=' ) + ). + +possible_operator( (abolish) ). +possible_operator( (attribute) ). +possible_operator( (check_advice) ). +possible_operator( (compile_command) ). +possible_operator( (delay) ). +possible_operator( (demon) ). +possible_operator( (discontiguous) ). +possible_operator( (div) ). +possible_operator( (do) ). +possible_operator( (document_export) ). +possible_operator( (document_import) ). +possible_operator( (dy) ). +possible_operator( (dynamic) ). +possible_operator( (edb) ). +possible_operator( (eexport) ). +possible_operator( (else) ). +possible_operator( (except) ). +possible_operator( (export) ). +possible_operator( (foreign_pred) ). +possible_operator( (from) ). +possible_operator( (from_chars) ). +possible_operator( (from_file) ). +possible_operator( (from_stream) ). +possible_operator( (global) ). +possible_operator( (help) ). +possible_operator( (hilog) ). +possible_operator( (if) ). +possible_operator( (import) ). +possible_operator( (index) ). +possible_operator( (initialization) ). +possible_operator( (is) ). +possible_operator( (listing) ). +possible_operator( (local) ). +possible_operator( (locked) ). +possible_operator( (meta_predicate) ). +possible_operator( (mod) ). +possible_operator( (mode) ). +possible_operator( (module_transparent) ). +possible_operator( (multifile) ). +possible_operator( (namic) ). +possible_operator( (nocheck_advice) ). +possible_operator( (nospy) ). +possible_operator( (not) ). +possible_operator( (of) ). +possible_operator( (once) ). +possible_operator( (onto_chars) ). +possible_operator( (onto_file) ). +possible_operator( (onto_stream) ). +possible_operator( (parallel) ). +possible_operator( (public) ). +possible_operator( (r) ). +possible_operator( (rem) ). +possible_operator( (skipped) ). +possible_operator( (spy) ). +possible_operator( (table) ). +possible_operator( (then) ). +possible_operator( (thread_local) ). +possible_operator( (ti) ). +possible_operator( (ti_off) ). +possible_operator( (traceable) ). +possible_operator( (unskipped) ). +possible_operator( (untraceable) ). +possible_operator( (use_subsumptive_tabling) ). +possible_operator( (use_variant_tabling) ). +possible_operator( (volatile) ). +possible_operator( (with) ). +possible_operator( (with_input_from_chars) ). +possible_operator( (with_output_to_chars) ). +possible_operator( (xor) ). + +pp_indent( 0 ). +pp_indent( s(N) ) :- + write( ' ' ), + pp_indent( N ). + +pp_comma :- + write( ',' ). + +pp_comma_sp :- + write( ', ' ). diff --git a/packages/xml/xml_utilities.pl b/packages/xml/xml_utilities.pl new file mode 100644 index 000000000..a237e8141 --- /dev/null +++ b/packages/xml/xml_utilities.pl @@ -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, + "Egrave"-[200], % latin capital letter E with grave, + "Epsilon"-[917], % greek capital letter epsilon, U+0395 + "Eta"-[919], % greek capital letter eta, U+0397 + "Euml"-[203], % latin capital letter E with diaeresis, + "Gamma"-[915], % greek capital letter gamma, + "Iacute"-[205], % latin capital letter I with acute, + "Icirc"-[206], % latin capital letter I with circumflex, + "Igrave"-[204], % latin capital letter I with grave, + "Iota"-[921], % greek capital letter iota, U+0399 + "Iuml"-[207], % latin capital letter I with diaeresis, + "Kappa"-[922], % greek capital letter kappa, U+039A + "Lambda"-[923], % greek capital letter lambda, + "Mu"-[924], % greek capital letter mu, U+039C + "Ntilde"-[209], % latin capital letter N with tilde, + "Nu"-[925], % greek capital letter nu, U+039D + "OElig"-[338], % latin capital ligature OE, + "Oacute"-[211], % latin capital letter O with acute, + "Ocirc"-[212], % latin capital letter O with circumflex, + "Ograve"-[210], % latin capital letter O with grave, + "Omega"-[937], % greek capital letter omega, + "Omicron"-[927], % greek capital letter omicron, U+039F + "Oslash"-[216], % latin capital letter O with stroke + "Otilde"-[213], % latin capital letter O with tilde, + "Ouml"-[214], % latin capital letter O with diaeresis, + "Phi"-[934], % greek capital letter phi, + "Pi"-[928], % greek capital letter pi, U+03A0 ISOgrk3 + "Prime"-[8243], % double prime = seconds = inches, + "Psi"-[936], % greek capital letter psi, + "Rho"-[929], % greek capital letter rho, U+03A1 + "Scaron"-[352], % latin capital letter S with caron, + "Sigma"-[931], % greek capital letter sigma, + "THORN"-[222], % latin capital letter THORN, + "Tau"-[932], % greek capital letter tau, U+03A4 + "Theta"-[920], % greek capital letter theta, + "Uacute"-[218], % latin capital letter U with acute, + "Ucirc"-[219], % latin capital letter U with circumflex, + "Ugrave"-[217], % latin capital letter U with grave, + "Upsilon"-[933], % greek capital letter upsilon, + "Uuml"-[220], % latin capital letter U with diaeresis, + "Xi"-[926], % greek capital letter xi, U+039E ISOgrk3 + "Yacute"-[221], % latin capital letter Y with acute, + "Yuml"-[376], % latin capital letter Y with diaeresis, + "Zeta"-[918], % greek capital letter zeta, U+0396 + "aacute"-[225], % latin small letter a with acute, + "acirc"-[226], % latin small letter a with circumflex, + "acute"-[180], % acute accent = spacing acute, + "aelig"-[230], % latin small letter ae + "agrave"-[224], % latin small letter a with grave + "alefsym"-[8501], % alef symbol = first transfinite cardinal, + "alpha"-[945], % greek small letter alpha, + "and"-[8743], % logical and = wedge, U+2227 ISOtech + "ang"-[8736], % angle, U+2220 ISOamso + "aring"-[229], % latin small letter a with ring above + "asymp"-[8776], % almost equal to = asymptotic to, + "atilde"-[227], % latin small letter a with tilde, + "auml"-[228], % latin small letter a with diaeresis, + "bdquo"-[8222], % double low-9 quotation mark, U+201E NEW + "beta"-[946], % greek small letter beta, U+03B2 ISOgrk3 + "brvbar"-[166], % broken bar = broken vertical bar, + "bull"-[8226], % bullet = black small circle, + "cap"-[8745], % intersection = cap, U+2229 ISOtech + "ccedil"-[231], % latin small letter c with cedilla, + "cedil"-[184], % cedilla = spacing cedilla, U+00B8 ISOdia> + "cent"-[162], % cent sign, U+00A2 ISOnum> + "chi"-[967], % greek small letter chi, U+03C7 ISOgrk3 + "circ"-[710], % modifier letter circumflex accent, + "clubs"-[9827], % black club suit = shamrock, + "cong"-[8773], % approximately equal to, U+2245 ISOtech + "copy"-[169], % copyright sign, U+00A9 ISOnum> + "crarr"-[8629], % downwards arrow with corner leftwards + "cup"-[8746], % union = cup, U+222A ISOtech + "curren"-[164], % currency sign, U+00A4 ISOnum> + "dArr"-[8659], % downwards double arrow, U+21D3 ISOamsa + "dagger"-[8224], % dagger, U+2020 ISOpub + "darr"-[8595], % downwards arrow, U+2193 ISOnum + "deg"-[176], % degree sign, U+00B0 ISOnum> + "delta"-[948], % greek small letter delta, + "diams"-[9830], % black diamond suit, U+2666 ISOpub + "divide"-[247], % division sign, U+00F7 ISOnum> + "eacute"-[233], % latin small letter e with acute, + "ecirc"-[234], % latin small letter e with circumflex, + "egrave"-[232], % latin small letter e with grave, + "empty"-[8709], % empty set = null set = diameter, + "emsp"-[8195], % em space, U+2003 ISOpub + "ensp"-[8194], % en space, U+2002 ISOpub + "epsilon"-[949], % greek small letter epsilon, + "equiv"-[8801], % identical to, U+2261 ISOtech + "eta"-[951], % greek small letter eta, U+03B7 ISOgrk3 + "eth"-[240], % latin small letter eth, U+00F0 ISOlat1> + "euml"-[235], % latin small letter e with diaeresis, + "euro"-[8364], % euro sign, U+20AC NEW + "exist"-[8707], % there exists, U+2203 ISOtech + "fnof"-[402], % latin small f with hook = function + "forall"-[8704], % for all, U+2200 ISOtech + "frac12"-[189], % vulgar fraction one half + "frac14"-[188], % vulgar fraction one quarter + "frac34"-[190], % vulgar fraction three quarters + "frasl"-[8260], % fraction slash, U+2044 NEW + "gamma"-[947], % greek small letter gamma, + "ge"-[8805], % greater-than or equal to, + "hArr"-[8660], % left right double arrow, + "harr"-[8596], % left right arrow, U+2194 ISOamsa + "hearts"-[9829], % black heart suit = valentine, + "hellip"-[8230], % horizontal ellipsis = three dot leader, + "iacute"-[237], % latin small letter i with acute, + "icirc"-[238], % latin small letter i with circumflex, + "iexcl"-[161], % inverted exclamation mark, U+00A1 ISOnum> + "igrave"-[236], % latin small letter i with grave, + "image"-[8465], % blackletter capital I = imaginary part, + "infin"-[8734], % infinity, U+221E ISOtech + "int"-[8747], % integral, U+222B ISOtech + "iota"-[953], % greek small letter iota, U+03B9 ISOgrk3 + "iquest"-[191], % inverted question mark + "isin"-[8712], % element of, U+2208 ISOtech + "iuml"-[239], % latin small letter i with diaeresis, + "kappa"-[954], % greek small letter kappa, + "lArr"-[8656], % leftwards double arrow, U+21D0 ISOtech + "lambda"-[955], % greek small letter lambda, + "lang"-[9001], % left-pointing angle bracket = bra, + "laquo"-[171], % left-pointing double angle quotation mark + "larr"-[8592], % leftwards arrow, U+2190 ISOnum + "lceil"-[8968], % left ceiling = apl upstile, + "ldquo"-[8220], % left double quotation mark, + "le"-[8804], % less-than or equal to, U+2264 ISOtech + "lfloor"-[8970], % left floor = apl downstile, + "lowast"-[8727], % asterisk operator, U+2217 ISOtech + "loz"-[9674], % lozenge, U+25CA ISOpub + "lrm"-[8206], % left-to-right mark, U+200E NEW RFC 2070 + "lsaquo"-[8249], % single left-pointing angle quotation mark, + "lsquo"-[8216], % left single quotation mark, + "macr"-[175], % macron = spacing macron = overline + "mdash"-[8212], % em dash, U+2014 ISOpub + "micro"-[181], % micro sign, U+00B5 ISOnum> + "middot"-[183], % middle dot = Georgian comma + "minus"-[8722], % minus sign, U+2212 ISOtech + "mu"-[956], % greek small letter mu, U+03BC ISOgrk3 + "nabla"-[8711], % nabla = backward difference, + "nbsp"-[160], % no-break space = non-breaking space, + "ndash"-[8211], % en dash, U+2013 ISOpub + "ne"-[8800], % not equal to, U+2260 ISOtech + "ni"-[8715], % contains as member, U+220B ISOtech + "not"-[172], % not sign, U+00AC ISOnum> + "notin"-[8713], % not an element of, U+2209 ISOtech + "nsub"-[8836], % not a subset of, U+2284 ISOamsn + "ntilde"-[241], % latin small letter n with tilde, + "nu"-[957], % greek small letter nu, U+03BD ISOgrk3 + "oacute"-[243], % latin small letter o with acute, + "ocirc"-[244], % latin small letter o with circumflex, + "oelig"-[339], % latin small ligature oe, U+0153 ISOlat2 + "ograve"-[242], % latin small letter o with grave, + "oline"-[8254], % overline = spacing overscore, + "omega"-[969], % greek small letter omega, + "omicron"-[959], % greek small letter omicron, U+03BF NEW + "oplus"-[8853], % circled plus = direct sum, + "or"-[8744], % logical or = vee, U+2228 ISOtech + "ordf"-[170], % feminine ordinal indicator, U+00AA ISOnum> + "ordm"-[186], % masculine ordinal indicator, + "oslash"-[248], % latin small letter o with stroke, + "otilde"-[245], % latin small letter o with tilde, + "otimes"-[8855], % circled times = vector product, + "ouml"-[246], % latin small letter o with diaeresis, + "para"-[182], % pilcrow sign = paragraph sign, + "part"-[8706], % partial differential, U+2202 ISOtech + "permil"-[8240], % per mille sign, U+2030 ISOtech + "perp"-[8869], % up tack = orthogonal to = perpendicular, + "phi"-[966], % greek small letter phi, U+03C6 ISOgrk3 + "pi"-[960], % greek small letter pi, U+03C0 ISOgrk3 + "piv"-[982], % greek pi symbol, U+03D6 ISOgrk3 + "plusmn"-[177], % plus-minus sign = plus-or-minus sign, + "pound"-[163], % pound sign, U+00A3 ISOnum> + "prime"-[8242], % prime = minutes = feet, U+2032 ISOtech + "prod"-[8719], % n-ary product = product sign, + "prop"-[8733], % proportional to, U+221D ISOtech + "psi"-[968], % greek small letter psi, U+03C8 ISOgrk3 + "rArr"-[8658], % rightwards double arrow, + "radic"-[8730], % square root = radical sign, + "rang"-[9002], % right-pointing angle bracket = ket, + "raquo"-[187], % right-pointing double angle quotation mark + "rarr"-[8594], % rightwards arrow, U+2192 ISOnum + "rceil"-[8969], % right ceiling, U+2309 ISOamsc + "rdquo"-[8221], % right double quotation mark, + "real"-[8476], % blackletter capital R = real part symbol, + "reg"-[174], % registered sign = registered trade mark sign, + "rfloor"-[8971], % right floor, U+230B ISOamsc + "rho"-[961], % greek small letter rho, U+03C1 ISOgrk3 + "rlm"-[8207], % right-to-left mark, U+200F NEW RFC 2070 + "rsaquo"-[8250], % single right-pointing angle quotation mark, + "rsquo"-[8217], % right single quotation mark, + "sbquo"-[8218], % single low-9 quotation mark, U+201A NEW + "scaron"-[353], % latin small letter s with caron, + "sdot"-[8901], % dot operator, U+22C5 ISOamsb + "sect"-[167], % section sign, U+00A7 ISOnum> + "shy"-[173], % soft hyphen = discretionary hyphen, + "sigma"-[963], % greek small letter sigma, + "sigmaf"-[962], % greek small letter final sigma, + "sim"-[8764], % tilde operator = varies with = similar to, + "spades"-[9824], % black spade suit, U+2660 ISOpub + "sub"-[8834], % subset of, U+2282 ISOtech + "sube"-[8838], % subset of or equal to, U+2286 ISOtech + "sum"-[8721], % n-ary sumation, U+2211 ISOamsb + "sup"-[8835], % superset of, U+2283 ISOtech + "sup1"-[185], % superscript one = superscript digit one, + "sup2"-[178], % superscript two = superscript digit two + "sup3"-[179], % superscript three = superscript digit three + "supe"-[8839], % superset of or equal to, + "szlig"-[223], % latin small letter sharp s = ess-zed, + "tau"-[964], % greek small letter tau, U+03C4 ISOgrk3 + "there4"-[8756], % therefore, U+2234 ISOtech + "theta"-[952], % greek small letter theta, + "thetasym"-[977], % greek small letter theta symbol, + "thinsp"-[8201], % thin space, U+2009 ISOpub + "thorn"-[254], % latin small letter thorn with, + "tilde"-[732], % small tilde, U+02DC ISOdia + "times"-[215], % multiplication sign, U+00D7 ISOnum> + "trade"-[8482], % trade mark sign, U+2122 ISOnum + "uArr"-[8657], % upwards double arrow, U+21D1 ISOamsa + "uacute"-[250], % latin small letter u with acute, + "uarr"-[8593], % upwards arrow, U+2191 ISOnum + "ucirc"-[251], % latin small letter u with circumflex, + "ugrave"-[249], % latin small letter u with grave, + "uml"-[168], % diaeresis = spacing diaeresis, + "upsih"-[978], % greek upsilon with hook symbol, + "upsilon"-[965], % greek small letter upsilon, + "uuml"-[252], % latin small letter u with diaeresis, + "weierp"-[8472], % script capital P = power set + "xi"-[958], % greek small letter xi, U+03BE ISOgrk3 + "yacute"-[253], % latin small letter y with acute, + "yen"-[165], % yen sign = yuan sign, U+00A5 ISOnum> + "yuml"-[255], % latin small letter y with diaeresis, + "zeta"-[950], % greek small letter zeta, U+03B6 ISOgrk3 + "zwj"-[8205], % zero width joiner, U+200D NEW RFC 2070 + "zwnj"-[8204] % zero width non-joiner, + ] ). + +/* chars( ?Chars, ?Plus, ?Minus ) used as chars( ?Chars ) in a DCG to + * copy the list Chars inline. + * + * This is best expressed in terms of append/3 where append/3 is built-in. + * For other Prologs, a straightforward specification can be used: + * + * chars( [] ) --> "". + * chars( [Char|Chars] ) --> + * [Char], + * chars( Chars ). + */ + +chars( Chars, Plus, Minus ) :- + append( Chars, Minus, Plus ). + diff --git a/packages/zlib b/packages/zlib index 2a859fd75..5da6dfcfe 160000 --- a/packages/zlib +++ b/packages/zlib @@ -1 +1 @@ -Subproject commit 2a859fd75795cc428e911b59abf8404c87b530f4 +Subproject commit 5da6dfcfe79c21df05820a92dbfa07dcfdbcbc04 diff --git a/pl/boot.yap b/pl/boot.yap index 81d411ded..011d2bab0 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -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'. diff --git a/pl/consult.yap b/pl/consult.yap index 85f7b96bd..89b136f00 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -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)). + diff --git a/pl/dialect.yap b/pl/dialect.yap index aa02dcf40..bb1304c8a 100644 --- a/pl/dialect.yap +++ b/pl/dialect.yap @@ -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, diff --git a/pl/directives.yap b/pl/directives.yap index 4c4c8e235..74462f9df 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -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) :- diff --git a/pl/flags.yap b/pl/flags.yap index cac382d58..48a312bb3 100644 --- a/pl/flags.yap +++ b/pl/flags.yap @@ -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). diff --git a/pl/init.yap b/pl/init.yap index 34f6c7e5c..510962c06 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -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). diff --git a/pl/modules.yap b/pl/modules.yap index 7b03ba451..8fd637f7c 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -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)) :- diff --git a/pl/utils.yap b/pl/utils.yap index a6688898b..83306a5d3 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -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).