From 8dcee4415b20fdfb543dd4e8ed06d3b80304fa21 Mon Sep 17 00:00:00 2001 From: vsc Date: Mon, 21 May 2001 20:00:05 +0000 Subject: [PATCH] library(system) plus several new support builtins much improved garbage collector improvements to compiler yaptab compiles again git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@34 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/absmi.c | 38 +- C/alloc.c | 5 +- C/attvar.c | 3 + C/c_interface.c | 77 +- C/cdmgr.c | 9 + C/compiler.c | 23 +- C/dbase.c | 2 +- C/errors.c | 4 +- C/exec.c | 2 +- C/grow.c | 4 +- C/heapgc.c | 345 +++-- C/init.c | 2 +- C/iopreds.c | 359 ++++- C/mavar.c | 17 +- C/stdpreds.c | 2 +- C/sysbits.c | 45 +- C/tracer.c | 4 +- H/Regs.h | 9 +- H/yapio.h | 12 + Makefile.in | 3 + OPTYap/or.engine.c | 4 +- OPTYap/tab.suspend.c | 2 + TO_DO | 8 +- changes.css | 1 + changes4.3.html | 2889 ++++++++++++++++++----------------------- config.h.in | 18 +- configure | 125 +- configure.in | 9 +- docs/yap.tex | 5 +- include/c_interface.h | 48 + misc/yap.def | 6 +- pl/arith.yap | 5 + pl/boot.yap | 8 +- pl/errors.yap | 6 + pl/preds.yap | 1 + pl/tabling.yap | 2 +- pl/utils.yap | 27 +- pl/yio.yap | 2 + 38 files changed, 2211 insertions(+), 1920 deletions(-) create mode 100644 changes.css diff --git a/C/absmi.c b/C/absmi.c index d84b438ae..0adfd16f1 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -292,7 +292,7 @@ absmi(int inp) #endif /* USE_THREADED_CODE */ noheapleft: - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); saveregs(); #if PUSH_REGS restore_absmi_regs(old_regs); @@ -1604,7 +1604,7 @@ absmi(int inp) ASP = (CELL *)B; goto noheapleft; } - if (CFREG != MinStackGap*(stack_overflows+1)) + if (CFREG != CalculateStackGap()) goto creep; else goto NoStackExec; @@ -1752,12 +1752,12 @@ absmi(int inp) if (ReadTimedVar(WokenGoals) != TermNil) goto creepc; else { - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); JMPNext(); } } #endif - if (CFREG != MinStackGap*(stack_overflows+1)) + if (CFREG != CalculateStackGap()) goto creepc; ASP = (CELL *) (((char *) Y) + PREG->u.sla.s); if (ASP > (CELL *)B) @@ -1830,11 +1830,11 @@ absmi(int inp) if (ReadTimedVar(WokenGoals) != TermNil) goto creep_either; else { - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); JMPNext(); } } - if (CFREG != MinStackGap*(stack_overflows+1)) { + if (CFREG != CalculateStackGap()) { goto either_notest; } ASP = (CELL *) (((char *) Y) + PREG->u.sla.s); @@ -1916,12 +1916,12 @@ absmi(int inp) if (ReadTimedVar(WokenGoals) != TermNil) goto creepde; else { - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); JMPNext(); } } #endif - if (CFREG != MinStackGap*(stack_overflows+1)) + if (CFREG != CalculateStackGap()) goto creepde; NoStackExec: @@ -2041,10 +2041,10 @@ absmi(int inp) /* no more goals to wake up */ UpdateTimedVar(WokenGoals, TermNil); - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); } else { - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); /* We haven't changed P yet so this means redo the * same instruction */ JMPNext(); @@ -2101,7 +2101,7 @@ absmi(int inp) ARG1 = (Term) AbsPair(H); H += 2; - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); SREG = (CELL *) (Unsigned(CreepCode) - sizeof(SMALLUNSGN)); #ifdef COROUTINING @@ -5920,7 +5920,7 @@ absmi(int inp) { Prop p = GetPredProp (at, 1); if (p == NIL) { - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); FAIL(); } else { PredEntry *undefpe; @@ -5932,7 +5932,7 @@ absmi(int inp) } } PREG = (yamop *)pred_entry_from_code(UndefCode)->CodeOfPred; - CFREG = MinStackGap*(stack_overflows+1); + CFREG = CalculateStackGap(); CACHE_A1(); JMPNext(); ENDBOp(); @@ -10144,7 +10144,7 @@ absmi(int inp) if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) { /* make sure we have something to show for our trouble */ saveregs(); - gc(3, Y, NEXTOP(NEXTOP(PREG,xxx),sla)); + gc(0, Y, NEXTOP(NEXTOP(PREG,xxx),sla)); setregs(); goto restart_func2s; } @@ -10242,7 +10242,7 @@ absmi(int inp) if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) { /* make sure we have something to show for our trouble */ saveregs(); - gc(3, Y, NEXTOP(NEXTOP(PREG,xcx),sla)); + gc(0, Y, NEXTOP(NEXTOP(PREG,xcx),sla)); setregs(); goto restart_func2s_cv; } @@ -10339,7 +10339,7 @@ absmi(int inp) if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) { /* make sure we have something to show for our trouble */ saveregs(); - gc(3, Y, NEXTOP(NEXTOP(PREG,xxc),sla)); + gc(0, Y, NEXTOP(NEXTOP(PREG,xxc),sla)); setregs(); goto restart_func2s_vc; } @@ -10433,7 +10433,7 @@ absmi(int inp) if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) { /* make sure we have something to show for our trouble */ saveregs(); - gc(3, Y, NEXTOP(NEXTOP(PREG,yxx),sla)); + gc(0, Y, NEXTOP(NEXTOP(PREG,yxx),sla)); setregs(); goto restart_func2s_y; } @@ -10553,7 +10553,7 @@ absmi(int inp) if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) { /* make sure we have something to show for our trouble */ saveregs(); - gc(3, Y, NEXTOP(NEXTOP(PREG,ycx),sla)); + gc(0, Y, NEXTOP(NEXTOP(PREG,ycx),sla)); setregs(); goto restart_func2s_y_cv; } @@ -10682,7 +10682,7 @@ absmi(int inp) if (pt1+d1 > ENV || pt1+d1 > (CELL *)B) { /* make sure we have something to show for our trouble */ saveregs(); - gc(3, Y, NEXTOP(NEXTOP(PREG,yxc),sla)); + gc(0, Y, NEXTOP(NEXTOP(PREG,yxc),sla)); setregs(); goto restart_func2s_y_vc; } diff --git a/C/alloc.c b/C/alloc.c index 053fe3e3e..7f7309489 100644 --- a/C/alloc.c +++ b/C/alloc.c @@ -12,7 +12,7 @@ * Last rev: * * mods: * * comments: allocating space * -* version:$Id: alloc.c,v 1.6 2001-05-07 19:56:02 vsc Exp $ * +* version:$Id: alloc.c,v 1.7 2001-05-21 20:00:05 vsc Exp $ * *************************************************************************/ #ifdef SCCS static char SccsId[] = "%W% %G%"; @@ -537,6 +537,7 @@ ExtendWorkSpace(Int s) { #ifdef YAPOR abort_optyap("function ExtendWorkSpace called"); + return(FALSE); #else MALLOC_T a; @@ -614,9 +615,9 @@ ExtendWorkSpace(Int s) return FALSE; } -#endif /* YAPOR */ WorkSpaceTop = (char *) a + s; return TRUE; +#endif /* YAPOR */ } int diff --git a/C/attvar.c b/C/attvar.c index 2cb7b2346..6f7df3d41 100644 --- a/C/attvar.c +++ b/C/attvar.c @@ -199,6 +199,8 @@ CurrentTime(void) { static Int InitVarTime(void) { + return(0); +#ifdef BEFORE_TRAIL_COMPRESSION if (B->cp_tr == TR) { /* we run the risk of not making non-determinate bindings before the end of the night */ @@ -206,6 +208,7 @@ InitVarTime(void) { Bind((CELL *)(TR+1),AbsAppl(H-1)); } return((CELL *)(B->cp_tr)-(CELL *)TrailBase); +#endif } static Int diff --git a/C/c_interface.c b/C/c_interface.c index ee12d3395..8d5295c3b 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -81,6 +81,8 @@ X_API void *STD_PROTO(YapAllocSpaceFromYap,(unsigned int)); X_API void STD_PROTO(YapFreeSpaceFromYap,(void *)); X_API void STD_PROTO(YapFreeSpaceFromYap,(void *)); X_API int STD_PROTO(YapStringToBuffer, (Term, char *, unsigned int)); +X_API Term STD_PROTO(YapBufferToString, (char *)); +X_API Term STD_PROTO(YapBufferToAtomList, (char *)); X_API void STD_PROTO(YapError,(char *)); X_API int STD_PROTO(YapRunGoal,(Term)); X_API int STD_PROTO(YapRestartGoal,(void)); @@ -96,6 +98,8 @@ X_API int STD_PROTO(YapReset, (void)); X_API void STD_PROTO(YapExit, (int)); X_API void STD_PROTO(YapInitSocks, (char *, long)); X_API void STD_PROTO(YapSetOutputMessage, (void)); +X_API int STD_PROTO(YapStreamToFileNo, (Term)); +X_API int STD_PROTO(YapPopen, (Term)); X_API Term YapA(int i) @@ -359,12 +363,14 @@ YapUnify(Term pt1, Term pt2) return(out); } -Int YapExecute(CPredicate code) +Int +YapExecute(CPredicate code) { return((code)()); } -X_API Int YapCallProlog(Term t) +X_API Int +YapCallProlog(Term t) { Int out; BACKUP_MACHINE_REGS(); @@ -375,7 +381,8 @@ X_API Int YapCallProlog(Term t) return(out); } -X_API void *YapAllocSpaceFromYap(unsigned int size) +X_API void * +YapAllocSpaceFromYap(unsigned int size) { void *ptr; BACKUP_MACHINE_REGS(); @@ -391,13 +398,15 @@ X_API void *YapAllocSpaceFromYap(unsigned int size) return(ptr); } -X_API void YapFreeSpaceFromYap(void *ptr) +X_API void +YapFreeSpaceFromYap(void *ptr) { FreeCodeSpace(ptr); } /* copy a string to a buffer */ -X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize) +X_API int +YapStringToBuffer(Term t, char *buf, unsigned int bufsize) { unsigned int j = 0; @@ -419,7 +428,10 @@ X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize) return(FALSE); } buf[j++] = i; - if (j > bufsize) return(FALSE); + if (j > bufsize) { + buf[j-1] = '\0'; + return(FALSE); + } t = TailOfTerm(t); if (IsVarTerm(t)) { Error(INSTANTIATION_ERROR,t,"user defined procedure"); @@ -434,6 +446,33 @@ X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize) } +/* copy a string to a buffer */ +X_API Term +YapBufferToString(char *s) +{ + Term t; + BACKUP_H(); + + t = StringToList(s); + + RECOVER_H(); + return(t); +} + +/* copy a string to a buffer */ +X_API Term +YapBufferToAtomList(char *s) +{ + Term t; + BACKUP_H(); + + t = StringToListOfAtoms(s); + + RECOVER_H(); + return(t); +} + + X_API void YapError(char *buf) { @@ -742,3 +781,29 @@ YapSetOutputMessage(void) #endif } +X_API int +YapStreamToFileNo(Term t) +{ + return(StreamToFileNo(t)); +} + +X_API void +YapCloseAllOpenStreams(void) +{ + BACKUP_H(); + + return(CloseStreams(FALSE)); + + RECOVER_H(); +} + +X_API Term +YapOpenStream(void *fh, char *name, Term nm, int flags) +{ + BACKUP_H(); + + return(OpenStream((FILE *)fh, name, nm, flags)); + + RECOVER_H(); +} + diff --git a/C/cdmgr.c b/C/cdmgr.c index 72bcaface..c6962fd11 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -2032,6 +2032,7 @@ Int PredForCode(CODEADDR codeptr, Atom *pat, Int *parity, SMALLUNSGN *pmodule) { Int i_table; Int val; + AtomEntry *chain; for (i_table = 0; i_table < MaxHash; i_table++) { Atom a; @@ -2048,6 +2049,14 @@ PredForCode(CODEADDR codeptr, Atom *pat, Int *parity, SMALLUNSGN *pmodule) { } READ_UNLOCK(HashChain[i_table].AERWLock); } + chain = RepAtom(INVISIBLECHAIN.Entry); + while (!EndOfPAEntr(chain) != 0) { + if ((val = check_code_in_atom(chain, codeptr, parity, pmodule)) != 0) { + *pat = AbsAtom(chain); + return(val); + } + chain = RepAtom(chain->NextOfAE); + } /* we didn't find it, must be one of the hidden predicates */ return(0); } diff --git a/C/compiler.c b/C/compiler.c index de8ba0663..2fba1b33e 100644 --- a/C/compiler.c +++ b/C/compiler.c @@ -329,7 +329,7 @@ optimize_ce(Term t, unsigned int arity) CExpEntry *p = common_exps, *parent = common_exps; int cmp = 0; - if (onbranch || (IsApplTerm(t) && IsExtensionFunctor(FunctorOfTerm(t)))) + if (IsApplTerm(t) && IsExtensionFunctor(FunctorOfTerm(t))) return (t); while (p != NULL) { CELL *OldH = H; @@ -1041,7 +1041,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3) save_machine_regs(); longjmp(CompilerBotch,1); } - } else if (IsNewVar(t3) && cur_branch == 0) { + } else if (IsNewVar(t3) /* && cur_branch == 0 */) { c_var(t3,f_flag,(unsigned int)Op); if (Op == _functor) { emit(empty_call_op, Zero, Zero); @@ -2108,9 +2108,9 @@ CheckUnsafe(PInstr *pc) add_bvarray_op(pc, vstat, pc->rnd2); break; case call_op: - emit(label_op, ++labelno, Zero); - pc->ops.opseqt[1] = (CELL)labelno; - add_bvarray_op(pc, vstat, pc->rnd2); + emit(label_op, ++labelno, Zero); + pc->ops.opseqt[1] = (CELL)labelno; + add_bvarray_op(pc, vstat, pc->rnd2); case deallocate_op: { int n = pc->op == call_op ? pc->rnd2 : 0; @@ -2144,6 +2144,7 @@ CheckVoids(void) cpc = CodeStart; while ((ic = cpc->op) != allocate_op) { + ic = cpc->op; #ifdef M_WILLIAMS switch ((int) ic) { #else @@ -2160,14 +2161,12 @@ CheckVoids(void) ve = ((Ventry *) cpc->rnd1); if ((ve->FlagsOfVE & PermFlag) == 0 && ve->RCountOfVE <= 1) { ve->NoOfVE = ve->KindOfVE = VoidVar; -#ifndef SFUNC if (ic == get_var_op || ic == - save_pair_op || ic == save_appl_op) { -#else - if (ic == get_var_op || ic == - save_appl_op || ic == save_pair_op - || ic == unify_s_var_op) { + save_pair_op || ic == save_appl_op +#ifdef SFUNC + || ic == unify_s_var_op #endif + ) { cpc->op = nop_op; break; } @@ -2202,6 +2201,8 @@ checktemp(void) vreg = vadr & MaskVarAdrs; if (v->KindOfVE == PermVar || v->KindOfVE == VoidVar) return (0); + if (v->RCountOfVE == 1) + return(0); if (vreg) { --Uses[vreg]; return (1); diff --git a/C/dbase.c b/C/dbase.c index b273d345d..7fff7fdcd 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -1939,7 +1939,7 @@ GetDBTerm(DBRef DBSP) pt = CellPtr(DBSP->Contents); NOf = DBSP->NOfCells; - if (H+NOf > ASP - MinStackGap*(stack_overflows+1)) { + if (H+NOf > ASP-CalculateStackGap()) { return((Term)0); } HeapPtr = cpcells(HOld, pt, NOf); diff --git a/C/errors.c b/C/errors.c index 1b648f373..94cfa4b66 100644 --- a/C/errors.c +++ b/C/errors.c @@ -255,7 +255,7 @@ Abort (char *format,...) } else { - CreepFlag = MinStackGap*(stack_overflows+1); + CreepFlag = CalculateStackGap(); #if PUSH_REGS restore_absmi_regs(&standard_regs); #endif @@ -1801,7 +1801,7 @@ Error (yap_error_number type, Term where, char *format,...) if (serious) { Int depth; - CreepFlag = MinStackGap*(stack_overflows+1); + CreepFlag = CalculateStackGap(); if (type == PURE_ABORT) depth = SetDBForThrow(MkAtomTerm(LookupAtom("abort"))); else diff --git a/C/exec.c b/C/exec.c index f386ec599..5cec63651 100644 --- a/C/exec.c +++ b/C/exec.c @@ -845,7 +845,7 @@ exec_absmi(int top) B = (choiceptr)(LCL0-depth); #endif yap_flags[SPY_CREEP_FLAG] = 0; - CreepFlag = MinStackGap*(stack_overflows+1); + CreepFlag = CalculateStackGap(); #if defined(__GNUC__) && defined(hppa) /* siglongjmp resets the TR hardware register */ restore_TR(); diff --git a/C/grow.c b/C/grow.c index 204a8bed1..321cd0ada 100644 --- a/C/grow.c +++ b/C/grow.c @@ -695,7 +695,7 @@ growstack(long size) fix_tabling_info(); #endif YAPLeaveCriticalSection(); - CreepFlag = MinStackGap*(stack_overflows+1); + CreepFlag = CalculateStackGap(); ASP += 256; growth_time = cputime()-start_growth_time; total_stack_overflow_time += growth_time; @@ -815,7 +815,7 @@ growstack_in_parser(tr_fr_ptr *old_trp, TokEntry **tksp, VarEntry **vep) } AdjustRegs(MaxTemps); YAPLeaveCriticalSection(); - CreepFlag = MinStackGap*(stack_overflows+1); + CreepFlag = CalculateStackGap(); ASP += 256; growth_time = cputime()-start_growth_time; total_stack_overflow_time += growth_time; diff --git a/C/heapgc.c b/C/heapgc.c index 124ae7860..08ebe848d 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -21,10 +21,12 @@ static char SccsId[] = "%W% %G%"; #include "absmi.h" #include "yapio.h" +#define DEBUG 1 #define EARLY_RESET 1 #define EASY_SHUNTING 1 -#define HYBRID_SCHEME 1 +//#define HYBRID_SCHEME 1 + #ifdef MULTI_ASSIGNMENT_VARIABLES /* @@ -153,6 +155,8 @@ static choiceptr current_B; static tr_fr_ptr sTR; #endif +static tr_fr_ptr new_TR; + STATIC_PROTO(void push_registers, (Int, yamop *)); STATIC_PROTO(void marking_phase, (tr_fr_ptr, CELL *, yamop *, CELL *)); STATIC_PROTO(void compaction_phase, (tr_fr_ptr, CELL *, yamop *, CELL *)); @@ -655,7 +659,7 @@ init_dbtable(tr_fr_ptr trail_ptr) { #ifdef DEBUG -/*#define INSTRUMENT_GC 1*/ +#define INSTRUMENT_GC 1 /*#define CHECK_CHOICEPOINTS 1*/ #ifdef INSTRUMENT_GC @@ -780,16 +784,25 @@ check_global(void) { #if INSTRUMENT_GC if (IsVarTerm(ccurr)) { if (IsBlobFunctor((Functor)ccurr)) vars[gc_num]++; - else if (ccurr != 0 && ccurr < (CELL)HeapTop) vars[gc_func]++; + else if (ccurr != 0 && ccurr < (CELL)HeapTop) { + /* printf("%p: %s/%d\n", current, + RepAtom(NameOfFunctor((Functor)ccurr))->StrOfAE, + ArityOfFunctor((Functor)ccurr));*/ + vars[gc_func]++; + } else if (IsUnboundVar((CELL)current)) vars[gc_var]++; else vars[gc_ref]++; } else if (IsApplTerm(ccurr)) { + // printf("%p: f->%p\n",current,RepAppl(ccurr)); vars[gc_appl]++; } else if (IsPairTerm(ccurr)) { + // printf("%p: l->%p\n",current,RepPair(ccurr)); vars[gc_list]++; } else if (IsAtomTerm(ccurr)) { + // printf("%p: %s\n",current,RepAtom(AtomOfTerm(ccurr))->StrOfAE); vars[gc_atom]++; } else if (IsIntTerm(ccurr)) { + // printf("%p: %d\n",current,IntOfTerm(ccurr)); vars[gc_int]++; } #endif @@ -1202,12 +1215,18 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B mark_external_reference(&TrailTerm(trail_ptr)); UNMARK(&TrailTerm(trail_ptr)); #endif /* EARLY_RESET */ - } else { - if (hp < (CELL *)HeapTop) { + } else if (hp < (CELL *)HeapTop) { /* I decided to allow pointers from the Heap back into the trail. The point of doing so is to have dynamic arrays */ - mark_external_reference(hp); - } + mark_external_reference(hp); + } else if ((hp < (CELL *)gc_B && hp >= gc_H) || hp > (CELL *)TrailBase) { + /* clean the trail, avoid dangling pointers! */ + RESET_VARIABLE(&TrailTerm(trail_ptr)); +#ifdef FROZEN_REGS + RESET_VARIABLE(&TrailVal(trail_ptr)); +#endif + discard_trail_entries++; + } else { #ifdef EASY_SHUNTING if (hp < gc_H && hp >= H0) { CELL *cptr = (CELL *)trail_cell; @@ -1300,9 +1319,16 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B #if MULTI_ASSIGNMENT_VARIABLES while (live_list != NULL) { CELL trail_cell = TrailTerm(live_list->trptr-1); + CELL trail_cell2 = TrailTerm(live_list->trptr); if (HEAP_PTR(trail_cell)) { mark_external_reference(&TrailTerm(live_list->trptr-1)); } + /* + swap the two so that the sweep_trail() knows we have + a multi-assignment binding + */ + TrailTerm(live_list->trptr) = TrailTerm(live_list->trptr-1); + TrailTerm(live_list->trptr-1) = trail_cell2; live_list = live_list->ma_list; } #endif @@ -1325,10 +1351,6 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B #endif /* TABLING_SCHEDULING */ #endif -#ifdef DEBUG -//#define CHECK_CHOICEPOINTS 1 -#endif - #ifdef CHECK_CHOICEPOINTS #ifndef ANALYST @@ -1379,7 +1401,15 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR) case _retry_userc: case _trust_logical_pred: case _retry_profiled: - printf("B %p (%s) with %d\n", gc_B, op_names[opnum], total_marked); + { + Atom at; + UInt arity; + SMALLUNSGN mod; + if (PredForCode((CODEADDR)gc_B->cp_ap, &at, &arity, &mod)) + printf("B %p (%s) at %s/%d with %d,%d\nf", gc_B, op_names[opnum], RepAtom(at)->StrOfAE, arity, gc_B->cp_h-H0, total_marked); + else + printf("B %p (%s) with %d,%d\n", gc_B, op_names[opnum], gc_B->cp_h-H0, total_marked); + } break; #ifdef TABLING case _table_completion: @@ -1389,11 +1419,11 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR) op_numbers caller_op = op_from_opcode(ENV_ToOp(gc_B->cp_cp)); /* first condition checks if this was a meta-call */ if ((caller_op != _call && caller_op != _fcall) || pe == NULL) { - printf("B %p (%s) with %d\n", gc_B, op_names[opnum], total_marked); + printf("B %p (%s) with %d,%d\n", gc_B, op_names[opnum], gc_B->cp_h-H0, total_marked); } else if (pe->ArityOfPE) - printf("B %p (%s for %s/%d) with %d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked); + printf("B %p (%s for %s/%d) with %d,%d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, gc_B->cp_h-H0, total_marked); else - printf("B %p (%s for %s/0) with %d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked); + printf("B %p (%s for %s/0) with %d,%d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, gc_B->cp_h-H0, total_marked); } break; #endif @@ -1403,14 +1433,21 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR) if (pe == NULL) { printf("B %p (%s) with %d\n", gc_B, op_names[opnum], total_marked); } else if (pe->ArityOfPE) - printf("B %p (%s for %s/%d) with %d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked); + printf("B %p (%s for %s/%d) with %d,%d\n", gc_B, op_names[opnum], RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, gc_B->cp_h-H0, total_marked); else - printf("B %p (%s for %s/0) with %d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked); + printf("B %p (%s for %s/0) with %d,%d\n", gc_B, op_names[opnum], RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, gc_B->cp_h-H0, total_marked); } } #endif /* CHECK_CHOICEPOINTS */ - mark_trail(saved_TR, gc_B->cp_tr, gc_B->cp_h, gc_B); - saved_TR = gc_B->cp_tr; + { + /* find out how many cells are still alive in the trail */ + UInt d0 = discard_trail_entries, diff, orig; + orig = saved_TR-gc_B->cp_tr; + mark_trail(saved_TR, gc_B->cp_tr, gc_B->cp_h, gc_B); + saved_TR = gc_B->cp_tr; + diff = discard_trail_entries-d0; + gc_B->cp_tr = (tr_fr_ptr)(orig-diff); + } restart_cp: if (opnum == _or_else || opnum == _or_last) { /* ; choice point */ @@ -1640,15 +1677,26 @@ into_relocation_chain(CELL_PTR current, CELL_PTR next) static void sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR) { - tr_fr_ptr trail_ptr; - CELL *cp_H = gc_B->cp_h; + tr_fr_ptr trail_ptr, dest, tri = (tr_fr_ptr)db_vec; Int OldHeapUsed = HeapUsed; #ifdef DEBUG Int hp_entrs = 0, hp_erased = 0, hp_not_in_use = 0, hp_in_use_erased = 0, code_entries = 0; #endif +#if MULTI_ASSIGNMENT_VARIABLES + tr_fr_ptr next_timestamp = NULL; +#endif - + /* adjust cp_tr pointers */ + { + Int size = old_TR-(tr_fr_ptr)TrailBase; + size -= discard_trail_entries; + while (gc_B != NULL) { + size -= (UInt)(gc_B->cp_tr); + gc_B->cp_tr = (tr_fr_ptr)TrailBase+size; + gc_B = gc_B->cp_b; + } + } #if DB_SEARCH_METHOD #if DEBUG { @@ -1671,129 +1719,173 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR) } /* next, follows the real trail entries */ - trail_ptr = old_TR; - while (trail_ptr > (tr_fr_ptr)TrailBase) { + trail_ptr = (tr_fr_ptr)TrailBase; + dest = trail_ptr; + while (trail_ptr < old_TR) { register CELL trail_cell; - trail_ptr--; - trail_cell = TrailTerm(trail_ptr); - if (gc_B && trail_ptr < gc_B->cp_tr) { - do { - gc_B = gc_B->cp_b; - } while (gc_B && trail_ptr < gc_B->cp_tr); - cp_H = gc_B->cp_h; - } - - if (IsVarTerm(trail_cell)) { - /* we need to check whether this is a honest to god trail entry */ - if ((CELL *)trail_cell < cp_H && MARKED(*(CELL *)trail_cell) && (CELL *)trail_cell >= H0) { - if (HEAP_PTR(trail_cell)) { - into_relocation_chain(&TrailTerm(trail_ptr), GET_NEXT(trail_cell)); - } - } else if ((CELL *)trail_cell < (CELL *)HeapTop) { - /* we may have pointers from the heap back into the cell */ - UNMARK(CellPtr(trail_cell)); - if (HEAP_PTR(trail_cell)) { - into_relocation_chain(CellPtr(trail_cell), GET_NEXT(*(CELL *)trail_cell)); - } - } else { - /* clean the trail, avoid dangling pointers! */ - if ((CELL *)trail_cell < (CELL *)gc_B && (CELL *)trail_cell >= H0) { - RESET_VARIABLE(&TrailTerm(trail_ptr)); + if (trail_cell == (CELL)trail_ptr) { + trail_ptr++; + /* just skip cell */ + } else { + TrailTerm(dest) = trail_cell; #ifdef FROZEN_REGS - RESET_VARIABLE(&TrailVal(trail_ptr)); + TrailVal(dest) = TrailVal(trail_ptr); #endif - discard_trail_entries++; + if (IsVarTerm(trail_cell)) { + /* we need to check whether this is a honest to god trail entry */ + if ((CELL *)trail_cell < H && MARKED(*(CELL *)trail_cell) && (CELL *)trail_cell >= H0) { + if (HEAP_PTR(trail_cell)) { + into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell)); + } + } else if ((CELL *)trail_cell < (CELL *)HeapTop) { + /* we may have pointers from the heap back into the cell */ + UNMARK(CellPtr(trail_cell)); + if (HEAP_PTR(trail_cell)) { + into_relocation_chain(CellPtr(trail_cell), GET_NEXT(*(CELL *)trail_cell)); + } } - } #ifdef FROZEN_REGS - if (MARKED(TrailVal(trail_ptr))) { - UNMARK(&TrailVal(trail_ptr)); - if (HEAP_PTR(TrailVal(trail_ptr))) { - into_relocation_chain(&TrailVal(trail_ptr), GET_NEXT(TrailVal(trail_ptr))); + if (MARKED(TrailVal(dest))) { + UNMARK(&TrailVal(dest)); + if (HEAP_PTR(TrailVal(dest))) { + into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailVal(dest))); + } } - } #endif - } else if (IsPairTerm(trail_cell)) { - CELL *pt0 = RepPair(trail_cell); - CELL flags; + } else if (IsPairTerm(trail_cell)) { + CELL *pt0 = RepPair(trail_cell); + CELL flags; #ifdef FROZEN_REGS /* TRAIL */ - /* process all segments */ - if ( + /* process all segments */ + if ( #ifdef SBA - (ADDR) pt0 >= HeapTop + (ADDR) pt0 >= HeapTop #else - (ADDR) pt0 >= TrailBase + (ADDR) pt0 >= TrailBase #endif - ) { - continue; - } + ) { + continue; + } #endif /* FROZEN_REGS */ - flags = Flags((CELL)pt0); + flags = Flags((CELL)pt0); #ifdef DEBUG - if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) { - hp_entrs++; - if (!FlagOn(GcFoundMask, flags)) { - hp_not_in_use++; - if (FlagOn(ErasedMask, flags)) { - hp_erased++; + if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) { + hp_entrs++; + if (!FlagOn(GcFoundMask, flags)) { + hp_not_in_use++; + if (FlagOn(ErasedMask, flags)) { + hp_erased++; + } + } else { + if (FlagOn(ErasedMask, flags)) { + hp_in_use_erased++; + } } } else { - if (FlagOn(ErasedMask, flags)) { - hp_in_use_erased++; - } + code_entries++; } - } else { - code_entries++; - } #endif - if (!FlagOn(GcFoundMask, flags)) { - if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) { - Flags((CELL)pt0) = ResetFlag(InUseMask, flags); - if (FlagOn(ErasedMask, flags)) { - ErDBE((DBRef) ((CELL)pt0 - (CELL) &(((DBRef) NIL)->Flags))); + if (!FlagOn(GcFoundMask, flags)) { + if (FlagOn(DBClMask, flags) && !FlagOn(LogUpdMask, flags)) { + Flags((CELL)pt0) = ResetFlag(InUseMask, flags); + if (FlagOn(ErasedMask, flags)) { + ErDBE((DBRef) ((CELL)pt0 - (CELL) &(((DBRef) NIL)->Flags))); + } + RESET_VARIABLE(&TrailTerm(dest)); + discard_trail_entries++; } - RESET_VARIABLE(trail_ptr); - discard_trail_entries++; + } else { + Flags((CELL)pt0) = ResetFlag(GcFoundMask, flags); } - } else { - Flags((CELL)pt0) = ResetFlag(GcFoundMask, flags); - } #if MULTI_ASSIGNMENT_VARIABLES - } else { - CELL *old_value_ptr = (CELL *)trail_ptr; + } else { + CELL trail_cell = TrailTerm(trail_ptr); + CELL *ptr; + CELL old = TrailTerm(trail_ptr+1); - if (MARKED(trail_cell)) { - UNMARK(&TrailTerm(trail_ptr)); - if (HEAP_PTR(TrailTerm(trail_ptr))) { - into_relocation_chain(&TrailTerm(trail_ptr), GET_NEXT(trail_cell)); + if (MARKED(trail_cell)) + ptr = RepAppl(UNMARK_CELL(trail_cell)); + else + ptr = RepAppl(trail_cell); + + /* now, we must check whether we are looking at a time-stamp */ + if (next_timestamp == trail_ptr) { + /* we have a time stamp. Problem is: the trail shifted and we can not trust the + current time stamps */ + CELL old_cell = *ptr; + int was_marked = MARKED(old_cell); + tr_fr_ptr old_timestamp; + + if (was_marked) + old_cell = UNMARK_CELL(old_cell); + old_timestamp = (tr_fr_ptr)TrailBase+IntegerOfTerm(old_cell); + + if (old_timestamp >= trail_ptr) { + /* first time, we found the current timestamp */ + old = MkIntTerm(0); + } else { + /* set time stamp to current */ + old = old_cell; + } + *ptr = MkIntegerTerm(dest-(tr_fr_ptr)TrailBase); + if (was_marked) + MARK(ptr); + } else if (ptr < H0 || UNMARK_CELL(ptr[-1]) == (CELL)FunctorMutable) { + /* yes, we do have a time stamp */ + next_timestamp = trail_ptr+2; } - } - trail_cell = old_value_ptr[-1]; + + TrailTerm(dest) = old; + TrailTerm(dest+1) = trail_cell; + if (MARKED(old)) { + UNMARK(&TrailTerm(dest)); + if (HEAP_PTR(old)) { + into_relocation_chain(&TrailTerm(dest), GET_NEXT(old)); + } + } + dest++; + if (MARKED(trail_cell)) { + UNMARK(&TrailTerm(dest)); + if (HEAP_PTR(trail_cell)) { + if (next_timestamp == trail_ptr) { + /* wait until we're over to insert in relocation chain */ + TrailTerm(tri) = (CELL)dest; + tri++; + } else { + into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell)); + } + } + } + trail_ptr++; #ifdef FROZEN_REGS - if (MARKED(TrailVal(trail_ptr))) { - UNMARK(&TrailVal(trail_ptr)); - if (HEAP_PTR(TrailVal(trail_ptr))) { - into_relocation_chain(&TrailVal(trail_ptr), GET_NEXT(TrailTerm(trail_ptr))); + TrailVal(dest) = TrailVal(trail_ptr); + if (MARKED(TrailVal(dest))) { + UNMARK(&TrailVal(dest)); + if (HEAP_PTR(TrailVal(dest))) { + into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailTerm(dest))); + } } - } #endif - old_value_ptr--; - if (MARKED(trail_cell)) { - UNMARK(old_value_ptr); - if (HEAP_PTR(trail_cell)) { - into_relocation_chain(old_value_ptr, GET_NEXT(trail_cell)); - } - } - trail_ptr = (tr_fr_ptr)old_value_ptr; #endif + } + trail_ptr++; + dest++; } } + while (tri > (tr_fr_ptr)db_vec) { + tr_fr_ptr x = (tr_fr_ptr)TrailTerm(--tri); + CELL trail_cell = TrailTerm(x); + if (HEAP_PTR(trail_cell)) { + into_relocation_chain(&TrailTerm(x), GET_NEXT(trail_cell)); + } + } + new_TR = dest; if (is_gc_verbose()) { YP_fprintf(YP_stderr, "[GC] Trail: discarded %d (%ld%%) cells out of %ld\n", @@ -2502,7 +2594,7 @@ icompact_heap(void) #ifdef EASY_SHUNTING static void -set_conditionals(CELL *TRo) { +set_conditionals(tr_fr_ptr TRo) { while (sTR != TRo) { CELL *cptr = (CELL *)TrailTerm(sTR-1); *cptr = TrailTerm(sTR-2); @@ -2580,10 +2672,10 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max) if (total_marked != iptop-(CELL_PTR *)H && iptop < (CELL_PTR *)ASP -1024) YP_fprintf(YP_stderr,"[GC] Oops on iptop-H (%d) vs %d\n", iptop-(CELL_PTR *)H, total_marked); #endif - if (iptop < (CELL_PTR *)ASP-1024 && 10*total_marked < H-H0) { + if (iptop < (CELL_PTR *)ASP /* && 10*total_marked < H-H0 */) { int effectiveness = (((H-H0)-total_marked)*100)/(H-H0); #ifdef DEBUG - fprintf(stderr,"using pointers (%d)\n", effectiveness); + YP_fprintf(YP_stderr,"[GC] using pointers (%d)\n", effectiveness); #endif quicksort((CELL_PTR *)H, 0, (iptop-(CELL_PTR *)H)-1); adjust_cp_hbs(); @@ -2591,9 +2683,11 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max) } else #endif /* HYBRID_SCHEME */ { -#ifdef DEBUG_IN +#ifdef DEBUG +#ifdef HYBID_SCHEME int effectiveness = (((H-H0)-total_marked)*100)/(H-H0); - fprintf(stderr,"not using pointers (%d)\n", effectiveness); + fprintf(stderr,"[GC] not using pointers (%d) ASP: %p, ip %p (expected %p) \n", effectiveness, ASP, iptop, H+total_marked); +#endif #endif compact_heap(); } @@ -2690,6 +2784,7 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop) compaction_phase(old_TR, current_env, nextop, max); TR = old_TR; pop_registers(predarity, nextop); + TR = new_TR; c_time = cputime(); YAPLeaveCriticalSection(); if (gc_verbose) { @@ -2714,7 +2809,12 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop) int is_gc_verbose(void) { +#ifdef INSTRUMENT_GC + /* always give info when we are debugging gc */ + return(TRUE); +#else return(GetValue(AtomGcVerbose) != TermNil); +#endif } Int total_gc_time(void) @@ -2765,20 +2865,21 @@ gc(Int predarity, CELL *current_env, yamop *nextop) gc_margin <<= 1; } /* expand the stak if effectiveness is less than 20 % */ - if (ASP - H < gc_margin || !gc_on || effectiveness < 20) { + if (FALSE&& ASP - H < gc_margin || !gc_on || effectiveness < 20) { + UInt gap = CalculateStackGap(); if (ASP-H > gc_margin) - gc_margin = (ASP-H)+MinStackGap*(stack_overflows+1); + gc_margin = (ASP-H)+gap; else gc_margin = 8 * (gc_margin - (ASP - H)); gc_margin = ((gc_margin >> 16) + 1) << 16; - if (gc_margin < MinStackGap) - gc_margin = MinStackGap; - while (gc_margin >= MinStackGap && !growstack(gc_margin)) + if (gc_margin < gap) + gc_margin = gap; + while (gc_margin >= gap && !growstack(gc_margin)) gc_margin = gc_margin/2; #ifdef DEBUG check_global(); #endif - return(gc_margin >= MinStackGap); + return(gc_margin >= gap); } /* * debug for(save_total=1; save_total<=N; ++save_total) diff --git a/C/init.c b/C/init.c index 8b29e7d85..89b868242 100644 --- a/C/init.c +++ b/C/init.c @@ -1015,6 +1015,7 @@ InitYaamRegs(void) BBREG = B_FZ = B_BASE; TR = TR_FZ = TR_BASE; #endif /* FROZEN_REGS */ + CreepFlag = CalculateStackGap(); } @@ -1124,7 +1125,6 @@ InitStacks(int Heap, ReleaseAtom(AtomFoundVar); LookupAtomWithAddress("[]",&(SF_STORE->AtNil)); LookupAtomWithAddress(".",&(SF_STORE->AtDot)); - CreepFlag = MinStackGap; PutValue(LookupAtom("$catch_counter"), MkIntTerm(0)); /* InitAbsmi must be done before InitCodes */ diff --git a/C/iopreds.c b/C/iopreds.c index 8c36d0283..0498e512c 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -82,6 +82,9 @@ typedef struct Int max_size; /* maximum buffer size (may be changed dynamically) */ Int pos; } mem_string; + struct { + int fd; + } pipe; #if USE_SOCKET struct { socket_domain domain; @@ -111,6 +114,8 @@ STATIC_PROTO (int post_process_read_char, (int, StreamDesc *, int)); STATIC_PROTO (int SocketPutc, (int, int)); STATIC_PROTO (int ConsoleSocketPutc, (int, int)); #endif +STATIC_PROTO (int PipePutc, (int, int)); +STATIC_PROTO (int ConsolePipePutc, (int, int)); STATIC_PROTO (int NullPutc, (int, int)); STATIC_PROTO (int ConsolePutc, (int, int)); STATIC_PROTO (Int p_setprompt, (void)); @@ -119,6 +124,8 @@ STATIC_PROTO (int PlGetc, (int)); STATIC_PROTO (int MemGetc, (int)); STATIC_PROTO (int ISOGetc, (int)); STATIC_PROTO (int ConsoleGetc, (int)); +STATIC_PROTO (int PipeGetc, (int)); +STATIC_PROTO (int ConsolePipeGetc, (int)); #if USE_SOCKET STATIC_PROTO (int SocketGetc, (int)); STATIC_PROTO (int ConsoleSocketGetc, (int)); @@ -214,6 +221,8 @@ StreamDesc Stream[MaxStreams]; #define Server_Socket_Stream_f 0x010000 #endif #define InMemory_Stream_f 0x020000 +#define Pipe_Stream_f 0x040000 +#define Popen_Stream_f 0x080000 int YP_stdin = 0; int YP_stdout = 1; @@ -276,7 +285,7 @@ YP_putc(int ch, int sno) int YP_fflush(int sno) { - if (Stream[sno].status & (Null_Stream_f|InMemory_Stream_f|Socket_Stream_f)) + if (Stream[sno].status & (Null_Stream_f|InMemory_Stream_f|Socket_Stream_f|Pipe_Stream_f)) return(0); return(fflush(Stream[sno].u.file.file)); } @@ -376,7 +385,11 @@ InitStdStream (int sno, SMALLUNSGN flags, YP_File file, Atom name) s->stream_getc = ConsoleSocketGetc; } else #endif - if (s->status & InMemory_Stream_f) { + if (s->status & Pipe_Stream_f) { + /* Console is a socket and socket will prompt */ + s->stream_putc = ConsolePipePutc; + s->stream_getc = ConsolePipeGetc; + } else if (s->status & InMemory_Stream_f) { s->stream_putc = MemPutc; s->stream_getc = MemGetc; } else { @@ -629,8 +642,42 @@ SocketPutc (int sno, int ch) console_count_output_char(ch,s,sno); return ((int) ch); } + #endif +/* static */ +static int +ConsolePipePutc (int sno, int ch) +{ + StreamDesc *s = &Stream[sno]; + char c = ch; +#if MAC || _MSC_VER + if (ch == 10) + { + ch = '\n'; + } +#endif + write(s->u.pipe.fd, &c, sizeof(c)); + count_output_char(ch,s,sno); + return ((int) ch); +} + +static int +PipePutc (int sno, int ch) +{ + StreamDesc *s = &Stream[sno]; + char c = ch; +#if MAC || _MSC_VER + if (ch == 10) + { + ch = '\n'; + } +#endif + write(s->u.pipe.fd, &c, sizeof(c)); + console_count_output_char(ch,s,sno); + return ((int) ch); +} + static int NullPutc (int sno, int ch) { @@ -793,7 +840,12 @@ EOFGetc(int sno) s->stream_putc = SocketPutc; } else #endif - if (s->status & InMemory_Stream_f) { + if (s->status & Pipe_Stream_f) { + if (s->status & Promptable_Stream_f) + s->stream_putc = ConsolePipePutc; + else + s->stream_putc = PipePutc; + } else if (s->status & InMemory_Stream_f) { s->stream_getc = MemGetc; s->stream_putc = MemPutc; } else if (s->status & Promptable_Stream_f) { @@ -946,6 +998,61 @@ ConsoleSocketGetc(int sno) } #endif +static int +PipeGetc(int sno) +{ + register StreamDesc *s = &Stream[sno]; + register int ch; + char c; + int count; + /* should be able to use a buffer */ + count = read(s->u.pipe.fd, &c, sizeof(char)); + if (count == 0) { + ch = EOF; + } else if (count > 0) { + ch = c; + } else { + Error(SYSTEM_ERROR, TermNil, "read"); + return(EOF); + } + return(post_process_read_char(ch, s, sno)); +} + +/* + Basically, the same as console but also sends a prompt and takes care of + finding out whether we are at the start of a newline. +*/ +static int +ConsolePipeGetc(int sno) +{ + register StreamDesc *s = &Stream[sno]; + register int ch; + char c; + int count; + + /* send the prompt away */ + if (newline) { + char *cptr = Prompt, ch; + /* use the default routine */ + while ((ch = *cptr++) != '\0') { + Stream[StdErrStream].stream_putc(StdErrStream, ch); + } + strncpy(Prompt, RepAtom (*AtPrompt)->StrOfAE, MAX_PROMPT); + newline = FALSE; + } + /* should be able to use a buffer */ + count = read(s->u.pipe.fd, &c, sizeof(char)); + if (count == 0) { + ch = EOF; + } else if (count > 0) { + ch = c; + } else { + Error(SYSTEM_ERROR, TermNil, "read"); + return(EOF); + } + return(console_post_process_read_char(ch, s, sno)); +} + /* standard routine, it should read from anything pointed by a FILE *. It could be made more efficient by doing our own buffering and avoiding post_process_read_char, something to think about */ @@ -1132,7 +1239,9 @@ GetStreamFd(int sno) return(Stream[sno].u.socket.fd); } else #endif - if (Stream[sno].status & InMemory_Stream_f) { + if (Stream[sno].status & Pipe_Stream_f) { + return(Stream[sno].u.pipe.fd); + } else if (Stream[sno].status & InMemory_Stream_f) { return(-1); } return(YP_fileno(Stream[sno].u.file.file)); @@ -1338,7 +1447,10 @@ p_open (void) st->stream_getc = SocketGetc; } else #endif - if (st->status & InMemory_Stream_f) { + if (st->status & Pipe_Stream_f) { + st->stream_putc = PipePutc; + st->stream_getc = PipeGetc; + } else if (st->status & InMemory_Stream_f) { st->stream_putc = MemPutc; st->stream_getc = MemGetc; } else { @@ -1498,6 +1610,111 @@ p_open_null_stream (void) return (unify (ARG1, t)); } +Term +OpenStream(FILE *fd, char *name, Term file_name, int flags) +{ + Term t; + StreamDesc *st; + int sno; + + for (sno = 0; sno < MaxStreams; ++sno) + if (Stream[sno].status & Free_Stream_f) + break; + if (sno == MaxStreams) + return (PlIOError (SYSTEM_ERROR,TermNil, "new stream not available for open_null_stream/1")); + st = &Stream[sno]; + st->status = 0; + if (flags & YAP_INPUT_STREAM) + st->status |= Input_Stream_f; + if (flags & YAP_OUTPUT_STREAM) + st->status |= Output_Stream_f; + if (flags & YAP_APPEND_STREAM) + st->status |= Append_Stream_f; + /* + pipes assume an integer file descriptor, not a FILE *: + if (flags & YAP_PIPE_STREAM) + st->status |= Pipe_Stream_f; + */ + if (flags & YAP_TTY_STREAM) + st->status |= Tty_Stream_f; + if (flags & YAP_POPEN_STREAM) + st->status |= Popen_Stream_f; + if (flags & YAP_BINARY_STREAM) + st->status |= Binary_Stream_f; + if (flags & YAP_SEEKABLE_STREAM) + st->status |= Seekable_Stream_f; + st->charcount = 0; + st->linecount = 1; + st->u.file.name = LookupAtom(name); + st->u.file.user_name = file_name; + st->u.file.file = fd; + st->linepos = 0; + if (flags & YAP_PIPE_STREAM) { + st->stream_putc = PipePutc; + st->stream_getc = PipeGetc; + } else if (flags & YAP_TTY_STREAM) { + st->stream_putc = ConsolePutc; + st->stream_getc = ConsoleGetc; + } else { + st->stream_putc = FilePutc; + st->stream_getc = PlGetc; + unix_upd_stream_info (st); + } + if (CharConversionTable != NULL) + st->stream_getc_for_read = ISOGetc; + else + st->stream_getc_for_read = st->stream_getc; + t = MkStream (sno); + return (t); +} + +static Int +p_open_pipe_stream (void) +{ + Term t1, t2; + StreamDesc *st; + int sno; + int filedes[2]; + + if (pipe(filedes) != 0) { + return (PlIOError (SYSTEM_ERROR,TermNil, "open_pipe_stream/2 could not create pipe")); + } + for (sno = 0; sno < MaxStreams; ++sno) + if (Stream[sno].status & Free_Stream_f) + break; + if (sno == MaxStreams) + return (PlIOError (SYSTEM_ERROR,TermNil, "new stream not available for open_pipe_stream/2")); + st = &Stream[sno]; + st->status = Input_Stream_f | Pipe_Stream_f; + st->linepos = 0; + st->charcount = 0; + st->linecount = 1; + st->stream_putc = PipePutc; + st->stream_getc = PipeGetc; + st->stream_getc_for_read = PipeGetc; + st->u.pipe.fd = filedes[0]; + t1 = MkStream (sno); + for (; sno < MaxStreams; ++sno) + if (Stream[sno].status & Free_Stream_f) + break; + if (sno == MaxStreams) + return (PlIOError (SYSTEM_ERROR,TermNil, "new stream not available for open_pipe_stream/2")); + st = &Stream[sno]; + st->status = Output_Stream_f | Pipe_Stream_f; + st->linepos = 0; + st->charcount = 0; + st->linecount = 1; + st->stream_putc = PipePutc; + st->stream_getc = PipeGetc; + if (CharConversionTable != NULL) + st->stream_getc_for_read = ISOGetc; + else + st->stream_getc_for_read = st->stream_getc; + st->u.pipe.fd = filedes[1]; + t2 = MkStream (sno); + return (unify (ARG1, t1) && unify (ARG2, t2)); +} + static Int p_open_mem_read_stream (void) /* $open_mem_read_stream(+List,-Stream) */ { @@ -1839,11 +2056,42 @@ p_check_if_stream (void) != -1); } +static Term +StreamName(int i) +{ +#if USE_SOCKET + if (Stream[i].status & Socket_Stream_f) + return(MkAtomTerm(LookupAtom("socket"))); + else +#endif + if (Stream[i].status & Pipe_Stream_f) + return(MkAtomTerm(LookupAtom("pipe"))); + if (Stream[i].status & InMemory_Stream_f) + return(MkAtomTerm(LookupAtom("charsio"))); + else + return(MkAtomTerm(Stream[i].u.file.name)); +} + static Int init_cur_s (void) { /* Init current_stream */ - EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0); - return (cont_cur_s ()); + Term t3 = Deref(ARG3); + if (!IsVarTerm(t3)) { + Int i = CheckStream (t3, Input_Stream_f|Output_Stream_f, "current_stream/3"); + Term t1 = StreamName(i), t2; + + t2 = (Stream[i].status & Input_Stream_f ? + MkAtomTerm (AtomRead) : + MkAtomTerm (AtomWrite)); + if (unify(ARG1,t1) && unify(ARG2,t2)) { + cut_succeed(); + } else { + cut_fail(); + } + } else { + EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0); + return (cont_cur_s ()); + } } static Int @@ -1858,15 +2106,7 @@ cont_cur_s (void) ++i; continue; } -#if USE_SOCKET - if (Stream[i].status & Socket_Stream_f) - t1 = MkAtomTerm(LookupAtom("socket")); - else -#endif - if (Stream[i].status & InMemory_Stream_f) - t1 = MkAtomTerm(LookupAtom("charsio")); - else - t1 = MkAtomTerm(Stream[i].u.file.name); + t1 = StreamName(i); t2 = (Stream[i].status & Input_Stream_f ? MkAtomTerm (AtomRead) : MkAtomTerm (AtomWrite)); @@ -1893,40 +2133,43 @@ void CloseStreams (int loud) { int sno; - for (sno = 3; sno < MaxStreams; ++sno) - { - if (Stream[sno].status & Free_Stream_f) - continue; - if (!(Stream[sno].status & (Null_Stream_f|Socket_Stream_f|InMemory_Stream_f))) - YP_fclose (Stream[sno].u.file.file); + for (sno = 3; sno < MaxStreams; ++sno) { + if (Stream[sno].status & Free_Stream_f) + continue; + if ((Stream[sno].status & Popen_Stream_f)) + pclose (Stream[sno].u.file.file); + if ((Stream[sno].status & (Pipe_Stream_f|Socket_Stream_f))) + close (Stream[sno].u.pipe.fd); #if USE_SOCKET - else if (Stream[sno].status & (Socket_Stream_f)) { - CloseSocket(Stream[sno].u.socket.fd, - Stream[sno].u.socket.flags, - Stream[sno].u.socket.domain); - } + else if (Stream[sno].status & (Socket_Stream_f)) { + CloseSocket(Stream[sno].u.socket.fd, + Stream[sno].u.socket.flags, + Stream[sno].u.socket.domain); + } #endif - else { + else if (!(Stream[sno].status & (Null_Stream_f|Socket_Stream_f|InMemory_Stream_f))) + YP_fclose (Stream[sno].u.file.file); + else { if (loud) YP_fprintf (YP_stderr, "[ Error: while closing stream: %s ]\n", RepAtom (Stream[sno].u.file.name)->StrOfAE); - if (c_input_stream == sno) - { - c_input_stream = StdInStream; - } - else if (c_output_stream == sno) - { - c_output_stream = StdOutStream; - } - } - Stream[sno].status = Free_Stream_f; } + if (c_input_stream == sno) + { + c_input_stream = StdInStream; + } + else if (c_output_stream == sno) + { + c_output_stream = StdOutStream; + } + } + Stream[sno].status = Free_Stream_f; } void CloseStream(int sno) { - if (!(Stream[sno].status & (Null_Stream_f|Socket_Stream_f|InMemory_Stream_f))) + if (!(Stream[sno].status & (Null_Stream_f|Socket_Stream_f|InMemory_Stream_f|Pipe_Stream_f))) YP_fclose (Stream[sno].u.file.file); #if USE_SOCKET else if (Stream[sno].status & (Socket_Stream_f)) { @@ -1935,6 +2178,9 @@ CloseStream(int sno) Stream[sno].u.socket.domain); } #endif + else if (Stream[sno].status & (Pipe_Stream_f)) { + close(Stream[sno].u.pipe.fd); + } else if (Stream[sno].status & (InMemory_Stream_f)) { FreeAtomSpace(Stream[sno].u.mem_string.buf); } @@ -2332,7 +2578,7 @@ p_read (void) /* Scans the term using stack space */ eot_before_eof = FALSE; - if ((Stream[c_input_stream].status & (Promptable_Stream_f|Socket_Stream_f|Eof_Stream_f|InMemory_Stream_f)) || CharConversionTable != NULL) + if ((Stream[c_input_stream].status & (Promptable_Stream_f|Pipe_Stream_f|Socket_Stream_f|Eof_Stream_f|InMemory_Stream_f)) || CharConversionTable != NULL) tokstart = tokptr = toktide = tokenizer (Stream[c_input_stream].stream_getc_for_read, Stream[c_input_stream].stream_getc); else { tokstart = tokptr = toktide = fast_tokenizer (); @@ -2507,7 +2753,9 @@ p_user_file_name (void) tout = MkAtomTerm(LookupAtom("socket")); else #endif - if (Stream[sno].status & InMemory_Stream_f) + if (Stream[sno].status & Pipe_Stream_f) + tout = MkAtomTerm(LookupAtom("pipe")); + else if (Stream[sno].status & InMemory_Stream_f) tout = MkAtomTerm(LookupAtom("charsio")); else tout = Stream[sno].u.file.user_name; @@ -2526,7 +2774,9 @@ p_file_name (void) tout = MkAtomTerm(LookupAtom("socket")); else #endif - if (Stream[sno].status & InMemory_Stream_f) + if (Stream[sno].status & Pipe_Stream_f) + tout = MkAtomTerm(LookupAtom("pipe")); + else if (Stream[sno].status & InMemory_Stream_f) tout = MkAtomTerm(LookupAtom("charsio")); else tout = MkAtomTerm(Stream[sno].u.file.name); @@ -2552,13 +2802,16 @@ p_cur_line_no (void) my_stream = LookupAtom("socket"); else #endif + if (Stream[sno].status & Pipe_Stream_f) + my_stream = LookupAtom("pipe"); + else if (Stream[sno].status & InMemory_Stream_f) my_stream = LookupAtom("charsio"); else my_stream = Stream[sno].u.file.name; for (i = 0; i < MaxStreams; i++) { - if (!(Stream[i].status & (Free_Stream_f|Socket_Stream_f|InMemory_Stream_f)) && + if (!(Stream[i].status & (Free_Stream_f|Socket_Stream_f|Pipe_Stream_f|InMemory_Stream_f)) && Stream[i].u.file.name == my_stream) no += Stream[i].linecount - 1; } @@ -2643,7 +2896,7 @@ p_show_stream_position (void) CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "stream_position/2"); if (sno < 0) return (FALSE); - if (Stream[sno].status & (Tty_Stream_f|Socket_Stream_f|InMemory_Stream_f)) + if (Stream[sno].status & (Tty_Stream_f|Socket_Stream_f|Pipe_Stream_f|InMemory_Stream_f)) sargs[0] = MkIntTerm (Stream[sno].charcount); else if (Stream[sno].status & Null_Stream_f) sargs[0] = MkIntTerm (Stream[sno].charcount); @@ -3897,7 +4150,7 @@ p_flush (void) int sno = CheckStream (ARG1, Output_Stream_f, "flush_output/1"); if (sno < 0) return (FALSE); - if (!(Stream[sno].status & (Null_Stream_f|Socket_Stream_f|InMemory_Stream_f))) + if (!(Stream[sno].status & (Null_Stream_f|Socket_Stream_f|Pipe_Stream_f|InMemory_Stream_f))) YP_fflush (sno); return (TRUE); } @@ -4250,6 +4503,21 @@ p_all_char_conversions(void) return(unify(ARG1,out)); } +int +StreamToFileNo(Term t) +{ + int sno = + CheckStream(t, (Input_Stream_f|Output_Stream_f), "StreamToFileNo"); + if (Stream[sno].status & Pipe_Stream_f) { + return(Stream[sno].u.pipe.fd); + } else if (Stream[sno].status & Socket_Stream_f) { + return(Stream[sno].u.socket.fd); + } else if (Stream[sno].status & (Null_Stream_f|InMemory_Stream_f)) { + return(-1); + } else { + return(YP_fileno(Stream[sno].u.file.file)); + } +} void InitBackIO (void) @@ -4274,6 +4542,7 @@ InitIOPreds(void) InitCPred ("$get_byte", 2, p_get_byte, SafePredFlag|SyncPredFlag); InitCPred ("$open", 4, p_open, SafePredFlag|SyncPredFlag); InitCPred ("$open_null_stream", 1, p_open_null_stream, SafePredFlag|SyncPredFlag); + InitCPred ("$open_pipe_stream", 2, p_open_pipe_stream, SafePredFlag|SyncPredFlag); InitCPred ("open_mem_read_stream", 2, p_open_mem_read_stream, SyncPredFlag); InitCPred ("open_mem_write_stream", 1, p_open_mem_write_stream, SyncPredFlag); InitCPred ("$put", 2, p_put, SafePredFlag|SyncPredFlag); diff --git a/C/mavar.c b/C/mavar.c index f84b1e073..d89e9c276 100644 --- a/C/mavar.c +++ b/C/mavar.c @@ -92,12 +92,11 @@ p_setarg(void) timestamps. Because of !, the only timestamp one can trust is the trailpointer - (ouch..). The trail is not reclaimed during backtracking. Also, if - there was a conditional binding, the trail is sure to have been - increased since the last choicepoint. For maximum effect, we can - actually store the current value of TR in the timestamp field, - giving a way to actually follow a link of all trailings for these - variables. + (ouch..). The trail is not reclaimed after cuts. Also, if there was + a conditional binding, the trail is sure to have been increased + since the last choicepoint. For maximum effect, we can actually + store the current value of TR in the timestamp field, giving a way + to actually follow a link of all trailings for these variables. */ @@ -114,6 +113,8 @@ static void CreateTimedVar(Term val) { timed_var *tv = (timed_var *)H; + tv->clock = MkIntTerm(0); +#ifdef BEFORE_TRAIL_COMPRESSION tv->clock = MkIntegerTerm((Int)((CELL *)(B->cp_tr)-(CELL *)TrailBase)); if (B->cp_tr == TR) { /* we run the risk of not making non-determinate bindings before @@ -121,6 +122,7 @@ CreateTimedVar(Term val) /* so we just init a TR cell that will not harm anyone */ Bind((CELL *)(TR+1),AbsAppl(H-1)); } +#endif tv->value = val; H += sizeof(timed_var)/sizeof(CELL); } @@ -129,6 +131,8 @@ static void CreateEmptyTimedVar(void) { timed_var *tv = (timed_var *)H; + tv->clock = MkIntTerm(0); +#ifdef BEFORE_TRAIL_COMPRESSION tv->clock = MkIntegerTerm((Int)((CELL *)(B->cp_tr)-(CELL *)TrailBase)); if (B->cp_tr == TR) { /* we run the risk of not making non-determinate bindings before @@ -136,6 +140,7 @@ CreateEmptyTimedVar(void) /* so we just init a TR cell that will not harm anyone */ Bind((CELL *)(TR+1),AbsAppl(H-1)); } +#endif RESET_VARIABLE(&(tv->value)); H += sizeof(timed_var)/sizeof(CELL); } diff --git a/C/stdpreds.c b/C/stdpreds.c index 3b1f0d119..2aa39617e 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -1247,7 +1247,7 @@ static Int p_abort(void) { /* abort */ /* make sure we won't go creeping around */ - CreepFlag = MinStackGap*(stack_overflows+1); + CreepFlag = CalculateStackGap(); yap_flags[SPY_CREEP_FLAG] = 0; Error(PURE_ABORT,TermNil,""); return(FALSE); diff --git a/C/sysbits.c b/C/sysbits.c index 0dab92b87..973992dc1 100644 --- a/C/sysbits.c +++ b/C/sysbits.c @@ -82,12 +82,6 @@ static char SccsId[] = "%W% %G%"; #endif #endif -#ifdef __MINGW32__ -#ifdef HAVE_ENVIRON -#undef HAVE_ENVIRON -#endif -#endif - STATIC_PROTO (void InitPageSize, (void)); STATIC_PROTO (void InitTime, (void)); STATIC_PROTO (void InitWTime, (void)); @@ -98,11 +92,11 @@ STATIC_PROTO (Int p_mv, (void)); STATIC_PROTO (Int p_cd, (void)); STATIC_PROTO (Int p_getcwd, (void)); STATIC_PROTO (Int p_dir_sp, (void)); -STATIC_PROTO (Int p_getenv, (void)); -STATIC_PROTO (Int p_environ, (void)); STATIC_PROTO (void InitRandom, (void)); STATIC_PROTO (Int p_srandom, (void)); STATIC_PROTO (Int p_alarm, (void)); +STATIC_PROTO (Int p_getenv, (void)); +STATIC_PROTO (Int p_putenv, (void)); #ifdef MACYAP STATIC_PROTO (int chdir, (char *)); /* #define signal skel_signal */ @@ -1233,7 +1227,7 @@ HandleSIGINT (int sig) #else #ifdef HAVE_SETBUF /* make sure we are not waiting for the end of line */ - YP_setbuf (YP_stdin, NULL); + YP_setbuf (stdin, NULL); #endif my_signal(SIGINT, HandleSIGINT); #endif @@ -1800,35 +1794,6 @@ SetTextFile (name) #endif -/* return YAP's environment */ -static Int p_environ(void) -{ -#if HAVE_ENVIRON - extern char **environ; - Term t1 = Deref(ARG1); - Int i; - - if (IsVarTerm(t1)) { - Error(INSTANTIATION_ERROR, t1, - "first arg of environ/2"); - return(FALSE); - } else if (!IsIntTerm(t1)) { - Error(TYPE_ERROR_INTEGER, t1, - "first arg of environ/2"); - return(FALSE); - } else i = IntOfTerm(t1); - if (environ[i] == NULL) - return(FALSE); - else { - Term t = StringToList(environ[i]); - return(unify(t, ARG2)); - } -#else - Error(SYSTEM_ERROR, TermNil, - "environ not available in this configuration"); - return (FALSE); -#endif -} /* return YAP's environment */ static Int p_getenv(void) @@ -1903,7 +1868,6 @@ static Int p_putenv(void) #endif } - /* wrapper for alarm system call */ #if defined(_WIN32) static VOID CALLBACK HandleTimer(LPVOID v, DWORD d1, DWORD d2) { @@ -2028,10 +1992,9 @@ InitSysPreds(void) InitCPred ("$cd", 1, p_cd, SafePredFlag|SyncPredFlag); InitCPred ("$getcwd", 1, p_getcwd, SafePredFlag|SyncPredFlag); InitCPred ("$dir_separator", 1, p_dir_sp, SafePredFlag); - InitCPred ("$environ", 2, p_environ, SafePredFlag); + InitCPred ("$alarm", 2, p_alarm, SafePredFlag|SyncPredFlag); InitCPred ("$getenv", 2, p_getenv, SafePredFlag); InitCPred ("$putenv", 2, p_putenv, SafePredFlag|SyncPredFlag); - InitCPred ("$alarm", 2, p_alarm, SafePredFlag|SyncPredFlag); } diff --git a/C/tracer.c b/C/tracer.c index 595ee3558..2870aaf24 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -129,10 +129,10 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) extern int gc_calls; vsc_count++; - if (vsc_count < 2810) return; + /* if (vsc_count < 4382) return;*/ /* if (vsc_count > 500000) exit(0); */ /* if (gc_calls < 1) return;*/ - YP_fprintf(YP_stderr,"%lu ",vsc_count); + YP_fprintf(YP_stderr,"%lu (%p)", vsc_count, H); /* check_trail_consistency(); */ if (pred == NULL) { return; diff --git a/H/Regs.h b/H/Regs.h index fa8afbe6b..b3644cd1c 100644 --- a/H/Regs.h +++ b/H/Regs.h @@ -10,7 +10,7 @@ * File: Regs.h * * mods: * * comments: YAP abstract machine registers * -* version: $Id: Regs.h,v 1.1.1.1 2001-04-09 19:53:39 vsc Exp $ * +* version: $Id: Regs.h,v 1.2 2001-05-21 20:00:05 vsc Exp $ * *************************************************************************/ @@ -682,3 +682,10 @@ EXTERN inline void restore_B(void) { REGSTORE standard_regs; #endif /* PUSH_REGS */ +static inline UInt +CalculateStackGap(void) +{ + UInt gmin = (LCL0-H0)>>1; + UInt min_gap = MinStackGap; + return(gmin < min_gap ? min_gap : gmin ); +} diff --git a/H/yapio.h b/H/yapio.h index 5a824c518..d3778e779 100644 --- a/H/yapio.h +++ b/H/yapio.h @@ -259,9 +259,21 @@ int STD_PROTO(GetStreamFd,(int)); void STD_PROTO(CloseStream,(int)); int STD_PROTO(PlGetchar,(void)); int STD_PROTO(PlFGetchar,(void)); +int STD_PROTO(StreamToFileNo,(Term)); extern int c_input_stream, c_output_stream, c_error_stream; +#define YAP_INPUT_STREAM 0x01 +#define YAP_OUTPUT_STREAM 0x02 +#define YAP_APPEND_STREAM 0x04 +#define YAP_PIPE_STREAM 0x08 +#define YAP_TTY_STREAM 0x10 +#define YAP_POPEN_STREAM 0x20 +#define YAP_BINARY_STREAM 0x40 +#define YAP_SEEKABLE_STREAM 0x80 + +Term STD_PROTO(OpenStream,(FILE *,char *,Term,int)); + /* routines in sysbits.c */ char *STD_PROTO(pfgets,(char *,int,YP_File)); diff --git a/Makefile.in b/Makefile.in index c23960dd4..2e6d4d615 100644 --- a/Makefile.in +++ b/Makefile.in @@ -450,6 +450,7 @@ install_unix: (cd $(srcdir)/CLPQR ; tar cf - .) | (cd $(DESTDIR)$(YAPLIBDIR)/library ; tar xf -) (cd $(srcdir)/CHR ; tar cf - .) | (cd $(DESTDIR)$(YAPLIBDIR)/library ; tar xf -) @INSTALL_DLLS@ (cd library/regex; make install) + @INSTALL_DLLS@ (cd library/system; make install) -mkdir -p $(DESTDIR)$(INCLUDEDIR) for h in $(INTERFACE_HEADERS); do $(INSTALL) $$h $(DESTDIR)$(INCLUDEDIR); done @@ -473,6 +474,8 @@ install_mingw32: (cd $(srcdir)/CHR ; tar cf - .) | (cd $(DESTDIR)$(YAPLIBDIR)/library ; tar xf -) (cd library/regex; make install_mingw32) +# (cd library/system; make install_mingw32) + install_library: libYap.a $(INSTALL_DATA) -m 644 libYap.a $(DESTDIR)$(LIBDIR)/libYap.a -mkdir $(DESTDIR)$(INCLUDEDIR) diff --git a/OPTYap/or.engine.c b/OPTYap/or.engine.c index c9f2dede4..df251bc50 100644 --- a/OPTYap/or.engine.c +++ b/OPTYap/or.engine.c @@ -539,8 +539,8 @@ void share_private_nodes(int worker_q) { /* frozen stack segment */ if (! next_node_on_branch) next_node_on_branch = sharing_node; - STACK_PUSH(or_frame, stack, stack_top); - STACK_PUSH(sharing_node, stack, stack_top); + STACK_PUSH(or_frame, stack, stack_top, stack_base); + STACK_PUSH(sharing_node, stack, stack_top, stack_base); sharing_node = consumer_cp; dep_frame = DepFr_next(dep_frame); consumer_cp = DepFr_cons_cp(dep_frame); diff --git a/OPTYap/tab.suspend.c b/OPTYap/tab.suspend.c index c873b61d4..79ddc1434 100644 --- a/OPTYap/tab.suspend.c +++ b/OPTYap/tab.suspend.c @@ -4,6 +4,8 @@ #include "Yap.h" #if defined(TABLING) && defined(YAPOR) +#include "Yatom.h" +#include "Heap.h" #include "tab.macros.h" #include "or.macros.h" diff --git a/TO_DO b/TO_DO index 52db33625..c18dfdb33 100644 --- a/TO_DO +++ b/TO_DO @@ -1,4 +1,5 @@ BEFORE 4.4: +- weird going ons with prompt - mixed constraints and delays. - write infinite terms - constraints in DB. @@ -8,7 +9,11 @@ BEFORE 4.4: - timestamps on files. - warnings in documentation file. - system library -- fixed restore when code is moved around. +- fix restore when code is moved around. +- library(system) for WIN32 +- document system(library) +- document new interface functions. +- logtalk. TO CHECK: - bad register allocation for a(X,Y) :- X is Y+2.3 ? @@ -16,6 +21,7 @@ TO CHECK: TABLING - pass all tabling tests from Kostis and Bart paper - handle floats, long ints and friends in tables. +- knap-sack AFTER 4.4(?) - change compilation order for arguments diff --git a/changes.css b/changes.css new file mode 100644 index 000000000..a243c730d --- /dev/null +++ b/changes.css @@ -0,0 +1 @@ +body { color: black; background-color: #FFE4C4; font-family: sans-serif; margin-left: 2em; margin-right: 2em; } h1, h2, h3, h4, h5, h6 { color: maroon; font-family: helvetica, arial, sans-serif; text-align: center; } code, pre { font-family: courier, monospace; } \ No newline at end of file diff --git a/changes4.3.html b/changes4.3.html index e6463ba4c..16af2dd3f 100644 --- a/changes4.3.html +++ b/changes4.3.html @@ -1,1691 +1,1350 @@ -Changes up to YAP4.3 + - + -

Changes in YAP4.3

+ + YAP change log + + -

Yap-4.3.19:

- + -

Yap-4.3.18:

- +
-

Yap-4.3.17:

- +

Changes in YAP4.3

-

Yap-4.3.16:

- +

Yap-4.3.19:

+ -

Yap-4.3.15:

- +

Yap-4.3.18:

+ -

Yap-4.3.14:

- +

Yap-4.3.17:

+ -

Yap-4.3.13:

- +

Yap-4.3.16:

+ -

Yap-4.3.12:

- +

Yap-4.3.15:

+ -

Yap-4.3.11:

- +

Yap-4.3.14:

+ + +

Yap-4.3.13:

+ + +

Yap-4.3.12:

+ + +

Yap-4.3.11:

+ -

Yap-4.3.10:

- +

Yap-4.3.10:

+ -

Yap-4.3.9:

- +

Yap-4.3.9:

+ -

Yap-4.3.8:

- +

Yap-4.3.8:

+ -

Yap4.3.7:

- +

Yap4.3.7:

+ -

Yap4.3.6:

- +

Yap4.3.6:

+ -

Yap4.3.5:

- +

Yap4.3.5:

+ -

Yap4.3.4:

- +

Yap4.3.4:

+ -

Yap4.3.3:

- +

Yap4.3.3:

+ -

Yap4.3.2:

- +

Yap4.3.2:

+ -

Yap4.3.1:

- +

Yap4.3.1:

+ -

+

Yap4.3.0 has been released. -

+

-

Changes in YAP4.2

-

+

Changes in YAP4.2

-

Yap4.2.1:

- +

Yap4.2.1:

+ -

Yap4.2.0pl18:

- +

Yap4.2.0pl18:

+ -

Yap4.2.0pl17:

- +

Yap4.2.0pl17:

+ -

Yap4.2.0pl16:

- +

Yap4.2.0pl16:

+ -

Yap4.2.0pl15:

- +

Yap4.2.0pl15:

+ -

Yap4.2.0pl14:

- +

Yap4.2.0pl14:

+ -

Yap4.2.0pl13:

- +

Yap4.2.0pl13:

+ -

Yap4.2.0pl12:

- +

Yap4.2.0pl12:

+ -

Yap4.2.0pl11:

- +

Yap4.2.0pl11:

+ -

Yap4.2.0pl10:

- +

Yap4.2.0pl10:

+ -

Yap4.2.0pl9:

- +

Yap4.2.0pl9:

+ -

Yap4.2.0pl8:

- +

Yap4.2.0pl8:

+ -

Yap4.2.0pl7:

- +

Yap4.2.0pl7:

+ -

Yap4.2.0pl6:

- +

Yap4.2.0pl6:

+ -

Yap4.2.0pl5:

- +

Yap4.2.0pl5:

+ -

Yap4.2.0pl4:

- +

Yap4.2.0pl4:

+ -

Yap4.2.0pl3:

- +

Yap4.2.0pl3:

+ -

Yap4.2.0pl2:

- +

Yap4.2.0pl2:

+ -

Yap4.2.0pl1:

- +

Yap4.2.0pl1:

+ -

Yap4.2.0:

- +

Yap4.2.0:

+ -

Changes in YAP4.1

-

+

Changes in YAP4.1

-

Yap4.1.19:

- +

Yap4.1.19:

+ -

Yap4.1.18:

- +

Yap4.1.18:

+ -

Yap4.1.17:

- +

Yap4.1.17:

+ -

Yap4.1.16:

- +

Yap4.1.16:

+ -

Yap4.1.15:

- +

Yap4.1.15:

+ -

Yap4.1.14:

- +

Yap4.1.14:

+ -

Yap4.1.13:

- +

Yap4.1.13:

+ -

Yap4.1.12:

- +

Yap4.1.12:

+ -

Yap4.1.11:

- +

Yap4.1.11:

+ -

Yap4.1.10:

- +

Yap4.1.10:

+ -

Yap4.1.9:

- +

Yap4.1.9:

+ -

Yap4.1.8:

- +

Yap4.1.8:

+ -

Yap4.1.7:

- +

Yap4.1.7:

+ -

Yap4.1.6:

- +

Yap4.1.6:

+ -

Yap4.1.5:

- +

Yap4.1.5:

+ -

Yap4.1.4:

- +

Yap4.1.4:

+ -

Yap4.1.3:

- +

Yap4.1.3:

+ -

Yap4.1.2:

- +

Yap4.1.2:

+ -

Yap4.1.1:

- +

Yap4.1.1:

+ -

Yap4.1.0:

- +

Yap4.1.0:

+ + +
+ + + + diff --git a/config.h.in b/config.h.in index de4abecc0..c7055cce2 100644 --- a/config.h.in +++ b/config.h.in @@ -26,10 +26,12 @@ #undef HAVE_ARPA_INET_H #undef HAVE_CTYPE_H #undef HAVE_DIRECT_H +#undef HAVE_DIRENT_H #undef HAVE_ERRNO_H #undef HAVE_FCNTL_H #undef HAVE_FENV_H #undef HAVE_FPU_CONTROL_H +#undef HAVE_GMP_H #undef HAVE_IEEEFP_H #undef HAVE_LIMITS_H #undef HAVE_MEMORY_H @@ -37,6 +39,7 @@ #undef HAVE_NETINET_IN_H #undef HAVE_REGEX_H #undef HAVE_SIGINFO_H +#undef HAVE_SIGNAL_H #undef HAVE_STDARG_H #undef HAVE_STRING_H #undef HAVE_SYS_FILE_H @@ -56,7 +59,6 @@ #undef HAVE_UNISTD_H #undef HAVE_WINSOCK_H #undef HAVE_WINSOCK2_H -#undef HAVE_GMP_H /* Do we have restartable syscalls */ #undef HAVE_RESTARTABLE_SYSCALLS @@ -101,6 +103,9 @@ #undef HAVE_DUP2 #undef HAVE_FETESTEXCEPT #undef HAVE_FINITE +#undef HAVE_GETHOSTBYNAME +#undef HAVE_GETHOSTID +#undef HAVE_GETHOSTNAME #undef HAVE_GETRUSAGE #undef HAVE_GETCWD #undef HAVE_GETENV @@ -110,15 +115,22 @@ #undef HAVE_GETWD #undef HAVE_ISATTY #undef HAVE_ISNAN +#undef HAVE_KILL #undef HAVE_LABS #undef HAVE_LINK +#undef HAVE_LOCALTIME +#undef HAVE_LSTAT #undef HAVE_MMAP #undef HAVE_MEMCPY #undef HAVE_MEMMOVE #undef HAVE_MKSTEMP +#undef HAVE_MKTEMP +#undef HAVE_OPENDIR +#undef HAVE_POPEN #undef HAVE_PUTENV #undef HAVE_RAND #undef HAVE_RANDOM +#undef HAVE_RENAME #undef HAVE_RINT #undef HAVE_SBRK #undef HAVE_STAT @@ -132,6 +144,7 @@ #undef HAVE_SIGPROCMASK #undef HAVE_SIGSEGV #undef HAVE_SIGSETJMP +#undef HAVE_SLEEP #undef HAVE_SNPRINTF #undef HAVE_SOCKET #undef HAVE_STRERROR @@ -140,9 +153,12 @@ #undef HAVE_STRCHR #undef HAVE_STRTOD #undef HAVE_SYSTEM +#undef HAVE_TIME #undef HAVE_TIMES #undef HAVE_TMPNAM +#undef HAVE_USLEEP #undef HAVE_VSNPRINTF +#undef HAVE_WAITPID #undef HAVE_ENVIRON #undef HAVE_MPZ_XOR diff --git a/configure b/configure index 28b9eb9da..7ec4b9aee 100755 --- a/configure +++ b/configure @@ -2461,7 +2461,7 @@ else fi done -for ac_hdr in sys/select.h direct.h +for ac_hdr in sys/select.h direct.h dirent.h signal.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 @@ -3612,7 +3612,7 @@ else fi done -for ac_func in setlinebuf +for ac_func in setlinebuf lstat opendir localtime time gethostname do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 echo "configure:3619: checking for $ac_func" >&5 @@ -3667,15 +3667,125 @@ else fi done +for ac_func in gethostid gethostbyname kill mktemp popen rename waitpid +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +echo "configure:3674: checking for $ac_func" >&5 +if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +$ac_func(); +#endif + +; return 0; } +EOF +if { (eval echo configure:3702: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_$ac_func=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` + cat >> confdefs.h <&6 +fi +done + +for ac_func in sleep usleep +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +echo "configure:3729: checking for $ac_func" >&5 +if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +$ac_func(); +#endif + +; return 0; } +EOF +if { (eval echo configure:3757: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_$ac_func=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` + cat >> confdefs.h <&6 +fi +done + echo $ac_n "checking for mpz_xor""... $ac_c" 1>&6 -echo "configure:3673: checking for mpz_xor" >&5 +echo "configure:3783: checking for mpz_xor" >&5 if eval "test \"`echo '$''{'yap_mpz_xor'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < void check(mpz_t rop,mpz_t op1,mpz_t op2) { @@ -3686,7 +3796,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:3690: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then +if { (eval echo configure:3800: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then rm -rf conftest* yap_mpz_xor=yes else @@ -3713,6 +3823,7 @@ EOF fi mkdir -p library/regex +mkdir -p library/system trap '' 1 2 15 cat > confcache <<\EOF @@ -3815,7 +3926,7 @@ done ac_given_srcdir=$srcdir ac_given_INSTALL="$INSTALL" -trap 'rm -fr `echo "Makefile library/regex/Makefile .depend config.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +trap 'rm -fr `echo "Makefile library/regex/Makefile library/system/Makefile .depend config.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 EOF cat >> $CONFIG_STATUS <> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then diff --git a/configure.in b/configure.in index 2f56e250e..f019bb4fb 100644 --- a/configure.in +++ b/configure.in @@ -395,7 +395,7 @@ AC_CHECK_HEADERS(sys/param.h errno.h netdb.h netinet/in.h arpa/inet.h) AC_CHECK_HEADERS(string.h memory.h sys/mman.h sys/stat.h stdarg.h ctype.h) AC_CHECK_HEADERS(sys/resource.h limits.h siginfo.h time.h fenv.h) AC_CHECK_HEADERS(fpu_control.h sys/shm.h regex.h winsock.h winsock2.h) -AC_CHECK_HEADERS(sys/select.h direct.h) +AC_CHECK_HEADERS(sys/select.h direct.h dirent.h signal.h) if test "$yap_cv_gmp" != "no" then AC_CHECK_HEADERS(gmp.h) @@ -567,7 +567,9 @@ AC_CHECK_FUNCS(snprintf vsnprintf setbuf system link getpwnam dup2 sigprocmask) AC_CHECK_FUNCS(labs strncat tmpnam getenv gettimeofday gethrtime putenv) AC_CHECK_FUNCS(strerror socket memmove alarm asinh acosh atanh rint) AC_CHECK_FUNCS(stat select fetestexcept finite strncpy mkstemp isnan) -AC_CHECK_FUNCS(setlinebuf) +AC_CHECK_FUNCS(setlinebuf lstat opendir localtime time gethostname) +AC_CHECK_FUNCS(gethostid gethostbyname kill mktemp popen rename waitpid) +AC_CHECK_FUNCS(sleep usleep) dnl check for mpz_xor AC_MSG_CHECKING(for mpz_xor) @@ -589,8 +591,9 @@ AC_DEFINE(HAVE_MPZ_XOR,0) fi mkdir -p library/regex +mkdir -p library/system -AC_OUTPUT(Makefile library/regex/Makefile .depend) +AC_OUTPUT(Makefile library/regex/Makefile library/system/Makefile .depend) make depend diff --git a/docs/yap.tex b/docs/yap.tex index d5047b9b3..35838491a 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -3250,7 +3250,8 @@ YAP currently ignores these options. @cnindex current_stream/3 Defines the relation: The stream @var{S} is opened on the file @var{F} in mode @var{M}. It might be used to obtain all open streams (by -backtracking) or to access the stream for a file @var{F} in mode @var{M}. +backtracking), to access the stream for a file @var{F} in mode @var{M}, +or to find properties for a stream @var{S}. @item flush_output [ISO] @findex flush_output/0 @@ -11521,7 +11522,7 @@ void init_my_predicates() The commands to compile the above file depend on the operating system. Under Linux (i386 and Alpha) you should use: @example - gcc -c -shared -fPIC my_process.c -o my_process.o + gcc -c -shared -fPIC my_process.c ld -shared -o my_process.so my_process.o @end example @noindent diff --git a/include/c_interface.h b/include/c_interface.h index ed6edd57d..260922627 100644 --- a/include/c_interface.h +++ b/include/c_interface.h @@ -504,6 +504,24 @@ static void (YapIStringToBuffer)() = YapStringToBuffer; #define StringToBuffer(T,BUF,SIZE) YapStringToBuffer(T,BUF,SIZE) #endif +/* int BufferToString(char *) */ +extern X_API Term PROTO(YapBufferToString,(char *)); +#ifdef IndirectCalls +static void (YapIBufferToString)() = YapBufferToString; +#define BufferToString(BUF) (*YapIBufferToString)(BUF) +#else +#define BufferToString(BUF) YapBufferToString(BUF) +#endif + +/* int BufferToAtomList(char *) */ +extern X_API Term PROTO(YapBufferToAtomList,(char *)); +#ifdef IndirectCalls +static void (YapIBufferToAtomList)() = YapBufferToAtomList; +#define BufferToAtomList(BUF) (*YapIBufferToAtomList)(BUF) +#else +#define BufferToAtomList(BUF) YapBufferToAtomList(BUF) +#endif + /* void YapInitSocks(char *,long) */ extern X_API int PROTO(YapInitSocks,(char *,long)); #ifdef IndirectCalls @@ -534,6 +552,36 @@ static void (*YapISetOutputMessage)() = YapSetOutputMessage; #define YapSetOutputMessage() (*YapISetOutputMessage)() #endif +/* Term YapSetOutputMessage() */ +extern X_API int PROTO(YapStreamToFileNo,(Term)); +#ifdef IndirectCalls +static void (*YapIStreamToFileNo)() = YapStreamToFileNo; +#define YapStreamToFileNo() (*YapIStreamToFileNo)() +#endif + +/* Term YapSetOutputMessage() */ +extern X_API void PROTO(YapCloseAllOpenStreams,(void)); +#ifdef IndirectCalls +static void (*YapICloseAllOpenStreams)() = YapCloseAllOpenStreams; +#define YapCloseAllOpenStreams() (*YapICloseAllOpenStreams)() +#endif + +#define YAP_INPUT_STREAM 0x01 +#define YAP_OUTPUT_STREAM 0x02 +#define YAP_APPEND_STREAM 0x04 +#define YAP_PIPE_STREAM 0x08 +#define YAP_TTY_STREAM 0x10 +#define YAP_POPEN_STREAM 0x20 +#define YAP_BINARY_STREAM 0x40 +#define YAP_SEEKABLE_STREAM 0x80 + +/* Term YapP() */ +extern X_API Term PROTO(YapOpenStream,(void *, char *, Term, int)); +#ifdef IndirectCalls +static Term (*YapIOpenStream)() = YapOpenStream; +#define YapOpenStream(FD,S,T,FL) (*YapIOpenStream)(FD,S,T,FL) +#endif + #define InitCPred(N,A,F) UserCPredicate(N,F,A) diff --git a/misc/yap.def b/misc/yap.def index a87d9b114..e927d8e16 100644 --- a/misc/yap.def +++ b/misc/yap.def @@ -42,6 +42,8 @@ Yapcut_succeed YapAllocSpaceFromYap YapFreeSpaceFromYap YapStringToBuffer +YapBufferToString +YapBufferToAtomList YapError YapRunGoal YapContinueGoal @@ -58,4 +60,6 @@ YapSetOutputMessage YapWrite YapInitConsult YapEndConsult - +YapStreamToFileNo +YapCloseAllOpenStreams +YapOpenStream diff --git a/pl/arith.yap b/pl/arith.yap index 6b947e16e..e061a074a 100644 --- a/pl/arith.yap +++ b/pl/arith.yap @@ -36,6 +36,11 @@ do_not_compile_expressions :- '$set_value'('$c_arith',[]). '$c_built_in'(IN, IN). +'$do_c_built_in'(\+ G, OUT) :- + nonvar(G), + G = (A = B), + !, + OUT = (A \= B). '$do_c_built_in'(recorded(K,T,R), OUT) :- nonvar(K), !, diff --git a/pl/boot.yap b/pl/boot.yap index a7b7d6f6e..49949fd9f 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -116,7 +116,8 @@ set_output(Stream) :- 8 use portray(_) */ -write(T) :- current_output(S), '$write'(S,4,T). +write(T) :- current_output(S), '$write'(S,4,T), fail. +write(_). write(Stream,T) :- '$write'(Stream,4,T), @@ -127,7 +128,8 @@ put(Stream,N) :- N1 is N, '$put'(Stream,N1). nl(Stream) :- '$put'(Stream,10). -nl :- current_output(Stream), '$put'(Stream,10). +nl :- current_output(Stream), '$put'(Stream,10), fail. +nl. /* main execution loop */ '$read_vars'(Stream,T,V) :- @@ -1049,7 +1051,7 @@ add_to_path(New) :- add_to_path(New,last). add_to_path(New,Pos) :- '$check_path'(New,Str), '$add_to_path'(Str,Pos). '$add_to_path'(New,_) :- '$recorded'('$path',New,R), erase(R), fail. -'$add_to_path'(New,last) :- '$recordz'('$path',New,_). +'$add_to_path'(New,last) :- !, '$recordz'('$path',New,_). '$add_to_path'(New,first) :- '$recorda'('$path',New,_). remove_from_path(New) :- '$check_path'(New,Path), diff --git a/pl/errors.yap b/pl/errors.yap index 0b840e629..4ec5548cf 100644 --- a/pl/errors.yap +++ b/pl/errors.yap @@ -101,6 +101,9 @@ print_message(help,M) :- '$output_error_message'(domain_error(character_code_list,Opt), Where) :- format(user_error,"[ DOMAIN ERROR- ~w: invalid list of codes ~w ]~n", [Where,Opt]). +'$output_error_message'(domain_error(delete_file_option,Opt), Where) :- + format(user_error,"[ DOMAIN ERROR- ~w: invalid list of options ~w ]~n", + [Where,Opt]). '$output_error_message'(domain_error(operator_specifier,Op), Where) :- format(user_error,"[ DOMAIN ERROR- ~w: invalid operator specifier ~w ]~n", [Where,Op]). @@ -284,6 +287,9 @@ print_message(help,M) :- '$output_error_message'(system_error, Where) :- format(user_error,"[ SYSTEM ERROR- ~w ]~n", [Where]). +'$output_error_message'(system_error(Message), Where) :- + format(user_error,"[ SYSTEM ERROR- ~w at ~w]~n", + [Message,Where]). '$output_error_message'(type_error(T,_,Err,M), Where) :- format(user_error,"[ TYPE ERROR- ~w: expected ~w, got ~w ]~n", [T,Err,M]). diff --git a/pl/preds.yap b/pl/preds.yap index d017e358b..86fa94e0e 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -61,6 +61,7 @@ assert(C) :- '$assert'(C,last,_,assert(C)). throw(error(permission_error(modify,static_procedure,Na/Ar),P)) ). + '$assert_dynamic'(V,Where,R,P) :- var(V), !, '$current_module'(M), throw(error(instantiation_error,P)). diff --git a/pl/tabling.yap b/pl/tabling.yap index 22f6aa2c2..c49599326 100644 --- a/pl/tabling.yap +++ b/pl/tabling.yap @@ -51,7 +51,7 @@ show_trie(X) :- var(X), !, show_trie(A/N) :- integer(N), atom(A), !, functor(T,A,N), $flags(T,F,F), ( - X is F /\ 8'000100, X =\= 0, !, $show_trie(T) + X is F /\ 8'000100, X =\= 0, !, $show_trie(T,_) ; write(user_error, '[ Error: '), write(user_error, A/N), diff --git a/pl/utils.yap b/pl/utils.yap index 4f494299d..d3ae190d3 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -249,26 +249,6 @@ rename(Old,New) :- atom(Old), atom(New), !, name(Old,SOld), name(New,SNew), '$rename'(SOld,SNew). -environ(Na,Val) :- atom(Na), !, - '$getenv'(Na,Val). -environ(Na,Val) :- - '$environ_enum'(0,I), - ( '$environ'(I,S) -> '$environ_split'(S,SNa,SVal) ; !, fail ), - atom_codes(Na, SNa), - atom_codes(Val, SVal). - -'$environ_enum'(X,X). -'$environ_enum'(X,X1) :- - Xi is X+1, - '$environ_enum'(Xi,X1). - -'$environ_split'([61|SVal], [], SVal) :- !. -'$environ_split'([C|S],[C|SNa],SVal) :- - '$environ_split'(S,SNa,SVal). - -putenv(Na,Val) :- - '$putenv'(Na,Val). - unix(V) :- var(V), !, throw(error(instantiation_error,unix(V))). unix(argv(L)) :- (var(L) ; atom(L)), !, '$argv'(L). @@ -280,7 +260,7 @@ unix(cd(V)) :- var(V), !, unix(cd(A)) :- atomic(A), !, cd(A). unix(cd(V)) :- throw(error(type_error(atomic,V),unix(cd(V)))). -unix(environ(X,Y)) :- environ(X,Y). +unix(environ(X,Y)) :- do_environ(X,Y). unix(getcwd(X)) :- getcwd(X). unix(shell(V)) :- var(V), !, throw(error(instantiation_error,unix(shell(V)))). @@ -295,6 +275,11 @@ unix(system(V)) :- unix(shell) :- sh. unix(putenv(X,Y)) :- '$putenv'(X,Y). +putenv(Na,Val) :- + '$putenv'(Na,Val). + +getenv(Na,Val) :- + '$getenv'(Na,Val). alarm(_, _, _) :- recorded('$alarm_handler',_, Ref), erase(Ref), fail. diff --git a/pl/yio.yap b/pl/yio.yap index 446cf1d40..7ccc39c7b 100644 --- a/pl/yio.yap +++ b/pl/yio.yap @@ -236,6 +236,8 @@ open(F,T,S,Opts) :- open_null_stream(S) :- '$open_null_stream'(S). +open_pipe_streams(P1,P2) :- '$open_pipe_stream'(P1, P2). + fileerrors :- '$set_value'(fileerrors,1). nofileerrors :- '$set_value'(fileerrors,0).