From 1fa46c6051de79b9232bfc720a627aedf7f302be Mon Sep 17 00:00:00 2001 From: vsc Date: Fri, 28 Oct 2005 17:38:50 +0000 Subject: [PATCH] sveral updates git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1415 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/absmi.c | 245 +++++++++++++++++++++++++----------------- C/adtdefs.c | 1 + C/agc.c | 1 + C/arrays.c | 199 ++++++++++++++++++++++++++++++---- C/attvar.c | 8 +- C/c_interface.c | 9 +- C/dbase.c | 24 +++-- C/exec.c | 165 ++++++++++++++++++++++++++++ C/grow.c | 61 +++++++---- C/heapgc.c | 83 +++++++------- C/init.c | 9 +- C/inlines.c | 18 +++- C/iopreds.c | 210 +++++++++++++++++++++++++----------- C/stdpreds.c | 35 +++++- C/sysbits.c | 12 ++- C/tracer.c | 8 ++ C/utilpreds.c | 2 +- H/Heap.h | 17 ++- H/Yapproto.h | 3 +- H/Yatom.h | 5 +- H/absmi.h | 14 +-- H/rheap.h | 31 ++++-- H/sshift.h | 9 ++ Makefile.in | 7 +- configure | 14 ++- configure.in | 7 +- include/yap_structs.h | 2 + library/Makefile.in | 2 + library/ordsets.yap | 12 ++- library/prandom.yap | 4 +- library/swi.yap | 59 +++++++++- library/ypp.yap | 4 +- pl/boot.yap | 67 ++++++++---- pl/checker.yap | 11 +- pl/consult.yap | 74 ++++++++----- pl/corout.yap | 4 +- pl/directives.yap | 31 ++++++ pl/errors.yap | 34 +++++- pl/modules.yap | 13 ++- pl/utils.yap | 29 ++++- pl/yio.yap | 54 ++++++++++ 41 files changed, 1241 insertions(+), 356 deletions(-) diff --git a/C/absmi.c b/C/absmi.c index f01d0f7ed..717420ad9 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -10,8 +10,38 @@ * * * File: absmi.c * * comments: Portable abstract machine interpreter * -* Last rev: $Date: 2005-10-18 17:04:43 $,$Author: vsc $ * +* Last rev: $Date: 2005-10-28 17:38:49 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.179 2005/10/18 17:04:43 vsc +* 5.1: +* - improvements to GC +* 2 generations +* generic speedups +* - new scheme for attvars +* - hProlog like interface also supported +* - SWI compatibility layer +* - extra predicates +* - global variables +* - moved to Prolog module +* - CLP(R) by Leslie De Koninck, Tom Schrijvers, Cristian Holzbaur, Bart +* Demoen and Jan Wielemacker +* - load_files/2 +* +* from 5.0.1 +* +* - WIN32 missing include files (untested) +* - -L trouble (my thanks to Takeyuchi Shiramoto-san)! +* - debugging of backtrable user-C preds would core dump. +* - redeclaring a C-predicate as Prolog core dumps. +* - badly protected YapInterface.h. +* - break/0 was failing at exit. +* - YAP_cut_fail and YAP_cut_succeed were different from manual. +* - tracing through data-bases could core dump. +* - cut could break on very large computations. +* - first pass at BigNum issues (reported by Roberto). +* - debugger could get go awol after fail port. +* - weird message on wrong debugger option. +* * Revision 1.178 2005/10/15 17:05:23 rslopes * enable profiling on amd64 * @@ -2055,7 +2085,7 @@ Yap_absmi(int inp) check_stack(NoStackExecute, H); #endif PREG = pt0->CodeOfPred; - E_YREG[E_CB] = d0; + ENV_YREG[E_CB] = d0; ENDD(d0); #ifdef DEPTH_LIMIT if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is prolog */ @@ -2117,29 +2147,29 @@ Yap_absmi(int inp) PREG = pt0->CodeOfPred; ALWAYS_LOOKAHEAD(pt0->OpcodeOfPred); /* do deallocate */ - CPREG = (yamop *) E_YREG[E_CP]; - E_YREG = ENV = (CELL *) E_YREG[E_E]; + CPREG = (yamop *) ENV_YREG[E_CP]; + ENV_YREG = ENV = (CELL *) ENV_YREG[E_E]; #ifdef FROZEN_STACKS { choiceptr top_b = PROTECT_FROZEN_B(B); #ifdef SBA - if (E_YREG > (CELL *) top_b || E_YREG < H) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; #else - if (E_YREG > (CELL *) top_b) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; #endif /* SBA */ - else E_YREG = (CELL *)((CELL)E_YREG + ENV_Size(CPREG)); + else ENV_YREG = (CELL *)((CELL)ENV_YREG + ENV_Size(CPREG)); } #else - if (E_YREG > (CELL *)B) { - E_YREG = (CELL *)B; + if (ENV_YREG > (CELL *)B) { + ENV_YREG = (CELL *)B; } else { - E_YREG = (CELL *) ((CELL) E_YREG + ENV_Size(CPREG)); + ENV_YREG = (CELL *) ((CELL) ENV_YREG + ENV_Size(CPREG)); } #endif /* FROZEN_STACKS */ WRITEBACK_Y_AS_ENV(); /* setup GB */ - E_YREG[E_CB] = (CELL) B; + ENV_YREG[E_CB] = (CELL) B; ALWAYS_GONext(); ALWAYS_END_PREFETCH(); } @@ -2148,10 +2178,10 @@ Yap_absmi(int inp) BOp(fcall, sla); CACHE_Y_AS_ENV(YREG); - E_YREG[E_CP] = (CELL) CPREG; - E_YREG[E_E] = (CELL) ENV; + ENV_YREG[E_CP] = (CELL) CPREG; + ENV_YREG[E_E] = (CELL) ENV; #ifdef DEPTH_LIMIT - E_YREG[E_DEPTH] = DEPTH; + ENV_YREG[E_DEPTH] = DEPTH; #endif /* DEPTH_LIMIT */ ENDCACHE_Y_AS_ENV(); ENDBOp(); @@ -2169,9 +2199,9 @@ Yap_absmi(int inp) #ifndef NO_CHECKING check_stack(NoStackCall, H); #endif - ENV = E_YREG; + ENV = ENV_YREG; /* Try to preserve the environment */ - E_YREG = (CELL *) (((char *) E_YREG) + PREG->u.sla.s); + ENV_YREG = (CELL *) (((char *) ENV_YREG) + PREG->u.sla.s); CPREG = NEXTOP(PREG, sla); ALWAYS_LOOKAHEAD(pt->OpcodeOfPred); PREG = pt->CodeOfPred; @@ -2189,19 +2219,19 @@ Yap_absmi(int inp) { choiceptr top_b = PROTECT_FROZEN_B(B); #ifdef SBA - if (E_YREG > (CELL *) top_b || E_YREG < H) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; #else - if (E_YREG > (CELL *) top_b) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; #endif /* SBA */ } #else - if (E_YREG > (CELL *) B) { - E_YREG = (CELL *) B; + if (ENV_YREG > (CELL *) B) { + ENV_YREG = (CELL *) B; } #endif /* FROZEN_STACKS */ WRITEBACK_Y_AS_ENV(); /* setup GB */ - E_YREG[E_CB] = (CELL) B; + ENV_YREG[E_CB] = (CELL) B; #ifdef YAPOR SCH_check_requests(); #endif /* YAPOR */ @@ -2218,9 +2248,9 @@ Yap_absmi(int inp) if (ap->PredFlags & HiddenPredFlag) { CACHE_Y_AS_ENV(YREG); CACHE_A1(); - ENV = E_YREG; + ENV = ENV_YREG; /* Try to preserve the environment */ - E_YREG = (CELL *) (((char *) YREG) + PREG->u.sla.s); + ENV_YREG = (CELL *) (((char *) YREG) + PREG->u.sla.s); CPREG = NEXTOP(PREG, sla); ALWAYS_LOOKAHEAD(ap->OpcodeOfPred); PREG = ap->CodeOfPred; @@ -2229,19 +2259,19 @@ Yap_absmi(int inp) { choiceptr top_b = PROTECT_FROZEN_B(B); #ifdef SBA - if (E_YREG > (CELL *) top_b || E_YREG < H) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; #else - if (E_YREG > (CELL *) top_b) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; #endif } #else - if (E_YREG > (CELL *) B) { - E_YREG = (CELL *) B; + if (ENV_YREG > (CELL *) B) { + ENV_YREG = (CELL *) B; } #endif /* FROZEN_STACKS */ WRITEBACK_Y_AS_ENV(); /* setup GB */ - E_YREG[E_CB] = (CELL) B; + ENV_YREG[E_CB] = (CELL) B; #ifdef YAPOR SCH_check_requests(); #endif /* YAPOR */ @@ -2341,10 +2371,10 @@ Yap_absmi(int inp) { /* fill it up */ CACHE_Y_AS_ENV(YREG); - E_YREG[E_CP] = (CELL) CPREG; - E_YREG[E_E] = (CELL) ENV; + ENV_YREG[E_CP] = (CELL) CPREG; + ENV_YREG[E_E] = (CELL) ENV; #ifdef DEPTH_LIMIT - E_YREG[E_DEPTH] = DEPTH; + ENV_YREG[E_DEPTH] = DEPTH; #endif /* DEPTH_LIMIT */ ENDCACHE_Y_AS_ENV(); } @@ -2443,29 +2473,29 @@ Yap_absmi(int inp) PREG = ap->CodeOfPred; ALWAYS_LOOKAHEAD(ap->OpcodeOfPred); /* do deallocate */ - CPREG = (yamop *) E_YREG[E_CP]; - E_YREG = ENV = (CELL *) E_YREG[E_E]; + CPREG = (yamop *) ENV_YREG[E_CP]; + ENV_YREG = ENV = (CELL *) ENV_YREG[E_E]; #ifdef FROZEN_STACKS { choiceptr top_b = PROTECT_FROZEN_B(B); #ifdef SBA - if (E_YREG > (CELL *) top_b || E_YREG < H) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; #else - if (E_YREG > (CELL *) top_b) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; #endif - else E_YREG = (CELL *)((CELL)E_YREG + ENV_Size(CPREG)); + else ENV_YREG = (CELL *)((CELL)ENV_YREG + ENV_Size(CPREG)); } #else - if (E_YREG > (CELL *)B) { - E_YREG = (CELL *)B; + if (ENV_YREG > (CELL *)B) { + ENV_YREG = (CELL *)B; } else { - E_YREG = (CELL *) ((CELL) E_YREG + ENV_Size(CPREG)); + ENV_YREG = (CELL *) ((CELL) ENV_YREG + ENV_Size(CPREG)); } #endif /* FROZEN_STACKS */ WRITEBACK_Y_AS_ENV(); /* setup GB */ - E_YREG[E_CB] = (CELL) B; + ENV_YREG[E_CB] = (CELL) B; ALWAYS_GONext(); ALWAYS_END_PREFETCH(); ENDCACHE_Y_AS_ENV(); @@ -2640,9 +2670,9 @@ Yap_absmi(int inp) BOp(procceed, e); CACHE_Y_AS_ENV(YREG); PREG = CPREG; - E_YREG = ENV; + ENV_YREG = ENV; #ifdef DEPTH_LIMIT - DEPTH = E_YREG[E_DEPTH]; + DEPTH = ENV_YREG[E_DEPTH]; #endif WRITEBACK_Y_AS_ENV(); JMPNext(); @@ -2652,12 +2682,12 @@ Yap_absmi(int inp) Op(allocate, e); CACHE_Y_AS_ENV(YREG); PREG = NEXTOP(PREG, e); - E_YREG[E_CP] = (CELL) CPREG; - E_YREG[E_E] = (CELL) ENV; + ENV_YREG[E_CP] = (CELL) CPREG; + ENV_YREG[E_E] = (CELL) ENV; #ifdef DEPTH_LIMIT - E_YREG[E_DEPTH] = DEPTH; + ENV_YREG[E_DEPTH] = DEPTH; #endif /* DEPTH_LIMIT */ - ENV = E_YREG; + ENV = ENV_YREG; ENDCACHE_Y_AS_ENV(); GONext(); ENDOp(); @@ -2668,26 +2698,26 @@ Yap_absmi(int inp) /* other instructions do depend on S being set by deallocate :-( */ SREG = YREG; - CPREG = (yamop *) E_YREG[E_CP]; - ENV = E_YREG = (CELL *) E_YREG[E_E]; + CPREG = (yamop *) ENV_YREG[E_CP]; + ENV = ENV_YREG = (CELL *) ENV_YREG[E_E]; #ifdef DEPTH_LIMIT - DEPTH = E_YREG[E_DEPTH]; + DEPTH = ENV_YREG[E_DEPTH]; #endif /* DEPTH_LIMIT */ #ifdef FROZEN_STACKS { choiceptr top_b = PROTECT_FROZEN_B(B); #ifdef SBA - if (E_YREG > (CELL *) top_b || E_YREG < H) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; #else - if (E_YREG > (CELL *) top_b) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; #endif /* SBA */ - else E_YREG = (CELL *)((CELL) E_YREG + ENV_Size(CPREG)); + else ENV_YREG = (CELL *)((CELL) ENV_YREG + ENV_Size(CPREG)); } #else - if (E_YREG > (CELL *) B) - E_YREG = (CELL *) B; + if (ENV_YREG > (CELL *) B) + ENV_YREG = (CELL *) B; else - E_YREG = (CELL *) ((CELL) E_YREG + ENV_Size(CPREG)); + ENV_YREG = (CELL *) ((CELL) ENV_YREG + ENV_Size(CPREG)); #endif /* FROZEN_STACKS */ WRITEBACK_Y_AS_ENV(); #ifndef NO_CHECKING @@ -6682,6 +6712,12 @@ Yap_absmi(int inp) BOp(call_cpred, sla); + + if (!(P->u.sla.sla_u.p->PredFlags & ( SafePredFlag|HiddenPredFlag))) { + CACHE_Y_AS_ENV(YREG); + check_stack(NoStackCall, H); + ENDCACHE_Y_AS_ENV(); + } #ifdef FROZEN_STACKS { choiceptr top_b = PROTECT_FROZEN_B(B); @@ -6724,6 +6760,11 @@ Yap_absmi(int inp) /* guarantee that *all* machine registers are saved and */ /* restored */ BOp(call_usercpred, sla); +#ifdef COROUTINING + CACHE_Y_AS_ENV(YREG); + check_stack(NoStackCall, H); + ENDCACHE_Y_AS_ENV(); +#endif #ifdef FROZEN_STACKS { choiceptr top_b = PROTECT_FROZEN_B(B); @@ -10364,10 +10405,17 @@ Yap_absmi(int inp) B = (choiceptr) H; SET_BB(B); save_hb(); - if (Yap_IUnify(d0, d1) == TRUE) { + if (Yap_IUnify(d0, d1)) { /* restore B, no need to restore HB */ PREG = PREG->u.l.l; B = pt1; +#ifdef COROUTINING + /* now restore Woken Goals to its old value */ + Yap_UpdateTimedVar(WokenGoals, OldWokenGoals); + if (OldWokenGoals == TermNil) { + Yap_undo_signal(YAP_WAKEUP_SIGNAL); + } +#endif GONext(); } /* restore B, and later HB */ @@ -10409,6 +10457,9 @@ Yap_absmi(int inp) #ifdef COROUTINING /* now restore Woken Goals to its old value */ Yap_UpdateTimedVar(WokenGoals, OldWokenGoals); + if (OldWokenGoals == TermNil) { + Yap_undo_signal(YAP_WAKEUP_SIGNAL); + } #endif } GONext(); @@ -12103,19 +12154,19 @@ Yap_absmi(int inp) CACHE_Y_AS_ENV(YREG); /* Try to preserve the environment */ - E_YREG = (CELL *) (((char *) YREG) + PREG->u.sla.s); + ENV_YREG = (CELL *) (((char *) YREG) + PREG->u.sla.s); #ifdef FROZEN_STACKS { choiceptr top_b = PROTECT_FROZEN_B(B); #ifdef SBA - if (E_YREG > (CELL *) top_b || E_YREG < H) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; #else - if (E_YREG > (CELL *) top_b) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; #endif /* SBA */ } #else - if (E_YREG > (CELL *) B) { - E_YREG = (CELL *) B; + if (ENV_YREG > (CELL *) B) { + ENV_YREG = (CELL *) B; } #endif /* FROZEN_STACKS */ BEGD(d0); @@ -12145,29 +12196,29 @@ Yap_absmi(int inp) deref_head(d1, execute_comma_unk); execute_comma_nvar: if (IsAtomTerm(d1)) { - E_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByAtom(AtomOfTerm(d1),mod)); - E_YREG[-EnvSizeInCells-3] = mod; + ENV_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByAtom(AtomOfTerm(d1),mod)); + ENV_YREG[-EnvSizeInCells-3] = mod; } else if (IsApplTerm(d1)) { Functor f = FunctorOfTerm(d1); if (IsExtensionFunctor(f)) { goto execute_metacall; } else { if (f == FunctorModule) goto execute_metacall; - E_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByFunc(f,mod)); - E_YREG[-EnvSizeInCells-3] = mod; + ENV_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByFunc(f,mod)); + ENV_YREG[-EnvSizeInCells-3] = mod; } } else { goto execute_metacall; } - E_YREG[E_CP] = (CELL)NEXTOP(PREG,sla); - E_YREG[E_CB] = (CELL)B; - E_YREG[E_E] = (CELL)ENV; + ENV_YREG[E_CP] = (CELL)NEXTOP(PREG,sla); + ENV_YREG[E_CB] = (CELL)B; + ENV_YREG[E_E] = (CELL)ENV; #ifdef DEPTH_LIMIT - E_YREG[E_DEPTH] = DEPTH; + ENV_YREG[E_DEPTH] = DEPTH; #endif /* DEPTH_LIMIT */ - E_YREG[-EnvSizeInCells-1] = d1; - ENV = E_YREG; - E_YREG -= EnvSizeInCells+3; + ENV_YREG[-EnvSizeInCells-1] = d1; + ENV = ENV_YREG; + ENV_YREG -= EnvSizeInCells+3; PREG = COMMA_CODE; d0 = SREG[1]; goto restart_execute; @@ -12238,7 +12289,7 @@ Yap_absmi(int inp) #endif /* LOW_LEVEL_TRACER */ WRITEBACK_Y_AS_ENV(); /* setup GB */ - E_YREG[E_CB] = (CELL) B; + ENV_YREG[E_CB] = (CELL) B; #ifdef YAPOR SCH_check_requests(); #endif /* YAPOR */ @@ -12262,7 +12313,7 @@ Yap_absmi(int inp) ENDD(d0); NoStackPExecute: SREG = (CELL *) pen; - ASP = E_YREG; + ASP = ENV_YREG; /* setup GB */ WRITEBACK_Y_AS_ENV(); YREG[E_CB] = (CELL) B; @@ -12292,27 +12343,27 @@ Yap_absmi(int inp) CACHE_Y_AS_ENV(YREG); BEGP(pt0); BEGD(d0); - d0 = E_YREG[-EnvSizeInCells-1]; - pen = RepPredProp((Prop)IntegerOfTerm(E_YREG[-EnvSizeInCells-2])); - CPREG = (yamop *) E_YREG[E_CP]; - pt0 = E_YREG; - E_YREG = ENV = (CELL *) E_YREG[E_E]; + d0 = ENV_YREG[-EnvSizeInCells-1]; + pen = RepPredProp((Prop)IntegerOfTerm(ENV_YREG[-EnvSizeInCells-2])); + CPREG = (yamop *) ENV_YREG[E_CP]; + pt0 = ENV_YREG; + ENV_YREG = ENV = (CELL *) ENV_YREG[E_E]; #ifdef FROZEN_STACKS { choiceptr top_b = PROTECT_FROZEN_B(B); #ifdef SBA - if (E_YREG > (CELL *) top_b || E_YREG < H) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; #else - if (E_YREG > (CELL *) top_b) E_YREG = (CELL *) top_b; + if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; #endif /* SBA */ - else E_YREG = (CELL *)((CELL)E_YREG + ENV_Size(CPREG)); + else ENV_YREG = (CELL *)((CELL)ENV_YREG + ENV_Size(CPREG)); } #else - if (E_YREG > (CELL *)B) { - E_YREG = (CELL *)B; + if (ENV_YREG > (CELL *)B) { + ENV_YREG = (CELL *)B; } else { - E_YREG = (CELL *) ((CELL) E_YREG+ ENV_Size(CPREG)); + ENV_YREG = (CELL *) ((CELL) ENV_YREG+ ENV_Size(CPREG)); } #endif /* FROZEN_STACKS */ arity = pen->ArityOfPE; @@ -12326,9 +12377,9 @@ Yap_absmi(int inp) /* create an to execute the call */ deref_head(d1, execute_comma_comma_unk); execute_comma_comma_nvar: - E_YREG[E_CB] = (CELL)pt0[E_CB]; + ENV_YREG[E_CB] = (CELL)pt0[E_CB]; if (IsAtomTerm(d1)) { - E_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByAtom(AtomOfTerm(d1),mod)); + ENV_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByAtom(AtomOfTerm(d1),mod)); } else if (IsApplTerm(d1)) { Functor f = FunctorOfTerm(d1); if (IsExtensionFunctor(f)) { @@ -12341,20 +12392,20 @@ Yap_absmi(int inp) d1 = RepAppl(d1)[2]; goto execute_comma_comma; } else { - E_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByFunc(f,mod)); + ENV_YREG[-EnvSizeInCells-2] = MkIntegerTerm((Int)PredPropByFunc(f,mod)); } } else { goto execute_metacall_after_comma; } - E_YREG[E_CP] = (CELL)CPREG; - E_YREG[E_E] = (CELL)ENV; + ENV_YREG[E_CP] = (CELL)CPREG; + ENV_YREG[E_E] = (CELL)ENV; #ifdef DEPTH_LIMIT - E_YREG[E_DEPTH] = DEPTH; + ENV_YREG[E_DEPTH] = DEPTH; #endif /* DEPTH_LIMIT */ - E_YREG[-EnvSizeInCells-1] = d1; - E_YREG[-EnvSizeInCells-3] = mod; - ENV = E_YREG; - E_YREG -= EnvSizeInCells+3; + ENV_YREG[-EnvSizeInCells-1] = d1; + ENV_YREG[-EnvSizeInCells-3] = mod; + ENV = ENV_YREG; + ENV_YREG -= EnvSizeInCells+3; d0 = SREG[1]; CPREG = NEXTOP(COMMA_CODE,sla); execute_comma_comma2: @@ -12480,7 +12531,7 @@ Yap_absmi(int inp) #endif PREG = pen->CodeOfPred; ALWAYS_LOOKAHEAD(pen->OpcodeOfPred); - E_YREG[E_CB] = (CELL)B; + ENV_YREG[E_CB] = (CELL)B; #ifdef LOW_LEVEL_TRACER if (Yap_do_low_level_trace) low_level_trace(enter_pred,pen,XREGS+1); @@ -12506,7 +12557,7 @@ Yap_absmi(int inp) NoStackPTExecute: WRITEBACK_Y_AS_ENV(); SREG = (CELL *) pen; - ASP = E_YREG; + ASP = ENV_YREG; if (ASP > (CELL *)B) ASP = (CELL *)B; LOCK(SignalLock); diff --git a/C/adtdefs.c b/C/adtdefs.c index b445b23b7..4ab5bfedb 100644 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -231,6 +231,7 @@ Yap_LookupAtomWithAddress(char *atom, AtomEntry *ae) return; } /* add new atom to start of chain */ + NOfAtoms++; ae->NextOfAE = a; HashChain[hash].Entry = AbsAtom(ae); ae->PropsOfAE = NIL; diff --git a/C/agc.c b/C/agc.c index 78e5189ce..36816fff8 100644 --- a/C/agc.c +++ b/C/agc.c @@ -133,6 +133,7 @@ AtomAdjust(Atom a) #define PtoLUCAdjust(P) (P) #define PtoStCAdjust(P) (P) #define PtoArrayEAdjust(P) (P) +#define PtoArraySAdjust(P) (P) #define PtoDelayAdjust(P) (P) #define PtoGloAdjust(P) (P) #define PtoLocAdjust(P) (P) diff --git a/C/arrays.c b/C/arrays.c index 96bf2f99c..f4a2fcc26 100644 --- a/C/arrays.c +++ b/C/arrays.c @@ -140,6 +140,7 @@ STATIC_PROTO(Int p_resize_static_array, (void)); STATIC_PROTO(Int p_close_static_array, (void)); STATIC_PROTO(Int p_access_array, (void)); STATIC_PROTO(Int p_assign_static, (void)); +STATIC_PROTO(Int p_assign_dynamic, (void)); static Term GetTermFromArray(DBTerm *ref) @@ -156,7 +157,7 @@ GetTermFromArray(DBTerm *ref) } } else { Yap_Error_TYPE = YAP_NO_ERROR; - if (!Yap_gc(3, ENV, CP)) { + if (!Yap_gc(3, ENV, P)) { Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); return TermNil; } @@ -174,25 +175,32 @@ GetNBTerm(live_term *ar, Int indx) { /* The object is now in use */ Term livet = ar[indx].tlive; - Term termt = ar[indx].tstore; - if (!IsVarTerm(livet) - || !IsUnboundVar(&(ar[indx].tlive))) { - return livet; - } - if (IsVarTerm(termt)) { - Term livet = MkVarTerm(); - MaBind(&(ar[indx].tlive), livet); - return livet; - } else if (IsAtomicTerm(termt)) { - MaBind(&(ar[indx].tlive), termt); - return termt; - } else { - DBTerm *ref = (DBTerm *)RepAppl(termt); - if ((livet = GetTermFromArray(ref)) == TermNil) { - return TermNil; + if (!IsVarTerm(livet)) { + if (!IsApplTerm(livet)) { + return livet; + } else if (FunctorOfTerm(livet) == FunctorAtFoundOne) { + return Yap_ReadTimedVar(livet); + } else { + return livet; } - MaBind(&(ar[indx].tlive), livet); + } else { + Term termt = ar[indx].tstore; + + if (!IsUnboundVar(&(ar[indx].tlive))) { + return livet; + } + if (IsVarTerm(termt)) { + livet = MkVarTerm(); + } else if (IsAtomicTerm(termt)) { + livet = termt; + } else { + DBTerm *ref = (DBTerm *)RepAppl(termt); + if ((livet = GetTermFromArray(ref)) == TermNil) { + return TermNil; + } + } + Bind(&(ar[indx].tlive), livet); return livet; } } @@ -395,7 +403,7 @@ p_access_array(void) Yap_Error(INSTANTIATION_ERROR,t,"access_array"); return(FALSE); } - return (Yap_unify(tf, ARG3)); + return Yap_unify(tf, ARG3); } static Int @@ -478,9 +486,9 @@ CreateNamedArray(PropEntry * pp, Int dim, AtomEntry *ae) #if THREADS p->owner_id = worker_id; #endif + p->NextAE = DynamicArrays; + DynamicArrays = p; InitNamedArray(p, dim); - p->NextArrayE = DynArrayList; - DynArrayList = p; } @@ -542,6 +550,8 @@ CreateStaticArray(AtomEntry *ae, Int dim, static_array_types type, CODEADDR star p->ArrayEArity = -dim; p->ArrayType = type; ae->PropsOfAE = AbsArrayProp((ArrayEntry *)p); + p->NextAE = StaticArrays; + StaticArrays = p; WRITE_UNLOCK(ae->ARWLock); if (start_addr == NULL) { int i; @@ -761,7 +771,8 @@ p_create_array(void) WRITE_UNLOCK(ae->ARWLock); if (!IsVarTerm(app->ValueOfVE) || !IsUnboundVar(&app->ValueOfVE)) { - if (size == app->ArrayEArity) + if (size == app->ArrayEArity || + size == -app->ArrayEArity) return TRUE; Yap_Error(PERMISSION_ERROR_CREATE_ARRAY,t,"create_array", ae->StrOfAE); @@ -1723,7 +1734,7 @@ p_assign_static(void) Term told = ptr->ValueOfVE.lterms[indx].tstore; CELL *livep = &(ptr->ValueOfVE.lterms[indx].tlive); - MaBind(livep,(CELL)livep); + RESET_VARIABLE(livep); /* recover space */ if (IsApplTerm(told)) { Yap_ReleaseTermFromDB((DBTerm *)RepAppl(told)); @@ -1763,6 +1774,147 @@ p_assign_static(void) return(TRUE); } +static Int +p_assign_dynamic(void) +{ + Term t1, t2, t3; + StaticArrayEntry *ptr; + Int indx; + + t2 = Deref(ARG2); + if (IsNonVarTerm(t2)) { + if (IsIntTerm(t2)) + indx = IntOfTerm(t2); + else { + union arith_ret v; + if (Yap_Eval(t2, &v) == long_int_e) { + indx = v.Int; + } else { + Yap_Error(TYPE_ERROR_INTEGER,t2,"update_array"); + return (FALSE); + } + } + } else { + Yap_Error(INSTANTIATION_ERROR,t2,"update_array"); + return (FALSE); + } + t3 = Deref(ARG3); + + t1 = Deref(ARG1); + if (IsVarTerm(t1)) { + Yap_Error(INSTANTIATION_ERROR,t1,"update_array"); + return(FALSE); + } + if (!IsAtomTerm(t1)) { + if (IsApplTerm(t1)) { + CELL *ptr; + Functor f = FunctorOfTerm(t1); + /* store the terms to visit */ + if (IsExtensionFunctor(f)) { + Yap_Error(TYPE_ERROR_ARRAY,t1,"update_array"); + return(FALSE); + } + if (indx > 0 && indx > ArityOfFunctor(f)) { + Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"update_array"); + return(FALSE); + } + ptr = RepAppl(t1)+indx+1; +#ifdef MULTI_ASSIGNMENT_VARIABLES + MaBind(ptr, t3); + return(TRUE); +#else + Yap_Error(SYSTEM_ERROR,t2,"update_array"); + return(FALSE); +#endif + } else { + Yap_Error(TYPE_ERROR_ATOM,t1,"update_array"); + return(FALSE); + } + } + { + AtomEntry *ae = RepAtom(AtomOfTerm(t1)); + + READ_LOCK(ae->ARWLock); + ptr = RepStaticArrayProp(ae->PropsOfAE); + while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty) + ptr = RepStaticArrayProp(ptr->NextOfPE); + READ_UNLOCK(ae->ARWLock); + } + + if (EndOfPAEntr(ptr)) { + Yap_Error(EXISTENCE_ERROR_ARRAY,t1,"assign_static %s", RepAtom(AtomOfTerm(t1))->StrOfAE); + return(FALSE); + } + + WRITE_LOCK(ptr->ArRWLock); + if (ArrayIsDynamic((ArrayEntry *)ptr)) { + ArrayEntry *pp = (ArrayEntry *)ptr; + CELL *pt; + if (indx < 0 || indx >= pp->ArrayEArity) { + Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static"); + READ_UNLOCK(((ArrayEntry *)ptr)->ArRWLock); + return(FALSE); + } + pt = RepAppl(pp->ValueOfVE) + indx + 1; + WRITE_UNLOCK(((ArrayEntry *)ptr)->ArRWLock); +#ifdef MULTI_ASSIGNMENT_VARIABLES + /* the evil deed is to be done now */ + MaBind(pt, t3); + return(TRUE); +#else + Yap_Error(SYSTEM_ERROR,t2,"update_array"); + return FALSE; +#endif + } + + /* a static array */ + if (indx < 0 || indx >= - ptr->ArrayEArity) { + WRITE_UNLOCK(ptr->ArRWLock); + Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static"); + return(FALSE); + } + switch (ptr->ArrayType) { + case array_of_ints: + case array_of_chars: + case array_of_uchars: + case array_of_doubles: + case array_of_ptrs: + case array_of_atoms: + case array_of_dbrefs: + case array_of_terms: + WRITE_UNLOCK(ptr->ArRWLock); + Yap_Error(DOMAIN_ERROR_ARRAY_TYPE, t3, "assign_static"); + return FALSE; + + case array_of_nb_terms: +#ifdef MULTI_ASSIGNMENT_VARIABLES + { + Term t = ptr->ValueOfVE.lterms[indx].tlive; + Functor f; + /* we have a mutable term there */ + + if (IsVarTerm(t) || + !IsApplTerm(t) || + (f = FunctorOfTerm(t)) != FunctorAtFoundOne) { + Term tn = Yap_NewTimedVar(t3); + CELL *sp = RepAppl(tn); + *sp = (CELL)FunctorAtFoundOne; + Bind(&(ptr->ValueOfVE.lterms[indx].tlive),tn); + } else { + Yap_UpdateTimedVar(t, t3); + } + } + return TRUE; +#else + Yap_Error(SYSTEM_ERROR,t2,"update_array"); + return FALSE; +#endif + + } + WRITE_UNLOCK(ptr->ArRWLock); + return(TRUE); +} + static Int p_add_to_array_element(void) { @@ -2190,6 +2342,7 @@ Yap_InitArrayPreds(void) Yap_InitCPred("resize_static_array", 3, p_resize_static_array, SafePredFlag|SyncPredFlag); Yap_InitCPred("mmapped_array", 4, p_create_mmapped_array, SafePredFlag|SyncPredFlag); Yap_InitCPred("update_array", 3, p_assign_static, SafePredFlag); + Yap_InitCPred("dynamic_update_array", 3, p_assign_dynamic, SafePredFlag); Yap_InitCPred("add_to_array_element", 4, p_add_to_array_element, SafePredFlag); Yap_InitCPred("array_element", 3, p_access_array, 0); Yap_InitCPred("close_static_array", 1, p_close_static_array, SafePredFlag); diff --git a/C/attvar.c b/C/attvar.c index f6fb3cda2..0f0f45bdb 100644 --- a/C/attvar.c +++ b/C/attvar.c @@ -82,7 +82,13 @@ CopyAttVar(CELL *orig, CELL ***to_visit_ptr, CELL *res) vt = &(attv->Atts); to_visit[0] = vt-1; to_visit[1] = vt; - to_visit[2] = &(newv->Atts); + if (IsVarTerm(attv->Atts)) { + newv->Atts = (CELL)H; + to_visit[2] = H; + H++; + } else { + to_visit[2] = &(newv->Atts); + } to_visit[3] = (CELL *)vt[-1]; *to_visit_ptr = to_visit+4; *res = (CELL)&(newv->Done); diff --git a/C/c_interface.c b/C/c_interface.c index 144f9ee87..6dc5d930d 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -10,8 +10,11 @@ * File: c_interface.c * * comments: c_interface primitives definition * * * -* Last rev: $Date: 2005-10-21 16:07:07 $,$Author: vsc $ * +* Last rev: $Date: 2005-10-28 17:38:49 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.74 2005/10/21 16:07:07 vsc +* fix tabling +* * Revision 1.73 2005/10/18 17:04:43 vsc * 5.1: * - improvements to GC @@ -1255,6 +1258,9 @@ YAP_Init(YAP_init_args *yap_init) if (yap_init->YapPrologGoal) { Yap_PutValue(Yap_FullLookupAtom("$init_goal"), MkAtomTerm(Yap_LookupAtom(yap_init->YapPrologGoal))); } + if (yap_init->YapPrologAddPath) { + Yap_PutValue(Yap_FullLookupAtom("$extend_file_search_path"), MkAtomTerm(Yap_LookupAtom(yap_init->YapPrologAddPath))); + } if (yap_init->SavedState != NULL || yap_init->YapPrologBootFile == NULL) { if (restore_result == FAIL_RESTORE) { @@ -1287,6 +1293,7 @@ YAP_FastInit(char saved_state[]) init_args.YapPrologRCFile = NULL; init_args.YapPrologGoal = NULL; init_args.YapPrologTopLevelGoal = NULL; + init_args.YapPrologAddPath = NULL; init_args.HaltAfterConsult = FALSE; init_args.FastBoot = FALSE; init_args.NumberWorkers = 1; diff --git a/C/dbase.c b/C/dbase.c index d454d1667..acbd7dbb1 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -265,6 +265,16 @@ STATIC_PROTO(DBProp find_int_key, (Int)); } #endif +static UInt new_trail_size(void) +{ + UInt sz = (Yap_TrailTop-(ADDR)TR)/2; + if (sz < 64 * 1024L) + return 64 * 1024L; + if (sz > 1024*1024L) + return 1024*1024L; + return sz; +} + static int recover_from_record_error(int nargs) { @@ -276,7 +286,7 @@ recover_from_record_error(int nargs) } goto recover_record; case OUT_OF_TRAIL_ERROR: - if (!Yap_growtrail(64 * 1024L, FALSE)) { + if (!Yap_growtrail(new_trail_size(), FALSE)) { Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, "YAP could not grow trail in recorda/3"); return FALSE; } @@ -1005,9 +1015,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, #ifdef COROUTINING /* we still may have constraints to do */ if (ConstraintsTerm != TermNil && - !(RepAppl(ConstraintsTerm) >= tbase && - RepAppl(ConstraintsTerm) < StoPoint) - ) { + !IN_BETWEEN(tbase,RepAppl(ConstraintsTerm),CodeMax)) { *attachmentsp = (CELL)(CodeMax+1); pt0 = RepAppl(ConstraintsTerm)+1; pt0_end = RepAppl(ConstraintsTerm)+4; @@ -1025,7 +1033,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, #ifdef COROUTINING H = origH; #endif - return(CodeMax); + return CodeMax; error: Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR; @@ -1044,7 +1052,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, #ifdef COROUTINING H = origH; #endif - return(NULL); + return NULL; error2: Yap_Error_TYPE = OUT_OF_STACK_ERROR; @@ -1062,7 +1070,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, #ifdef COROUTINING H = origH; #endif - return(NULL); + return NULL; error_tr_overflow: Yap_Error_TYPE = OUT_OF_TRAIL_ERROR; @@ -1080,7 +1088,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, #ifdef COROUTINING H = origH; #endif - return(NULL); + return NULL; #if THREADS #undef Yap_REGS #define Yap_REGS (*Yap_regp) diff --git a/C/exec.c b/C/exec.c index cc84913c8..14dfb6e8f 100644 --- a/C/exec.c +++ b/C/exec.c @@ -214,6 +214,125 @@ do_execute(Term t, Term mod) } } +static Term +copy_execn_to_heap(Functor f, CELL *pt, unsigned int n, unsigned int arity, Term mod) +{ + CELL *h0 = H; + Term tf; + unsigned int i; + + if (arity == 2 && + NameOfFunctor(f) == AtomDot) { + for (i = 0; iPredFlags & (GoalExPredFlag|MetaPredFlag)) { + ARG1 = copy_execn_to_heap(f, pt, n, arity, mod); + return(CallMetaCall(mod)); + } + /* now let us do what we wanted to do from the beginning !! */ + /* I cannot use the standard macro here because + otherwise I would dereference the argument and + might skip a svar */ + for (i = 1; i <= arity-n; i++) { +#if SBA + Term d0 = *pt++; + if (d0 == 0) + XREGS[i] = (CELL)(pt-1); + else + XREGS[i] = d0; +#else + XREGS[i] = *pt++; +#endif + } + for (i = arity-n+1; i <= arity; i++,j++) { + XREGS[i] = H[j]; + } + return (CallPredicate(pen, B, pen->CodeOfPred)); +} + static Int EnterCreepMode(Term t, Term mod) { PredEntry *PredCreep; @@ -248,6 +367,49 @@ p_execute(void) return(do_execute(t, CurrentModule)); } +static void +heap_store(Term t) +{ + if (IsVarTerm(t)) { + if (VarOfTerm(t) < H) { + *H++ = t; + } else { + RESET_VARIABLE(H); + Bind_Local(VarOfTerm(t), (CELL)H); + H++; + } + } else { + *H++ = t; + } +} + +static Int +p_execute2(void) +{ /* '$execute'(Goal) */ + Term t = Deref(ARG1); + heap_store(Deref(ARG2)); + return(do_execute_n(t, CurrentModule, 1)); +} + +static Int +p_execute3(void) +{ /* '$execute'(Goal) */ + Term t = Deref(ARG1); + heap_store(Deref(ARG2)); + heap_store(Deref(ARG3)); + return(do_execute_n(t, CurrentModule, 2)); +} + +static Int +p_execute4(void) +{ /* '$execute'(Goal) */ + Term t = Deref(ARG1); + heap_store(Deref(ARG2)); + heap_store(Deref(ARG3)); + heap_store(Deref(ARG4)); + return(do_execute_n(t, CurrentModule, 3)); +} + static Int p_execute_clause(void) { /* '$execute_clause'(Goal) */ @@ -1634,6 +1796,9 @@ Yap_InitExecFs(void) { Yap_InitComma(); Yap_InitCPred("$execute", 1, p_execute, HiddenPredFlag); + Yap_InitCPred("$execute", 2, p_execute2, HiddenPredFlag); + Yap_InitCPred("$execute", 3, p_execute3, HiddenPredFlag); + Yap_InitCPred("$execute", 4, p_execute4, HiddenPredFlag); Yap_InitCPred("$execute_in_mod", 2, p_execute_in_mod, HiddenPredFlag); Yap_InitCPred("$call_with_args", 2, p_execute_0, HiddenPredFlag); Yap_InitCPred("$call_with_args", 3, p_execute_1, HiddenPredFlag); diff --git a/C/grow.c b/C/grow.c index ef56dce02..1e16a3908 100644 --- a/C/grow.c +++ b/C/grow.c @@ -324,20 +324,6 @@ AdjustTrail(int adjusting_heap) TrailTerm(ptt) = DelayAdjust(reg); else if (IsOldTrail(reg)) TrailTerm(ptt) = TrailAdjust(reg); - else if (IsOldCode(reg)) { - CELL *ptr; - TrailTerm(ptt) = reg = CodeAdjust(reg); - ptr = (CELL *)reg; - if (IsApplTerm(*ptr)) { - *ptr = AdjustAppl(*ptr); - } else if (IsPairTerm(*ptr)) { - *ptr = AdjustAppl(*ptr); - } -#ifdef DEBUG_STRONG - else - fprintf(Yap_stderr,"%% garbage heap ptr %p to %lx found in trail at %p by stack shifter\n", ptr, (unsigned long int)*ptr, ptt); -#endif - } } else if (IsPairTerm(reg)) { TrailTerm(ptt) = AdjustPair(reg); #ifdef MULTI_ASSIGNMENT_VARIABLES /* does not work with new structures */ @@ -357,8 +343,6 @@ AdjustTrail(int adjusting_heap) TrailVal(ptt) = DelayAdjust(reg2); else if (IsOldTrail(reg2)) TrailVal(ptt) = TrailAdjust(reg2); - else if (IsOldCode(reg2)) - TrailVal(ptt) = CodeAdjust(reg2); } else if (IsApplTerm(reg2)) { TrailVal(ptt) = AdjustAppl(reg2); } else if (IsPairTerm(reg2)) { @@ -398,10 +382,51 @@ AdjustLocal(void) } +static Term +AdjustGlobTerm(Term reg) +{ + if (IsVarTerm(reg)) { + if (IsOldGlobal(reg)) + return GlobalAdjust(reg); + else if (IsOldDelay(reg)) + return DelayAdjust(reg); + else if (IsOldLocal(reg)) + return LocalAdjust(reg); +#ifdef MULTI_ASSIGNMENT_VARIABLES + else if (IsOldTrail(reg)) + return TrailAdjust(reg); +#endif + } else if (IsApplTerm(reg)) + return AdjustAppl(reg); + else if (IsPairTerm(reg)) + return AdjustPair(reg); + return AtomTermAdjust(reg); +} + static void AdjustGlobal(void) { - register CELL *pt; + CELL *pt; + ArrayEntry *al = DynamicArrays; + StaticArrayEntry *sal = StaticArrays; + + while (al) { + al->ValueOfVE = AdjustGlobTerm(al->ValueOfVE); + al = al->NextAE; + } + while (sal) { + if (sal->ArrayType == array_of_nb_terms) { + UInt arity = -sal->ArrayEArity, i; + for (i=0; i < arity; i++) { + /* sal->ValueOfVE.lterms[i].tlive = AdjustGlobTerm(sal->ValueOfVE.lterms[i].tlive); */ + Term tlive = sal->ValueOfVE.lterms[i].tlive; + if (!IsVarTerm(tlive) || !IsUnboundVar(&sal->ValueOfVE.lterms[i].tlive)) { + sal->ValueOfVE.lterms[i].tlive = AdjustGlobTerm(sal->ValueOfVE.lterms[i].tlive); + } + } + } + sal = sal->NextAE; + } /* * to clean the global now that functors are just variables pointing to @@ -415,7 +440,7 @@ AdjustGlobal(void) if (IsVarTerm(reg)) { if (IsOldGlobal(reg)) *pt = GlobalAdjust(reg); - if (IsOldDelay(reg)) + else if (IsOldDelay(reg)) *pt = DelayAdjust(reg); else if (IsOldLocal(reg)) *pt = LocalAdjust(reg); diff --git a/C/heapgc.c b/C/heapgc.c index 7a4a1406f..b030bb966 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -372,14 +372,25 @@ static void push_registers(Int num_regs, yamop *nextop) { int i; + StaticArrayEntry *sal = StaticArrays; /* push array entries first */ - ArrayEntry *al = DynArrayList; - while (al != NULL) { - if (al->ArrayEArity > 0) { - TrailTerm(TR++) = al->ValueOfVE; + ArrayEntry *al = DynamicArrays; + while (al) { + TrailTerm(TR++) = al->ValueOfVE; + al = al->NextAE; + } + while (sal) { + if (sal->ArrayType == array_of_nb_terms) { + UInt arity = -sal->ArrayEArity, i; + for (i=0; i < arity; i++) { + Term tlive = sal->ValueOfVE.lterms[i].tlive; + if (!IsVarTerm(tlive) || !IsUnboundVar(&sal->ValueOfVE.lterms[i].tlive)) { + TrailTerm(TR++) = tlive; + } + } } - al = al->NextArrayE; + sal = sal->NextAE; } TrailTerm(TR) = GcGeneration; TR++; @@ -424,14 +435,26 @@ pop_registers(Int num_regs, yamop *nextop) { int i; tr_fr_ptr ptr = TR; + StaticArrayEntry *sal = StaticArrays; /* pop array entries first */ - ArrayEntry *al = DynArrayList; - while (al != NULL) { - if (al->ArrayEArity > 0) { - al->ValueOfVE = TrailTerm(ptr++); + ArrayEntry *al = DynamicArrays; + while (al) { + al->ValueOfVE = TrailTerm(ptr++); + al = al->NextAE; + } + sal = StaticArrays; + while (sal) { + if (sal->ArrayType == array_of_nb_terms) { + UInt arity = -sal->ArrayEArity; + for (i=0; i < arity; i++) { + Term tlive = sal->ValueOfVE.lterms[i].tlive; + if (!IsVarTerm(tlive) || !IsUnboundVar(&sal->ValueOfVE.lterms[i].tlive)) { + sal->ValueOfVE.lterms[i].tlive = TrailTerm(ptr++); + } + } } - al = al->NextArrayE; + sal = sal->NextAE; } GcGeneration = TrailTerm(ptr++); #ifdef COROUTINING @@ -1342,10 +1365,10 @@ mark_external_reference(CELL *ptr) { if (ONHEAP(next)) { #ifdef HYBRID_SCHEME - CELL_PTR *old = iptop; -#endif - mark_variable(ptr); - POPSWAP_POINTER(old); + CELL_PTR *old = iptop; +#endif + mark_variable(ptr); + POPSWAP_POINTER(old); } else { MARK(ptr); mark_code(ptr, next); @@ -1556,9 +1579,8 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B UNMARK(&TrailTerm(trail_base)); #endif /* EARLY_RESET */ } else if (hp < (CELL *)Yap_GlobalBase || hp > (CELL *)Yap_TrailTop) { - /* 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); + /* pointers from the Heap back into the trail are process in mark_regs. */ + /* do nothing !!! */ } else if ((hp < (CELL *)gc_B && hp >= gc_H) || hp > (CELL *)Yap_TrailBase) { /* clean the trail, avoid dangling pointers! */ RESET_VARIABLE(&TrailTerm(trail_base)); @@ -2106,7 +2128,8 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR) /* first, whatever we dumped on the trail. Easier just to do the registers separately? */ for (trail_ptr = old_TR; trail_ptr < TR; trail_ptr++) { - if (MARKED_PTR(&TrailTerm(trail_ptr))) { + if (IN_BETWEEN(Yap_GlobalBase,TrailTerm(trail_ptr),Yap_TrailTop) && + MARKED_PTR(&TrailTerm(trail_ptr))) { UNMARK(&TrailTerm(trail_ptr)); if (HEAP_PTR(TrailTerm(trail_ptr))) { into_relocation_chain(&TrailTerm(trail_ptr), GET_NEXT(TrailTerm(trail_ptr))); @@ -2134,7 +2157,8 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR) TrailTerm(dest) = trail_cell; if (IsVarTerm(trail_cell)) { /* we need to check whether this is a honest to god trail entry */ - if ((CELL *)trail_cell < H && MARKED_PTR((CELL *)trail_cell) && (CELL *)trail_cell >= H0) { + /* make sure it is a heap cell before we test whether it has been marked */ + if ((CELL *)trail_cell < H && (CELL *)trail_cell >= H0 && MARKED_PTR((CELL *)trail_cell)) { if (HEAP_PTR(trail_cell)) { into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell)); } @@ -2147,24 +2171,6 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR) into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailVal(dest))); } } -#endif - } else if ((CELL *)trail_cell < (CELL *)Yap_GlobalBase || - (CELL *)trail_cell > (CELL *)Yap_TrailTop) { - /* we may have pointers from the heap back into the cell */ - CELL *next = GET_NEXT(*CellPtr(trail_cell)); - UNMARK(CellPtr(trail_cell)); - if (HEAP_PTR(*CellPtr(trail_cell))) { - into_relocation_chain(CellPtr(trail_cell),next); - } -#ifdef FROZEN_STACKS - /* it is complex to recover cells with frozen segments */ - TrailVal(dest) = TrailVal(trail_ptr); - if (MARKED_PTR(&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)) { @@ -3661,6 +3667,8 @@ p_inform_gc(void) } +int vsc_gc_calls; + static int call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop) { @@ -3695,6 +3703,7 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop) if (gc_margin < gc_lim) gc_margin = gc_lim; GcCalls++; +vsc_gc_calls = GcCalls; if (gc_on && !(Yap_PrologMode & InErrorMode)) { effectiveness = do_gc(predarity, current_env, nextop); if (effectiveness > 90) { diff --git a/C/init.c b/C/init.c index 240b0b21a..b6160ff73 100644 --- a/C/init.c +++ b/C/init.c @@ -861,8 +861,13 @@ InitCodes(void) Yap_heap_regs->wl[i].scratchpad.ptr = NULL; Yap_heap_regs->wl[i].scratchpad.sz = SCRATCH_START_SIZE; Yap_heap_regs->wl[i].scratchpad.msz = SCRATCH_START_SIZE; + Yap_heap_regs->wl[i].dynamic_arrays = NULL; + Yap_heap_regs->wl[i].static_arrays = NULL; } } +#else + Yap_heap_regs->wl.dynamic_arrays = NULL; + Yap_heap_regs->wl.static_arrays = NULL; #endif /* YAPOR */ Yap_heap_regs->clausecode->arity = 0; Yap_heap_regs->clausecode->clause = NULL; @@ -1017,6 +1022,7 @@ InitCodes(void) #endif Yap_heap_regs->functor_arrow = Yap_MkFunctor(AtomArrow, 2); Yap_heap_regs->functor_assert = Yap_MkFunctor(AtomAssert, 2); + Yap_heap_regs->functor_at_found_one = Yap_MkFunctor(AtomFoundVar, 2); #ifdef COROUTINING Yap_heap_regs->functor_att_goal = Yap_MkFunctor(Yap_FullLookupAtom("$att_do"),2); #endif @@ -1033,6 +1039,7 @@ InitCodes(void) Yap_heap_regs->functor_g_atomic = Yap_MkFunctor(Yap_LookupAtom("atomic"), 1); Yap_heap_regs->functor_g_compound = Yap_MkFunctor(Yap_LookupAtom("compound"), 1); Yap_heap_regs->functor_g_float = Yap_MkFunctor(Yap_LookupAtom("float"), 1); + Yap_heap_regs->functor_g_format_at = Yap_MkFunctor(Yap_LookupAtom("$format@"), 2); Yap_heap_regs->functor_g_integer = Yap_MkFunctor(Yap_LookupAtom("integer"), 1); Yap_heap_regs->functor_g_number = Yap_MkFunctor(Yap_LookupAtom("number"), 1); Yap_heap_regs->functor_g_primitive = Yap_MkFunctor(Yap_LookupAtom("primitive"), 1); @@ -1067,7 +1074,6 @@ InitCodes(void) Yap_heap_regs->term_dollar_u = MkAtomTerm(Yap_FullLookupAtom("$u")); #endif Yap_heap_regs->term_refound_var = MkAtomTerm(Yap_FullLookupAtom("$I_FOUND_THE_VARIABLE_AGAIN")); - Yap_heap_regs->dyn_array_list = NULL; Yap_heap_regs->n_of_file_aliases = 0; Yap_heap_regs->file_aliases = NULL; Yap_heap_regs->foreign_code_loaded = NULL; @@ -1186,6 +1192,7 @@ Yap_InitWorkspace(int Heap, int Stack, int Trail, int max_table_size, INIT_RWLOCK(HashChain[i].AERWLock); HashChain[i].Entry = NIL; } + NOfAtoms = 0; Yap_LookupAtomWithAddress(".",&(SF_STORE->AtFoundVar)); Yap_ReleaseAtom(AtomFoundVar); Yap_LookupAtomWithAddress("?",&(SF_STORE->AtFreeTerm)); diff --git a/C/inlines.c b/C/inlines.c index 668d1fae9..f6836c96e 100755 --- a/C/inlines.c +++ b/C/inlines.c @@ -406,10 +406,17 @@ p_dif(void) HBREG = H; B = (choiceptr) H; save_hb(); - if (Yap_IUnify(d0, d1) == TRUE) { + if (Yap_IUnify(d0, d1)) { /* restore B, no need to restore HB */ B = pt1; - return(FALSE); +#ifdef COROUTINING + /* now restore Woken Goals to its old value */ + Yap_UpdateTimedVar(WokenGoals, OldWokenGoals); + if (OldWokenGoals == TermNil) { + Yap_undo_signal(YAP_WAKEUP_SIGNAL); + } +#endif + return FALSE; } B = pt1; /* restore B, and later HB */ @@ -426,8 +433,11 @@ p_dif(void) #ifdef COROUTINING /* now restore Woken Goals to its old value */ Yap_UpdateTimedVar(WokenGoals, OldWokenGoals); + if (OldWokenGoals == TermNil) { + Yap_undo_signal(YAP_WAKEUP_SIGNAL); + } #endif - return(TRUE); + return TRUE; ENDP(pt0); BEGP(pt0); @@ -440,7 +450,7 @@ p_dif(void) deref_body(d1, pt0, dif_nvar1_unk2, dif_nvar1_nvar2); ENDP(pt0); /* second argument is unbound */ - return(FALSE); + return FALSE; ENDD(d1); ENDD(d0); } diff --git a/C/iopreds.c b/C/iopreds.c index 1c7375580..d35ace6d1 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -120,6 +120,7 @@ STATIC_PROTO (void PurgeAlias, (int)); STATIC_PROTO (int CheckAlias, (Atom)); STATIC_PROTO (Atom FetchAlias, (int)); STATIC_PROTO (int FindAliasForStream, (int, Atom)); +STATIC_PROTO (int FindStreamForAlias, (Atom)); STATIC_PROTO (int CheckStream, (Term, int, char *)); STATIC_PROTO (Int p_check_stream, (void)); STATIC_PROTO (Int p_check_if_stream, (void)); @@ -1831,25 +1832,29 @@ static Int p_check_if_valid_new_alias (void) static Int p_fetch_stream_alias (void) -{ /* '$fetch_stream_alias'(Stream) */ +{ /* '$fetch_stream_alias'(Stream,Alias) */ int sno; Term t2 = Deref(ARG2); + Term t1 = Deref(ARG1); - if ((sno = CheckStream (ARG1, Input_Stream_f | Output_Stream_f, + if (IsVarTerm(t1)) { + return Yap_unify(ARG1,MkStream(FindStreamForAlias(AtomOfTerm(t2)))); + } + if ((sno = CheckStream (t1, Input_Stream_f | Output_Stream_f, "fetch_stream_alias/2")) == -1) - return(FALSE); + return FALSE; if (IsVarTerm(t2)) { Atom at = FetchAlias(sno); if (at == AtomFoundVar) - return(FALSE); + return FALSE; else - return(Yap_unify_constant(t2, MkAtomTerm(at))); + return Yap_unify_constant(t2, MkAtomTerm(at)); } else if (IsAtomTerm(t2)) { Atom at = AtomOfTerm(t2); - return((Int)FindAliasForStream(sno,at)); + return (Int)FindAliasForStream(sno,at); } else { Yap_Error(TYPE_ERROR_ATOM, t2, "fetch_stream_alias/2"); - return(FALSE); + return FALSE; } } @@ -2288,6 +2293,21 @@ FindAliasForStream (int sno, Atom al) return(FALSE); } +/* check if arg is an alias */ +static int +FindStreamForAlias (Atom al) +{ + AliasDesc aliasp = FileAliases, aliasp_max = FileAliases+NOfFileAliases; + + while (aliasp < aliasp_max) { + if (aliasp->name == al) { + return(aliasp->alias_stream); + } + aliasp++; + } + return(FALSE); +} + static int CheckStream (Term arg, int kind, char *msg) { @@ -3520,66 +3540,66 @@ p_put_byte (void) return (TRUE); } -static int format_error = FALSE; - #define FORMAT_MAX_SIZE 256 -static char *format_ptr, *format_base, *format_max; -static int format_buf_size; - typedef struct { Int pos; /* tab point */ char pad; /* ok, it's not standard english */ } pads; -static pads pad_entries[16], *pad_max = pad_entries; +typedef struct format_status { + int format_error; + char *format_ptr, *format_base, *format_max; + int format_buf_size; + pads pad_entries[16], *pad_max; +} format_info; static int format_putc(int sno, int ch) { - if (format_buf_size == -1) - return(EOF); + if (FormatInfo->format_buf_size == -1) + return EOF; if (ch == 10) { - char *ptr = format_base; + char *ptr = FormatInfo->format_base; #if MAC || _MSC_VER ch = '\n'; #endif - for (ptr = format_base; ptr < format_ptr; ptr++) { + for (ptr = FormatInfo->format_base; ptr < FormatInfo->format_ptr; ptr++) { Stream[sno].stream_putc(sno, *ptr); } /* reset line */ - format_ptr = format_base; - pad_max = pad_entries; + FormatInfo->format_ptr = FormatInfo->format_base; + FormatInfo->pad_max = FormatInfo->pad_entries; Stream[sno].stream_putc(sno, '\n'); return((int)10); } else { - *format_ptr++ = (char)ch; - if (format_ptr == format_max) { + *FormatInfo->format_ptr++ = (char)ch; + if (FormatInfo->format_ptr == FormatInfo->format_max) { /* oops, we have reached an overflow */ - Int new_max_size = format_buf_size + FORMAT_MAX_SIZE; + Int new_max_size = FormatInfo->format_buf_size + FORMAT_MAX_SIZE; char *newbuf; if ((newbuf = Yap_AllocAtomSpace(new_max_size*sizeof(char))) == NULL) { - format_buf_size = -1; + FormatInfo->format_buf_size = -1; Yap_Error(SYSTEM_ERROR, TermNil, "YAP could not grow heap for format/2"); return(EOF); } #if HAVE_MEMMOVE - memmove((void *)newbuf, (void *)format_base, (size_t)((format_ptr-format_base)*sizeof(char))); + memmove((void *)newbuf, (void *)FormatInfo->format_base, (size_t)((FormatInfo->format_ptr-FormatInfo->format_base)*sizeof(char))); #else { - Int n = format_ptr-format_base; + Int n = FormatInfo->format_ptr-FormatInfo->format_base; char *to = newbuf; - char *from = format_base; + char *from = FormatInfo->format_base; while (n-- >= 0) { *to++ = *from++; } } #endif - Yap_FreeAtomSpace(format_base); - format_ptr = newbuf+(format_ptr-format_base); - format_base = newbuf; - format_max = newbuf+new_max_size; - format_buf_size = new_max_size; + Yap_FreeAtomSpace(FormatInfo->format_base); + FormatInfo->format_ptr = newbuf+(FormatInfo->format_ptr-FormatInfo->format_base); + FormatInfo->format_base = newbuf; + FormatInfo->format_max = newbuf+new_max_size; + FormatInfo->format_buf_size = new_max_size; if (ActiveSignals & YAP_CDOVF_SIGNAL) { if (!Yap_growheap(FALSE, 0, NULL)) { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP failed to grow heap at format"); @@ -3595,11 +3615,11 @@ static void fill_pads(int nchars) int nfillers, fill_space, lfill_space; if (nchars <= 0) return; /* ignore */ - nfillers = pad_max-pad_entries; + nfillers = FormatInfo->pad_max-FormatInfo->pad_entries; if (nfillers == 0) { /* OK, just pad with spaces */ while (nchars--) { - *format_ptr++ = ' '; + *FormatInfo->format_ptr++ = ' '; } return; } @@ -3607,35 +3627,35 @@ static void fill_pads(int nchars) lfill_space = nchars%nfillers; if (fill_space) { - pads *padi = pad_max; + pads *padi = FormatInfo->pad_max; - while (padi > pad_entries) { + while (padi > FormatInfo->pad_entries) { char *start_pos; int n, i; padi--; - start_pos = format_base+padi->pos; - n = format_ptr-start_pos; + start_pos = FormatInfo->format_base+padi->pos; + n = FormatInfo->format_ptr-start_pos; #if HAVE_MEMMOVE memmove((void *)(start_pos+fill_space), (void *)start_pos, (size_t)(n*sizeof(char))); #else { char *to = start_pos+(fill_space+n); - char *from = format_ptr; + char *from = FormatInfo->format_ptr; while (n-- > 0) { *--to = *--from; } } #endif - format_ptr += fill_space; + FormatInfo->format_ptr += fill_space; for (i = 0; i < fill_space; i++) { *start_pos++ = padi->pad; } } } while (lfill_space--) { - *format_ptr++ = pad_max[-1].pad; + *FormatInfo->format_ptr++ = FormatInfo->pad_max[-1].pad; } } @@ -3780,7 +3800,7 @@ format_has_tabs(const char *seq) if (ch == '*') { ch = *seq++; } - if (ch == 't' || ch == '|') { + if (ch == 't' || ch == '|' || ch == '@') { return TRUE; } } @@ -3804,7 +3824,12 @@ format(volatile Term otail, volatile Term oargs, int sno) jmp_buf format_botch; volatile void *old_handler; volatile int old_pos; + format_info finfo; + Term fmod = CurrentModule; + FormatInfo = &finfo; + finfo.pad_max = finfo.pad_entries; + finfo.format_error = FALSE; if (Stream[sno].status & InMemory_Stream_f) { old_handler = Stream[sno].u.mem_string.error_handler; Stream[sno].u.mem_string.error_handler = (void *)&format_botch; @@ -3850,6 +3875,26 @@ format(volatile Term otail, volatile Term oargs, int sno) Yap_Error(CONSISTENCY_ERROR, tail, "format/2"); return FALSE; } + if (IsVarTerm(args)) { + Yap_Error(INSTANTIATION_ERROR, args, "format/2"); + return FALSE; + } + while (IsApplTerm(args) && FunctorOfTerm(args) == FunctorModule) { + fmod = ArgOfTerm(1,args); + args = ArgOfTerm(2,args); + if (IsVarTerm(fmod)) { + Yap_Error(INSTANTIATION_ERROR, fmod, "format/2"); + return FALSE; + } + if (!IsAtomTerm(fmod)) { + Yap_Error(TYPE_ERROR_ATOM, fmod, "format/2"); + return FALSE; + } + if (IsVarTerm(args)) { + Yap_Error(INSTANTIATION_ERROR, args, "format/2"); + return FALSE; + } + } if (IsPairTerm(args)) { Int tsz = 8; @@ -3876,20 +3921,20 @@ format(volatile Term otail, volatile Term oargs, int sno) tnum = 0; targs = mytargs; } - format_error = FALSE; + finfo.format_error = FALSE; if ((has_tabs = format_has_tabs(fptr))) { - format_base = format_ptr = Yap_AllocAtomSpace(FORMAT_MAX_SIZE*sizeof(char)); - format_max = format_base+FORMAT_MAX_SIZE; - if (format_ptr == NULL) { + finfo.format_base = finfo.format_ptr = Yap_AllocAtomSpace(FORMAT_MAX_SIZE*sizeof(char)); + finfo.format_max = finfo.format_base+FORMAT_MAX_SIZE; + if (finfo.format_ptr == NULL) { Yap_Error(INSTANTIATION_ERROR,tail,"format/2"); return(FALSE); } - format_buf_size = FORMAT_MAX_SIZE; + finfo.format_buf_size = FORMAT_MAX_SIZE; f_putc = format_putc; } else { f_putc = Stream[sno].stream_putc; - format_base = NULL; + finfo.format_base = NULL; } while ((ch = *fptr++)) { Term t = TermNil; @@ -3932,6 +3977,7 @@ format(volatile Term otail, volatile Term oargs, int sno) if (!IsAtomTerm(t)) goto do_type_atom_error; Yap_plwrite (t, f_putc, Handle_vars_f|To_heap_f); + FormatInfo = &finfo; break; case 'c': { @@ -4004,6 +4050,7 @@ format(volatile Term otail, volatile Term oargs, int sno) goto do_type_int_error; if (!has_repeats) { Yap_plwrite (t, f_putc, Handle_vars_f|To_heap_f); + FormatInfo = &finfo; } else { Int siz, dec = IntegerOfTerm(t), i, div = 1; @@ -4044,6 +4091,7 @@ format(volatile Term otail, volatile Term oargs, int sno) f_putc(sno, (int) '.'); } Yap_plwrite (MkIntegerTerm(dec), f_putc, Handle_vars_f|To_heap_f); + FormatInfo = &finfo; break; case 'r': case 'R': @@ -4107,8 +4155,37 @@ format(volatile Term otail, volatile Term oargs, int sno) t = targs[targ++]; Yap_StartSlots(); Yap_plwrite (t, f_putc, Quote_illegal_f|Ignore_ops_f|To_heap_f ); + FormatInfo = &finfo; ASP++; break; + case '@': + t = targs[targ++]; + Yap_StartSlots(); + { + long sl = Yap_InitSlot(args); + long sl2; + Int res; + Term ta[2]; + Term ts; + + ta[0] = fmod; + ta[1] = t; + ta[0] = Yap_MkApplTerm(FunctorModule, 2, ta); + ta[1] = MkVarTerm(); + sl2 = Yap_InitSlot(ta[1]); + ts = Yap_MkApplTerm(FunctorGFormatAt, 2, ta); + res = Yap_execute_goal(ts, 0, 1); + FormatInfo = &finfo; + args = Yap_GetFromSlot(sl); + if (EX) goto ex_handler; + if (!res) return FALSE; + ts = Yap_GetFromSlot(sl2); + Yap_RecoverSlots(2); + if (!format_print_str (sno, repeats, has_repeats, ts, f_putc)) { + goto do_default_error; + } + } + break; case 'p': if (targ > tnum-1 || has_repeats) goto do_consistency_error; @@ -4117,11 +4194,15 @@ format(volatile Term otail, volatile Term oargs, int sno) { long sl = Yap_InitSlot(args); Yap_plwrite(t, f_putc, Handle_vars_f|Use_portray_f|To_heap_f); + FormatInfo = &finfo; args = Yap_GetFromSlot(sl); Yap_RecoverSlots(1); } if (EX != 0L) { - Term ball = EX; + Term ball; + + ex_handler: + ball = EX; EX = 0L; if (tnum <= 8) targs = NULL; @@ -4131,8 +4212,9 @@ format(volatile Term otail, volatile Term oargs, int sno) if (Stream[sno].status & InMemory_Stream_f) { Stream[sno].u.mem_string.error_handler = old_handler; } - format_clean_up(format_base, fstr, targs); + format_clean_up(finfo.format_base, fstr, targs); Yap_JumpToEnv(ball); + return FALSE; } ASP++; break; @@ -4142,6 +4224,7 @@ format(volatile Term otail, volatile Term oargs, int sno) t = targs[targ++]; Yap_StartSlots(); Yap_plwrite (t, f_putc, Handle_vars_f|Quote_illegal_f|To_heap_f); + FormatInfo = &finfo; ASP++; break; case 'w': @@ -4150,6 +4233,7 @@ format(volatile Term otail, volatile Term oargs, int sno) t = targs[targ++]; Yap_StartSlots(); Yap_plwrite (t, f_putc, Handle_vars_f|To_heap_f); + FormatInfo = &finfo; ASP++; break; case '~': @@ -4164,7 +4248,7 @@ format(volatile Term otail, volatile Term oargs, int sno) f_putc(sno, (int) '\n'); } column_boundary = 0; - pad_max = pad_entries; + finfo.pad_max = finfo.pad_entries; break; case 'N': if (!has_repeats) @@ -4172,41 +4256,41 @@ format(volatile Term otail, volatile Term oargs, int sno) if (Stream[sno].linepos != 0) { f_putc(sno, (int) '\n'); column_boundary = 0; - pad_max = pad_entries; + finfo.pad_max = finfo.pad_entries; } if (repeats > 1) { Int i; for (i = 1; i < repeats; i++) f_putc(sno, (int) '\n'); column_boundary = 0; - pad_max = pad_entries; + finfo.pad_max = finfo.pad_entries; } break; /* padding */ case '|': if (has_repeats) { - fill_pads(repeats-(format_ptr-format_base)); + fill_pads(repeats-(finfo.format_ptr-finfo.format_base)); } - pad_max = pad_entries; + finfo.pad_max = finfo.pad_entries; column_boundary = repeats; break; case '+': if (has_repeats) { - fill_pads((repeats+column_boundary)-(format_ptr-format_base)); + fill_pads((repeats+column_boundary)-(finfo.format_ptr-finfo.format_base)); } else { repeats = 8; fill_pads(8); } - pad_max = pad_entries; + finfo.pad_max = finfo.pad_entries; column_boundary = repeats+column_boundary; break; case 't': if (!has_repeats) - pad_max->pad = ' '; + finfo.pad_max->pad = ' '; else - pad_max->pad = fptr[-2]; - pad_max->pos = format_ptr-format_base; - pad_max++; + finfo.pad_max->pad = fptr[-2]; + finfo.pad_max->pos = finfo.format_ptr-finfo.format_base; + finfo.pad_max++; f_putc = format_putc; break; do_instantiation_error: @@ -4245,7 +4329,7 @@ format(volatile Term otail, volatile Term oargs, int sno) if (Stream[sno].status & InMemory_Stream_f) { Stream[sno].u.mem_string.error_handler = old_handler; } - format_clean_up(format_base, fstr, targs); + format_clean_up(finfo.format_base, fstr, targs); Yap_Error_TYPE = YAP_NO_ERROR; return FALSE; } @@ -4257,7 +4341,7 @@ format(volatile Term otail, volatile Term oargs, int sno) } } if (has_tabs) { - for (fptr = format_base; fptr < format_ptr; fptr++) { + for (fptr = finfo.format_base; fptr < finfo.format_ptr; fptr++) { Stream[sno].stream_putc(sno, *fptr); } } @@ -4269,7 +4353,7 @@ format(volatile Term otail, volatile Term oargs, int sno) if (Stream[sno].status & InMemory_Stream_f) { Stream[sno].u.mem_string.error_handler = old_handler; } - format_clean_up(format_base, fstr, targs); + format_clean_up(finfo.format_base, fstr, targs); return (TRUE); } diff --git a/C/stdpreds.c b/C/stdpreds.c index 73ef43a98..f3f38d2ec 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -11,8 +11,11 @@ * File: stdpreds.c * * comments: General-purpose C implemented system predicates * * * -* Last rev: $Date: 2005-10-21 16:09:02 $,$Author: vsc $ * +* Last rev: $Date: 2005-10-28 17:38:49 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.95 2005/10/21 16:09:02 vsc +* SWI compatible module only operators +* * Revision 1.94 2005/09/08 22:06:45 rslopes * BEAM for YAP update... * @@ -771,6 +774,18 @@ do_signal(yap_signals sig) UNLOCK(SignalLock); } +inline static void +undo_signal(yap_signals sig) +{ + LOCK(SignalLock); + if (ActiveSignals == sig) { + CreepFlag = CalculateStackGap(); + } + ActiveSignals &= ~sig; + UNLOCK(SignalLock); +} + + static Int p_creep(void) { @@ -820,6 +835,12 @@ Yap_signal(yap_signals sig) do_signal(sig); } +void +Yap_undo_signal(yap_signals sig) +{ + undo_signal(sig); +} + #ifdef undefined /* @@ -3207,6 +3228,16 @@ p_loop(void) { } #endif +static Int +p_max_tagged_integer(void) { + return Yap_unify(ARG1, MkIntTerm(MAX_ABS_INT-1L)); +} + +static Int +p_min_tagged_integer(void) { + return Yap_unify(ARG1, MkIntTerm(-MAX_ABS_INT)); +} + void Yap_InitBackCPreds(void) { @@ -3267,6 +3298,8 @@ Yap_InitCPreds(void) Yap_InitCPred("$access_yap_flags", 2, p_access_yap_flags, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$set_yap_flags", 2, p_set_yap_flags, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred("abort", 0, p_abort, SyncPredFlag); + Yap_InitCPred("$max_tagged_integer", 1, p_max_tagged_integer, SafePredFlag|HiddenPredFlag); + Yap_InitCPred("$min_tagged_integer", 1, p_min_tagged_integer, SafePredFlag|HiddenPredFlag); #ifdef BEAM Yap_InitCPred("@", 0, eager_split, SafePredFlag); Yap_InitCPred(":", 0, force_wait, SafePredFlag); diff --git a/C/sysbits.c b/C/sysbits.c index 55e9bec95..e7b819cd3 100644 --- a/C/sysbits.c +++ b/C/sysbits.c @@ -1758,7 +1758,7 @@ static Int p_shell (void) { /* '$shell'(+SystCommand) */ #if _MSC_VER || defined(__MINGW32__) - return(0); + return 0; #else #if HAVE_SYSTEM char *shell; @@ -2251,6 +2251,15 @@ p_yap_home(void) { return(Yap_unify(out,ARG1)); } +static Int +p_env_separator(void) { +#if defined(_WIN32) + return Yap_unify(MkIntegerTerm(';'),ARG1); +#else + return Yap_unify(MkIntegerTerm(':'),ARG1); +#endif +} + /* * This is responsable for the initialization of all machine dependant * predicates @@ -2435,6 +2444,7 @@ Yap_InitSysPreds(void) Yap_InitCPred ("$host_type", 1, p_host_type, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("$continue_signals", 0, p_continue_signals, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred ("file_directory_name", 2, p_file_directory_name, SafePredFlag); + Yap_InitCPred ("$env_separator", 1, p_env_separator, SafePredFlag); } diff --git a/C/tracer.c b/C/tracer.c index 07491af4d..49c777b4e 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -120,6 +120,12 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) /* extern int gc_calls; */ vsc_count++; + if (vsc_count == 21857LL) { + jmp_deb(1); + } + if (vsc_count < 21800LL) { + return; + } #ifdef COMMENTED // if (vsc_count == 218280) // vsc_xstop = 1; @@ -181,6 +187,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) #if defined(THREADS) || defined(YAPOR) fprintf(Yap_stderr,"(%d)", worker_id); #endif + fprintf(Yap_stderr," %x ", Yap_ReadTimedVar(WokenGoals)); /* check_trail_consistency(); */ if (pred == NULL) return; @@ -300,3 +307,4 @@ Yap_InitLowLevelTrace(void) #endif + diff --git a/C/utilpreds.c b/C/utilpreds.c index b702a4692..343fb109d 100644 --- a/C/utilpreds.c +++ b/C/utilpreds.c @@ -1940,7 +1940,7 @@ void Yap_InitUtilCPreds(void) { Term cm = CurrentModule; Yap_InitCPred("copy_term", 2, p_copy_term, 0); - Yap_InitCPred("$copy_term_but_not_constraints", 2, p_copy_term_no_delays, HiddenPredFlag); + Yap_InitCPred("copy_term_nat", 2, p_copy_term_no_delays, HiddenPredFlag); Yap_InitCPred("ground", 1, p_ground, SafePredFlag); Yap_InitCPred("$variables_in_term", 3, p_variables_in_term, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$non_singletons_in_term", 3, p_non_singletons_in_term, SafePredFlag|HiddenPredFlag); diff --git a/H/Heap.h b/H/Heap.h index 1e64a87d4..ecd82cf09 100644 --- a/H/Heap.h +++ b/H/Heap.h @@ -10,7 +10,7 @@ * File: Heap.h * * mods: * * comments: Heap Init Structure * -* version: $Id: Heap.h,v 1.84 2005-09-21 03:49:33 vsc Exp $ * +* version: $Id: Heap.h,v 1.85 2005-10-28 17:38:50 vsc Exp $ * *************************************************************************/ /* information that can be stored in Code Space */ @@ -67,6 +67,7 @@ extern struct restore_info rinfo; #endif typedef struct worker_local_struct { + struct format_status *f_info; char *scanner_stack; struct scanner_extra_alloc *scanner_extra_blocks; #if defined(YAPOR) || defined(THREADS) @@ -91,6 +92,8 @@ typedef struct worker_local_struct { Int tot_gc_time; /* total time spent in GC */ Int tot_gc_recovered; /* number of heap objects in all garbage collections */ jmp_buf gc_restore; /* where to jump if garbage collection crashes */ + struct array_entry *dynamic_arrays; + struct static_array_entry *static_arrays; yamop trust_lu_code[3]; } worker_local; @@ -338,6 +341,7 @@ typedef struct various_codes { #endif functor_arrow, functor_assert, + functor_at_found_one, #ifdef COROUTINING functor_att_goal, /* goal that activates attributed variables */ #endif @@ -354,6 +358,7 @@ typedef struct various_codes { functor_g_atom, functor_g_atomic, functor_g_compound, + functor_g_format_at, functor_g_integer, functor_g_float, functor_g_number, @@ -403,7 +408,6 @@ typedef struct various_codes { struct pred_entry *pred_static_clause; struct pred_entry *pred_throw; struct pred_entry *pred_handle_throw; - struct array_entry *dyn_array_list; struct DB_STRUCT *db_erased_marker; #ifdef DEBUG struct logic_upd_clause *db_erased_list; @@ -605,6 +609,7 @@ struct various_codes *Yap_heap_regs; #endif #define FunctorArrow Yap_heap_regs->functor_arrow #define FunctorAssert Yap_heap_regs->functor_assert +#define FunctorAtFoundOne Yap_heap_regs->functor_at_found_one #ifdef COROUTINING #define FunctorAttGoal Yap_heap_regs->functor_att_goal #endif @@ -623,6 +628,7 @@ struct various_codes *Yap_heap_regs; #define FunctorGCompound Yap_heap_regs->functor_g_compound #define FunctorGFloat Yap_heap_regs->functor_g_float #define FunctorGInteger Yap_heap_regs->functor_g_integer +#define FunctorGFormatAt Yap_heap_regs->functor_g_format_at #define FunctorGNumber Yap_heap_regs->functor_g_number #define FunctorGPrimitive Yap_heap_regs->functor_g_primitive #define FunctorGVar Yap_heap_regs->functor_g_var @@ -668,7 +674,6 @@ struct various_codes *Yap_heap_regs; #define PredStaticClause Yap_heap_regs->pred_static_clause #define PredThrow Yap_heap_regs->pred_throw #define PredHandleThrow Yap_heap_regs->pred_handle_throw -#define DynArrayList Yap_heap_regs->dyn_array_list #define DBErasedMarker Yap_heap_regs->db_erased_marker #ifdef DEBUG #define DBErasedList Yap_heap_regs->db_erased_list @@ -717,6 +722,7 @@ struct various_codes *Yap_heap_regs; #define TrDiff rinfo[worker_id].tr_diff #define XDiff rinfo[worker_id].x_diff #define DelayDiff rinfo[worker_id].delay_diff +#define FormatInfo Yap_heap_regs->wl[worker_id].f_info #define ScannerStack Yap_heap_regs->wl[worker_id].scanner_stack #define ScannerExtraBlocks Yap_heap_regs->wl[worker_id].scanner_extra_blocks #define SignalLock Yap_heap_regs->wl[worker_id].signal_lock @@ -739,6 +745,8 @@ struct various_codes *Yap_heap_regs; #define TotGcRecovered Yap_heap_regs->wl[worker_id].tot_gc_recovered #define Yap_gc_restore Yap_heap_regs->wl[worker_id].gc_restore #define TrustLUCode Yap_heap_regs->wl[worker_id].trust_lu_code +#define DynamicArrays Yap_heap_regs->wl[worker_id].dynamic_arrays +#define StaticArrays Yap_heap_regs->wl[worker_id].static_arrays #else #define OldASP rinfo.old_ASP #define OldLCL0 rinfo.old_LCL0 @@ -757,6 +765,7 @@ struct various_codes *Yap_heap_regs; #define TrDiff rinfo.tr_diff #define XDiff rinfo.x_diff #define DelayDiff rinfo.delay_diff +#define FormatInfo Yap_heap_regs->wl.f_info #define ScannerStack Yap_heap_regs->wl.scanner_stack #define ScannerExtraBlocks Yap_heap_regs->wl.scanner_extra_blocks #define ActiveSignals Yap_heap_regs->wl.active_signals @@ -777,6 +786,8 @@ struct various_codes *Yap_heap_regs; #define TotGcRecovered Yap_heap_regs->wl.tot_gc_recovered #define Yap_gc_restore Yap_heap_regs->wl.gc_restore #define TrustLUCode Yap_heap_regs->wl.trust_lu_code +#define DynamicArrays Yap_heap_regs->wl.dynamic_arrays +#define StaticArrays Yap_heap_regs->wl.static_arrays #endif #define profiling Yap_heap_regs->compiler_profiling #define call_counting Yap_heap_regs->compiler_call_counting diff --git a/H/Yapproto.h b/H/Yapproto.h index 8c047978e..75787461f 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -10,7 +10,7 @@ * File: Yap.proto * * mods: * * comments: Function declarations for YAP * -* version: $Id: Yapproto.h,v 1.61 2005-10-21 16:09:03 vsc Exp $ * +* version: $Id: Yapproto.h,v 1.62 2005-10-28 17:38:50 vsc Exp $ * *************************************************************************/ /* prototype file for Yap */ @@ -260,6 +260,7 @@ void STD_PROTO(Yap_InitBackCPreds,(void)); void STD_PROTO(Yap_InitCPreds,(void)); void STD_PROTO(Yap_show_statistics,(void)); void STD_PROTO(Yap_signal,(yap_signals)); +void STD_PROTO(Yap_undo_signal,(yap_signals)); /* sysbits.c */ void STD_PROTO(Yap_set_fpu_exceptions,(int)); diff --git a/H/Yatom.h b/H/Yatom.h index 50e43d5c8..92d1c778b 100644 --- a/H/Yatom.h +++ b/H/Yatom.h @@ -944,10 +944,10 @@ typedef struct array_entry #if defined(YAPOR) || defined(THREADS) rwlock_t ArRWLock; /* a read-write lock to protect the entry */ #endif - struct array_entry *NextArrayE; /* Pointer to the actual array */ #if THREADS unsigned int owner_id; #endif + struct array_entry *NextAE; Term ValueOfVE; /* Pointer to the actual array */ } ArrayEntry; @@ -987,7 +987,7 @@ typedef union } statarray_elements; /* next, the actual data structure */ -typedef struct +typedef struct static_array_entry { Prop NextOfPE; /* used to chain properties */ PropFlags KindOfPE; /* kind of property */ @@ -995,6 +995,7 @@ typedef struct #if defined(YAPOR) || defined(THREADS) rwlock_t ArRWLock; /* a read-write lock to protect the entry */ #endif + struct static_array_entry *NextAE; static_array_types ArrayType; /* Type of Array Elements. */ statarray_elements ValueOfVE; /* Pointer to the Array itself */ } StaticArrayEntry; diff --git a/H/absmi.h b/H/absmi.h index ec591deb0..91a4f709e 100644 --- a/H/absmi.h +++ b/H/absmi.h @@ -235,19 +235,19 @@ restore_absmi_regs(REGSTORE * old_regs) #if Y_IN_MEM -#define CACHE_Y_AS_ENV(A) { register CELL *E_YREG = (A) +#define CACHE_Y_AS_ENV(A) { register CELL *ENV_YREG = (A) -#define WRITEBACK_Y_AS_ENV() YREG = E_YREG +#define WRITEBACK_Y_AS_ENV() YREG = ENV_YREG #define ENDCACHE_Y_AS_ENV() } -#define saveregs_and_ycache() YREG = E_YREG; saveregs() +#define saveregs_and_ycache() YREG = ENV_YREG; saveregs() -#define setregs_and_ycache() E_YREG = YREG; setregs() +#define setregs_and_ycache() ENV_YREG = YREG; setregs() #else -#define E_YREG (YREG) +#define ENV_YREG (YREG) #define WRITEBACK_Y_AS_ENV() @@ -679,10 +679,10 @@ Macros to check the limits of stacks #if (defined(SBA) && defined(YAPOR)) || defined(TABLING) #define check_stack(Label, GLOB) \ - if ( (Int)(Unsigned(YOUNGEST_CP((choiceptr)E_YREG,B_FZ)) - Unsigned(YOUNGEST_H(H_FZ,GLOB))) < CFREG ) goto Label + if ( (Int)(Unsigned(YOUNGEST_CP((choiceptr)ENV_YREG,B_FZ)) - Unsigned(YOUNGEST_H(H_FZ,GLOB))) < CFREG ) goto Label #else #define check_stack(Label, GLOB) \ - if ( (Int)(Unsigned(E_YREG) - Unsigned(GLOB)) < CFREG ) goto Label + if ( (Int)(Unsigned(ENV_YREG) - Unsigned(GLOB)) < CFREG ) goto Label #endif /* SBA && YAPOR */ /*************************************************************** diff --git a/H/rheap.h b/H/rheap.h index f8e76a1a1..021e8dce3 100644 --- a/H/rheap.h +++ b/H/rheap.h @@ -11,8 +11,11 @@ * File: rheap.h * * comments: walk through heap code * * * -* Last rev: $Date: 2005-10-21 16:09:03 $,$Author: vsc $ * +* Last rev: $Date: 2005-10-28 17:38:50 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.56 2005/10/21 16:09:03 vsc +* SWI compatible module only operators +* * Revision 1.55 2005/10/19 19:00:48 vsc * extend arrays with nb_terms so that we can implement nb_ builtins * correctly. @@ -362,6 +365,7 @@ restore_codes(void) Yap_heap_regs->functor_alt_not = FuncAdjust(Yap_heap_regs->functor_alt_not); Yap_heap_regs->functor_arrow = FuncAdjust(Yap_heap_regs->functor_arrow); Yap_heap_regs->functor_assert = FuncAdjust(Yap_heap_regs->functor_assert); + Yap_heap_regs->functor_at_found_one = FuncAdjust(Yap_heap_regs->functor_at_found_one); #ifdef COROUTINING Yap_heap_regs->functor_att_goal = FuncAdjust(Yap_heap_regs->functor_att_goal); #endif @@ -378,6 +382,7 @@ restore_codes(void) Yap_heap_regs->functor_g_atomic = FuncAdjust(Yap_heap_regs->functor_g_atomic); Yap_heap_regs->functor_g_compound = FuncAdjust(Yap_heap_regs->functor_g_compound); Yap_heap_regs->functor_g_float = FuncAdjust(Yap_heap_regs->functor_g_float); + Yap_heap_regs->functor_g_format_at = FuncAdjust(Yap_heap_regs->functor_g_format_at); Yap_heap_regs->functor_g_integer = FuncAdjust(Yap_heap_regs->functor_g_integer); Yap_heap_regs->functor_g_number = FuncAdjust(Yap_heap_regs->functor_g_number); Yap_heap_regs->functor_g_primitive = FuncAdjust(Yap_heap_regs->functor_g_primitive); @@ -414,10 +419,6 @@ restore_codes(void) Yap_heap_regs->attributes_module = AtomTermAdjust(Yap_heap_regs->attributes_module); Yap_heap_regs->charsio_module = AtomTermAdjust(Yap_heap_regs->charsio_module); Yap_heap_regs->terms_module = AtomTermAdjust(Yap_heap_regs->terms_module); - if (Yap_heap_regs->dyn_array_list != NULL) { - Yap_heap_regs->dyn_array_list = - (struct array_entry *)AddrAdjust((ADDR)Yap_heap_regs->dyn_array_list); - } if (Yap_heap_regs->file_aliases != NULL) { Yap_heap_regs->yap_streams = (struct stream_desc *)AddrAdjust((ADDR)Yap_heap_regs->yap_streams); @@ -446,8 +447,6 @@ restore_codes(void) (PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_throw); Yap_heap_regs->pred_handle_throw = (PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_handle_throw); - if (Yap_heap_regs->dyn_array_list != NULL) - Yap_heap_regs->dyn_array_list = PtoArrayEAdjust(Yap_heap_regs->dyn_array_list); if (Yap_heap_regs->undef_code != NULL) Yap_heap_regs->undef_code = (PredEntry *)PtoHeapCellAdjust((CELL *)(Yap_heap_regs->undef_code)); if (Yap_heap_regs->creep_code != NULL) @@ -462,6 +461,14 @@ restore_codes(void) AbsAppl(PtoGloAdjust(RepAppl(Yap_heap_regs->wl.mutable_list))); Yap_heap_regs->wl.atts_mutable_list = AbsAppl(PtoGloAdjust(RepAppl(Yap_heap_regs->wl.atts_mutable_list))); + if (Yap_heap_regs->wl.dynamic_arrays) { + Yap_heap_regs->wl.dynamic_arrays = + PtoArrayEAdjust(Yap_heap_regs->wl.dynamic_arrays); + } + if (Yap_heap_regs->wl.static_arrays) { + Yap_heap_regs->wl.static_arrays = + PtoArraySAdjust(Yap_heap_regs->wl.static_arrays); + } #endif #endif if (Yap_heap_regs->last_wtime != NULL) @@ -1035,10 +1042,14 @@ RestoreEntries(PropEntry *pp) ae->NextOfPE = PropAdjust(ae->NextOfPE); if (ae->ArrayEArity < 0) { - restore_static_array((StaticArrayEntry *)ae); + /* static array entry */ + StaticArrayEntry *sae = (StaticArrayEntry *)ae; + if (sae->NextAE) + sae->NextAE = PtoArraySAdjust(sae->NextAE); + restore_static_array(sae); } else { - if (ae->NextArrayE != NULL) - ae->NextArrayE = PtoArrayEAdjust(ae->NextArrayE); + if (ae->NextAE) + ae->NextAE = PtoArrayEAdjust(ae->NextAE); if (IsVarTerm(ae->ValueOfVE)) RESET_VARIABLE(&(ae->ValueOfVE)); else { diff --git a/H/sshift.h b/H/sshift.h index 5c53054f7..5119c67b4 100644 --- a/H/sshift.h +++ b/H/sshift.h @@ -472,6 +472,15 @@ PtoArrayEAdjust (ArrayEntry * ptr) } +inline EXTERN StaticArrayEntry *PtoArraySAdjust (StaticArrayEntry *); + +inline EXTERN StaticArrayEntry * +PtoArraySAdjust (StaticArrayEntry * ptr) +{ + return (StaticArrayEntry *) (((StaticArrayEntry *) (CharP (ptr) + HDiff))); +} + + inline EXTERN struct logic_upd_clause *PtoLUCAdjust (struct logic_upd_clause *); diff --git a/Makefile.in b/Makefile.in index 59f6debac..2e02aa269 100644 --- a/Makefile.in +++ b/Makefile.in @@ -541,8 +541,11 @@ install_data: @ENABLE_JPL@ (cd LGPL/JPL/java; make install) $(INSTALL_DATA) $(srcdir)/LGPL/pillow/icon_address.pl $(DESTDIR)$(SHAREDIR)/Yap/ $(INSTALL_DATA) $(srcdir)/LGPL/pillow/pillow.pl $(DESTDIR)$(SHAREDIR)/Yap/ - (cd CLPQR ; make install) - (cd CHR ; make install) +# (cd CLPQR ; make install) + (cd LGPL/clp ; make install) + (cd LGPL/clpr ; make install) +# (cd CHR ; make install) + (cd LGPL/chr ; make install) (cd CLPBN ; make install) diff --git a/configure b/configure index 794f235f5..bbb39bd97 100755 --- a/configure +++ b/configure @@ -12881,7 +12881,8 @@ _ACEOF -for ac_func in acosh asinh atanh chdir dlopen dup2 + +for ac_func in acosh asinh atanh chdir ctime dlopen dup2 do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 @@ -14864,8 +14865,11 @@ mkdir -p LGPL/JPL/java mkdir -p LGPL/JPL/java/jpl mkdir -p LGPL/JPL/java/jpl/fli mkdir -p LGPL/JPL/src +mkdir -p LGPL/clp +mkdir -p LGPL/clpr +mkdir -p LGPL/chr - ac_config_files="$ac_config_files Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile CHR/Makefile CLPBN/Makefile CLPQR/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap" + ac_config_files="$ac_config_files Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/chr/Makefile LGPL/chr/chr_swi_bootstrap.yap CLPBN/Makefile LGPL/clp/Makefile LGPL/clpr/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure @@ -15399,9 +15403,11 @@ do "library/mpi/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/mpi/Makefile" ;; ".depend" ) CONFIG_FILES="$CONFIG_FILES .depend" ;; "library/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/Makefile" ;; - "CHR/Makefile" ) CONFIG_FILES="$CONFIG_FILES CHR/Makefile" ;; + "LGPL/chr/Makefile" ) CONFIG_FILES="$CONFIG_FILES LGPL/chr/Makefile" ;; + "LGPL/chr/chr_swi_bootstrap.yap" ) CONFIG_FILES="$CONFIG_FILES LGPL/chr/chr_swi_bootstrap.yap" ;; "CLPBN/Makefile" ) CONFIG_FILES="$CONFIG_FILES CLPBN/Makefile" ;; - "CLPQR/Makefile" ) CONFIG_FILES="$CONFIG_FILES CLPQR/Makefile" ;; + "LGPL/clp/Makefile" ) CONFIG_FILES="$CONFIG_FILES LGPL/clp/Makefile" ;; + "LGPL/clpr/Makefile" ) CONFIG_FILES="$CONFIG_FILES LGPL/clpr/Makefile" ;; "library/Tries/Makefile" ) CONFIG_FILES="$CONFIG_FILES library/Tries/Makefile" ;; "LGPL/JPL/Makefile" ) CONFIG_FILES="$CONFIG_FILES LGPL/JPL/Makefile" ;; "LGPL/JPL/src/Makefile" ) CONFIG_FILES="$CONFIG_FILES LGPL/JPL/src/Makefile" ;; diff --git a/configure.in b/configure.in index 9a37076bb..597c62628 100644 --- a/configure.in +++ b/configure.in @@ -997,7 +997,7 @@ fi dnl Checks for library functions. AC_TYPE_SIGNAL -AC_CHECK_FUNCS(acosh asinh atanh chdir dlopen dup2) +AC_CHECK_FUNCS(acosh asinh atanh chdir ctime dlopen dup2) AC_CHECK_FUNCS(fesettrapenable finite getcwd getenv) AC_CHECK_FUNCS(gethostbyname gethostid gethostname) AC_CHECK_FUNCS(gethrtime getpwnam getrusage gettimeofday getwd) @@ -1138,8 +1138,11 @@ mkdir -p LGPL/JPL/java mkdir -p LGPL/JPL/java/jpl mkdir -p LGPL/JPL/java/jpl/fli mkdir -p LGPL/JPL/src +mkdir -p LGPL/clp +mkdir -p LGPL/clpr +mkdir -p LGPL/chr -AC_OUTPUT(Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile CHR/Makefile CLPBN/Makefile CLPQR/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap) +AC_OUTPUT(Makefile library/regex/Makefile library/system/Makefile library/random/Makefile library/yap2swi/Makefile library/mpi/Makefile .depend library/Makefile LGPL/chr/Makefile LGPL/chr/chr_swi_bootstrap.yap CLPBN/Makefile LGPL/clp/Makefile LGPL/clpr/Makefile library/Tries/Makefile LGPL/JPL/Makefile LGPL/JPL/src/Makefile LGPL/JPL/java/Makefile LGPL/JPL/jpl_paths.yap) make depend diff --git a/include/yap_structs.h b/include/yap_structs.h index c897a00ae..bda3a032c 100644 --- a/include/yap_structs.h +++ b/include/yap_structs.h @@ -87,6 +87,8 @@ typedef struct { char *YapPrologGoal; /* if NON-NULL, a goal to run as top-level */ char *YapPrologTopLevelGoal; + /* if NON-NULL, a path to extend file-search-path */ + char *YapPrologAddPath; /* if previous NON-NULL and TRUE, halt after consulting that file */ int HaltAfterConsult; /* ignore .yaprc, .prolog.ini, etc. files. */ diff --git a/library/Makefile.in b/library/Makefile.in index 5843a9f5c..d30bfec42 100644 --- a/library/Makefile.in +++ b/library/Makefile.in @@ -29,7 +29,9 @@ PROGRAMS= $(srcdir)/apply_macros.yap \ $(srcdir)/avl.yap \ $(srcdir)/charsio.yap \ $(srcdir)/cleanup.yap \ + $(srcdir)/gensym.yap \ $(srcdir)/heaps.yap \ + $(srcdir)/listing.yap \ $(srcdir)/lists.yap \ $(srcdir)/logtalk.yap \ $(srcdir)/ordsets.yap \ diff --git a/library/ordsets.yap b/library/ordsets.yap index 1831eb84c..6b486a426 100644 --- a/library/ordsets.yap +++ b/library/ordsets.yap @@ -36,9 +36,14 @@ ord_symdiff/3, % Set x Set -> Set ord_union/2, % Set^2 -> Set ord_union/3, % Set x Set -> Set - ord_union/4 % Set x Set -> Set x Set + ord_union/4, % Set x Set -> Set x Set, + ord_empty/1, % -> Set + ord_memberchk/2 % Element X Set ]). +:- use_module(library(lists), + [memberchk/2]). + /* :- mode list_to_ord_set(+, ?), @@ -347,3 +352,8 @@ ord_union_all(N,Sets0,Union,Sets) :- ord_union(X, Y, Union) ). +ord_empty([]). + +ord_memberchk(Element, Set) :- + memberchk(Element, Set). + diff --git a/library/prandom.yap b/library/prandom.yap index b2004324d..6d5c80ac5 100644 --- a/library/prandom.yap +++ b/library/prandom.yap @@ -56,13 +56,13 @@ % % wsize(32) :- - yap_flag(max_integer,2147483647), !. + yap_flag(max_tagged_integer,I), I >> 32 =:= 0, !. wsize(64). ranstart :- ranstart(8'365). ranstart(N) :- - wsize(32), % bits available for int. + wsize(Wsize), % bits available for int. MaxInt is \(1 << (Wsize - 1)), % all bits but sign bit are 1. Incr is (8'154 << (Wsize - 9)) + 1, % per Knuth, v.2 p.78 Mult is 8'3655, % OK for 16-18 Wsize diff --git a/library/swi.yap b/library/swi.yap index 2a5652770..8538c1b9b 100644 --- a/library/swi.yap +++ b/library/swi.yap @@ -1,4 +1,10 @@ +:- source. + +:- style_check(all). + +:- yap_flag(unknown,error). + % redefines stuff in prolog module. :- module(swi, []). @@ -13,7 +19,8 @@ mktime/2]). :- use_module(library(terms),[term_variables/2, - term_variables/3]). + term_variables/3, + term_hash/2]). :- multifile prolog:message/3. @@ -111,7 +118,7 @@ prolog:b_getval(GlobalVariable,Value) :- prolog:b_setval(GlobalVariable,Value) :- array(GlobalVariable,1), - update_array(GlobalVariable,0,Value). + dynamic_update_array(GlobalVariable,0,Value). prolog:nb_getval(GlobalVariable,Value) :- array_element(GlobalVariable,0,Value). @@ -124,7 +131,7 @@ prolog:nb_delete(GlobalVariable) :- close_static_array(GlobalVariable). prolog:nb_current(GlobalVariable,Val) :- - static_array_properties(GlobalVariable,1,term), + static_array_properties(GlobalVariable,1,nb_term), array_element(GlobalVariable,0,Val). % SWI has a dynamic attribute scheme @@ -141,7 +148,7 @@ prolog:del_attr(Var, Mod) :- AttTerm =.. [Mod,_,_], attributes:del_all_module_atts(Var, AttTerm). -prolog:get_attrs(Var, SWIAtts) :- +prolog:get_attrs(AttVar, SWIAtts) :- get_all_swi_atts(AttVar,SWIAtts). prolog:put_attrs(_, []). @@ -164,7 +171,7 @@ prolog:append([],L,L). prolog:append([X|L0],L,[X|Lf]) :- prolog:append(L0,L,Lf). -prolog:member(X[X|_]). +prolog:member(X,[X|_]). prolog:member(X,[_|L0]) :- prolog:member(X,L0). @@ -188,7 +195,49 @@ prolog:get_time(Secs) :- datime(Datime), mktime(Datime, Secs). % Time is received as int, and converted to "..." prolog:convert_time(X,Y) :- swi:ctime(X,Y). +:- hide(atom_concat). + +prolog:atom_concat(A,B) :- atomic_concat(A,B). + +prolog:atom_concat(A,B,C) :- atomic_concat(A,B,C). + +:- hide(create_mutable). + +:- hide(get_mutable). + +:- hide(update_mutable). + +prolog:hash_term(X,Y) :- term_hash(X,Y). + +:- meta_predicate prolog:maplist(:,?), prolog:maplist(:,?,?), prolog:maplist(:,?,?). +prolog:maplist(_, []). +prolog:maplist(G, [H|L]) :- + call(G,H), + prolog:maplist(G, L). + +prolog:maplist(_, [], []). +prolog:maplist(G, [H1|L1], [H2|L2]) :- + call(G,H1,H2), + prolog:maplist(G, L1, L2). + +prolog:maplist(_, [], [], []). +prolog:maplist(G, [H1|L1], [H2|L2], [H3|L3]) :- + call(G,H1,H2,H3), + prolog:maplist(G, L1, L2, L3). + +prolog:make. + +prolog:source_location(File,Line) :- + prolog_load_context(file, File), + prolog_load_context(term_position, '$stream_position'(_,Line,_)). + +prolog:memberchk(Element, [Element|_]) :- !. +prolog:memberchk(Element, [_|Rest]) :- + prolog:memberchk(Element, Rest). + + + diff --git a/library/ypp.yap b/library/ypp.yap index 24724b6c6..a5fa60f3b 100644 --- a/library/ypp.yap +++ b/library/ypp.yap @@ -4,7 +4,7 @@ % % Author: Nuno Fonseca (nunofonseca@acm.org) % Date: 2005-05-14 -% $Id: ypp.yap,v 1.1 2005-06-06 05:10:37 vsc Exp $ +% $Id: ypp.yap,v 1.2 2005-10-28 17:38:50 vsc Exp $ % %==================================================================================== @@ -39,6 +39,8 @@ ypp_define(Name,Value):- ypp_undefine(Name):- ground(Name), + del_define(Name). + ypp_extcmd(Cmd):- ground(Cmd),!, eraseall('____ypp_extcmd'), diff --git a/pl/boot.yap b/pl/boot.yap index fae85d12f..e05a9ceb9 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -37,6 +37,7 @@ true :- true. '$system_catch'('$enter_top_level',Module,Error,user:'$Error'(Error)). '$init_system' :- + '$add_alias_to_stream'('$loop_stream','$stream'(0)), % do catch as early as possible ( '$access_yap_flags'(15, 0), \+ '$uncaught_throw' -> @@ -148,6 +149,11 @@ true :- true. '$sync_mmapped_arrays', set_value('$live','$false'). +'$startup_goals' :- + get_value('$extend_file_search_path',P), P \= [], + set_value('$extend_file_search_path',[]), + '$extend_file_search_path'(P), + fail. '$startup_goals' :- recorded('$startup_goal',G,_), '$current_module'(Module), @@ -492,12 +498,12 @@ repeat :- '$repeat'. '$write_answer'(_,_,_) :- '$flush_all_streams', fail. -'$write_answer'(Vs, LBlk, LAnsw) :- +'$write_answer'(Vs, LBlk, FLAnsw) :- '$purge_dontcares'(Vs,IVs), '$sort'(IVs, NVs), '$prep_answer_var_by_var'(NVs, LAnsw, LBlk), '$name_vars_in_goals'(LAnsw, Vs, NLAnsw), - '$write_vars_and_goals'(NLAnsw). + '$write_vars_and_goals'(NLAnsw, FLAnsw). '$purge_dontcares'([],[]). '$purge_dontcares'([[[95|_]|_]|Vs],NVs) :- !, @@ -536,25 +542,25 @@ repeat :- '$repeat'. C is I1+65, '$gen_name_string'(I2,[C|L0],LF). -'$write_vars_and_goals'([]). -'$write_vars_and_goals'([G1|LG]) :- - '$write_goal_output'(G1), - '$write_remaining_vars_and_goals'(LG). +'$write_vars_and_goals'([], []). +'$write_vars_and_goals'([G1|LG], NG) :- + '$write_goal_output'(G1, NG, IG), + '$write_remaining_vars_and_goals'(LG, IG). -'$write_remaining_vars_and_goals'([]). -'$write_remaining_vars_and_goals'([nl,G1|LG]) :- !, +'$write_remaining_vars_and_goals'([], []). +'$write_remaining_vars_and_goals'([nl,G1|LG], NG) :- !, nl(user_error), - '$write_goal_output'(G1), - '$write_remaining_vars_and_goals'(LG). -'$write_remaining_vars_and_goals'([G1|LG]) :- + '$write_goal_output'(G1, NG, IG), + '$write_remaining_vars_and_goals'(LG, IG). +'$write_remaining_vars_and_goals'([G1|LG], NG) :- ( LG = [] -> nl(user_error) ; format(user_error,',~n',[]) ), - '$write_goal_output'(G1), - '$write_remaining_vars_and_goals'(LG). + '$write_goal_output'(G1, NG, IG), + '$write_remaining_vars_and_goals'(LG, IG). -'$write_goal_output'(var([V|VL])) :- +'$write_goal_output'(var([V|VL]), [var([V|VL])|L], L) :- format(user_error,'~s',[V]), '$write_output_vars'(VL). -'$write_goal_output'(nonvar([V|VL],B)) :- +'$write_goal_output'(nonvar([V|VL],B), [nonvar([V|VL],B)|L], L) :- format(user_error,'~s',[V]), '$write_output_vars'(VL), format(user_error,' = ', []), @@ -562,17 +568,17 @@ repeat :- '$repeat'. write_term(user_error,B,Opts) ; format(user_error,'~w',[B]) ). -'$write_goal_output'(Format-G) :- +'$write_goal_output'(Format-G, NG, NG) :- G = [_|_], !, format(user_error,Format,G). -'$write_goal_output'(_-G) :- +'$write_goal_output'(_-G, NG, NG) :- ( recorded('$print_options','$toplevel'(Opts),_) -> write_term(user_error,G,Opts) ; format(user_error,'~w',[G]) ). '$name_vars_in_goals'(G, VL0, NG) :- - '$copy_term_but_not_constraints'(G+VL0, NG+NVL0), + copy_term_nat(G+VL0, NG+NVL0), '$name_well_known_vars'(NVL0), '$variables_in_term'(NG, [], NGVL), '$name_vars_in_goals1'(NGVL, 0, _). @@ -799,21 +805,38 @@ break :- (nonvar(Debug) -> recorda('$debug',Debug,_); true), set_value('$break',BL). +'$silent_bootstrap'(F) :- + get_value('$lf_verbose',OldSilent), + set_value('$lf_verbose',silent), + bootstrap(F), + set_value('$lf_verbose', OldSilent). bootstrap(F) :- '$open'(F,'$csult',Stream,0), - H0 is heapused, '$cputime'(T0,_), '$current_stream'(File,_,Stream), '$start_consult'(consult, File, LC), file_directory_name(File, Dir), '$getcwd'(OldD), cd(Dir), - format(user_error, '~*|% consulting ~w...~n', [LC,F]), + ( + get_value('$lf_verbose',silent) + -> + true + ; + H0 is heapused, '$cputime'(T0,_), + format(user_error, '~*|% consulting ~w...~n', [LC,F]) + ), '$loop'(Stream,consult), cd(OldD), '$end_consult', - H is heapused-H0, '$cputime'(TF,_), T is TF-T0, - format(user_error, '~*|% ~w consulted ~w bytes in ~d msecs~n', [LC,F,H,T]), + ( + get_value('$lf_verbose',silent) + -> + true + ; + H is heapused-H0, '$cputime'(TF,_), T is TF-T0, + format(user_error, '~*|% ~w consulted ~w bytes in ~d msecs~n', [LC,F,H,T]) + ), !. diff --git a/pl/checker.yap b/pl/checker.yap index 6daba9e1f..7faa1b213 100644 --- a/pl/checker.yap +++ b/pl/checker.yap @@ -11,8 +11,11 @@ * File: checker.yap * * comments: style checker for Prolog * * * -* Last rev: $Date: 2005-04-20 20:06:11 $,$Author: vsc $ * +* Last rev: $Date: 2005-10-28 17:38:50 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.18 2005/04/20 20:06:11 vsc +* try to improve error handling and warnings from within consults. +* * Revision 1.17 2005/04/20 04:08:20 vsc * fix warnings * @@ -53,8 +56,12 @@ style_check(all) :- '$syntax_check_mode'(_,on), '$syntax_check_multiple'(_,on). style_check(single_var) :- '$syntax_check_mode'(_,on), '$syntax_check_single_var'(_,on). +style_check(singleton) :- + style_check(single_var). style_check(-single_var) :- no_style_check(single_var). +style_check(-singleton) :- + no_style_check(single_var). style_check(discontiguous) :- '$syntax_check_mode'(_,on), '$syntax_check_discontiguous'(_,on). style_check(-discontiguous) :- @@ -188,7 +195,7 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$multifile'(V, _) :- var(V), !, '$do_error'(instantiation_error,multifile(V)). -'$multifile'((X,Y), M) :- '$multifile'(X, M), '$multifile'(Y, M). +'$multifile'((X,Y), M) :- !, '$multifile'(X, M), '$multifile'(Y, M). '$multifile'(Mod:PredSpec, _) :- !, '$multifile'(PredSpec, Mod). '$multifile'(N/A, M) :- diff --git a/pl/consult.yap b/pl/consult.yap index b8c01216b..08fa18bb2 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -33,8 +33,9 @@ load_files(Files,Opts) :- '$load_files'(Files,Opts,Call) :- '$process_lf_opts'(Opts,Silent,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult,Files,Call), + '$check_use_module'(Call,UseModule), '$current_module'(M0), - '$lf'(Files,M0,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult), + '$lf'(Files,M0,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult,UseModule), '$close_lf'(Silent). '$process_lf_opts'(V,_,_,_,_,_,_,_,_,_,_,Call) :- @@ -83,48 +84,56 @@ load_files(Files,Opts) :- /* ( '$stream'(Stream) -> true ; '$do_error'(domain_error(stream,Stream),Call) ), */ ( atom(Files) -> true ; '$do_error'(type_error(atom,Files),Call) ). -'$lf'(V,_,Call,_,_,_,_,_,_,_) :- var(V), !, +'$check_use_module'(use_module(_),use_module(_)) :- !. +'$check_use_module'(use_module(_,_),use_module(_)) :- !. +'$check_use_module'(use_module(M,_,_),use_module(M)) :- !. +'$check_use_module'(_,load_files) :- !. + +'$lf'(V,_,Call,_,_,_,_,_,_,_,_) :- var(V), !, '$do_error'(instantiation_error,Call). -'$lf'([],_,_,_,_,_,_,_,_,_,_) :- !. -'$lf'(M:X, _, Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult) :- !, +'$lf'([],_,_,_,_,_,_,_,_,_,_,_) :- !. +'$lf'(M:X, _, Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult,UseModule) :- !, ( atom(M) -> - '$lf'(X, M, Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult) + '$lf'(X, M, Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult,UseModule) ; '$do_error'(type_error(atom,M),Call) ). -'$lf'([F|Fs], Mod,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult) :- !, - '$lf'(F, Mod,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult), - '$lf'(Fs, Mod,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult). -'$lf'(X, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,Stream,_,Reconsult) :- +'$lf'([F|Fs], Mod,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult,UseModule) :- !, + '$lf'(F, Mod,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult,UseModule), + '$lf'(Fs, Mod,Call,InfLevel,Expand,Changed,CompilationMode,Imports,Stream,Encoding,Reconsult,UseModule). +'$lf'(X, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,Stream,_,Reconsult,UseModule) :- nonvar(Stream), !, - '$do_lf'(X, Mod, Stream, InfLevel,CompilationMode,Imports,Reconsult). -'$lf'(user, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,Reconsult) :- !, - '$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,Reconsult). -'$lf'(user_input, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_) :- !, - '$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports). -'$lf'(X, Mod, Call, InfLevel,_,Changed,CompilationMode,Imports,_,_,Reconsult) :- + '$do_lf'(X, Mod, Stream, InfLevel,CompilationMode,Imports,Reconsult,UseModule). +'$lf'(user, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,Reconsult,UseModule) :- !, + '$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,Reconsult,UseModule). +'$lf'(user_input, Mod, Call,InfLevel,_,Changed,CompilationMode,Imports,_,_,UseModule) :- !, + '$do_lf'(user_input, Mod, user_input, InfLevel, CompilationMode,Imports,UseModule). +'$lf'(X, Mod, Call, InfLevel,_,Changed,CompilationMode,Imports,_,_,Reconsult,UseModule) :- '$find_in_path'(X, Y, Call), '$open'(Y, '$csult', Stream, 0), !, - '$start_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, Changed,Reconsult), + '$set_changed_lfmode'(Changed), + '$start_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, Changed,Reconsult,UseModule), '$close'(Stream). -'$lf'(X, _, Call, _, _, _, _, _, _, _,_) :- +'$lf'(X, _, Call, _, _, _, _, _, _, _,_,_) :- '$do_error'(permission_error(input,stream,X),Call). +'$set_changed_lfmode'(true) :- !. +'$set_changed_lfmode'(_). -'$start_lf'(_, Mod, Stream,_ ,_, Imports, not_loaded, _) :- +'$start_lf'(_, Mod, Stream,_ ,_, Imports, not_loaded, _,_) :- '$file_loaded'(Stream, Mod, Imports), !. -'$start_lf'(_, Mod, Stream, _, _, Imports, changed, _) :- +'$start_lf'(_, Mod, Stream, _, _, Imports, changed, _,_) :- '$file_unchanged'(Stream, Mod, Imports), !. -'$start_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, _, Reconsult) :- - '$do_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, Reconsult). +'$start_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, _, Reconsult, UseModule) :- + '$do_lf'(X, Mod, Stream, InfLevel, CompilationMode, Imports, Reconsult, UseModule). '$close_lf'(Silent) :- nonvar(Silent), !, set_value('$lf_verbose',Silent). '$close_lf'(_). - + ensure_loaded(Fs) :- '$load_files'(Fs, [if(changed)],ensure_loaded(Fs)). @@ -154,13 +163,13 @@ reconsult(Fs) :- '$load_files'(Fs, [], reconsult(Fs)). use_module(F) :- - '$load_files'(F, [if(not_loaded)],use_module(F)). + '$load_files'(F, [if(not_loaded)], use_module(F)). use_module(F,Is) :- - '$load_files'(F, [if(not_loaded),imports(Is)],use_module(F,Is)). + '$load_files'(F, [if(not_loaded),imports(Is)], use_module(F,Is)). use_module(M,F,Is) :- - '$load_files'(F, [if(not_loaded),imports(Is)],use_module(M,F,Is)). + '$load_files'(F, [if(not_loaded),imports(Is)], use_module(M,F,Is)). '$csult'(V, _) :- var(V), !, '$do_error'(instantiation_error,consult(V)). @@ -168,7 +177,7 @@ use_module(M,F,Is) :- '$csult'([-F|L], M) :- !, '$load_files'(M:F, [],[-M:F]), '$csult'(L, M). '$csult'([F|L], M) :- '$consult'(F, M), '$csult'(L, M). -'$do_lf'(F, ContextModule, Stream, InfLevel, _, Imports, Reconsult) :- +'$do_lf'(F, ContextModule, Stream, InfLevel, _, Imports, Reconsult, UseModule) :- '$record_loaded'(Stream, M), '$current_module'(OldModule,ContextModule), '$getcwd'(OldD), @@ -176,6 +185,8 @@ use_module(M,F,Is) :- '$set_consulting_file'(Stream), H0 is heapused, '$cputime'(T0,_), '$current_stream'(File,_,Stream), + '$fetch_stream_alias'(OldStream,'$loop_stream'), + '$change_alias_to_stream'('$loop_stream',Stream), get_value('$consulting',Old), set_value('$consulting',false), '$consult_infolevel'(InfLevel), @@ -206,13 +217,18 @@ use_module(M,F,Is) :- set_value('$consulting_file',OldF), cd(OldD), '$current_module'(Mod,OldModule), + '$bind_module'(Mod, UseModule), '$import_to_current_module'(File, ContextModule, Imports), ( LC == 0 -> prompt(_,' |: ') ; true), H is heapused-H0, '$cputime'(TF,_), T is TF-T0, '$print_message'(InfLevel, loaded(EndMsg, File, Mod, T, H)), '$exec_initialisation_goals', + '$change_alias_to_stream'('$loop_stream',OldStream), !. +'$bind_module'(_, load_files). +'$bind_module'(Mod, use_module(Mod)). + '$import_to_current_module'(File, M, Imports) :- recorded('$module','$module'(File,NM,Ps),_), M \= NM, !, '$use_preds'(Imports, Ps, NM, M). @@ -220,7 +236,7 @@ use_module(M,F,Is) :- '$consult_infolevel'(InfoLevel) :- nonvar(InfoLevel), !. '$consult_infolevel'(InfoLevel) :- - get_value('$lf_verbose',InfoLevel), !. + get_value('$lf_verbose',InfoLevel), InfoLevel \= [], !. '$consult_infolevel'(informational). '$start_reconsulting'(F) :- @@ -309,9 +325,9 @@ prolog_load_context(module, X) :- prolog_load_context(source, FileName) :- get_value('$consulting_file',FileName). prolog_load_context(stream, Stream) :- - '$fetch_stream_alias'('$loop_stream', Stream). + '$fetch_stream_alias'(Stream,'$loop_stream'). prolog_load_context(term_position, Position) :- - '$fetch_stream_alias'('$loop_stream', Stream), + '$fetch_stream_alias'(Stream,'$loop_stream'). stream_position(Stream, Position). diff --git a/pl/corout.yap b/pl/corout.yap index 88b516049..c24a6c5d3 100644 --- a/pl/corout.yap +++ b/pl/corout.yap @@ -565,13 +565,13 @@ call_residue(Goal,Residue) :- '$call_residue'(Goal,Module,Residue) :- '$read_svar_list'(OldAttsList), - '$copy_term_but_not_constraints'(Goal, NGoal), + copy_term_nat(Goal, NGoal), ( '$set_svar_list'(CurrentAttsList), '$system_catch'(NGoal,Module,Error,'$residue_catch_trap'(Error,OldAttsList)), '$call_residue_continuation'(NGoal,NResidue), ( '$set_svar_list'(OldAttsList), - '$copy_term_but_not_constraints'(NGoal+NResidue, Goal+Residue) + copy_term_nat(NGoal+NResidue, Goal+Residue) ; '$set_svar_list'(CurrentAttsList), fail ) diff --git a/pl/directives.yap b/pl/directives.yap index 7ec5b4662..704a520a9 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -177,6 +177,16 @@ yap_flag(syntax_errors, Option) :- yap_flag(enhanced,on) :- !, set_value('$enhanced',true). yap_flag(enhanced,off) :- set_value('$enhanced',[]). % +% SWI compatibility flag +% +yap_flag(generate_debug_info,V) :- var(V), !, + source_mode(OnOff,OnOff), + (OnOff = on -> V = true ; V = false). +yap_flag(generate_debug_info,true) :- !. +yap_flag(generate_debug_info,false) :- !. +yap_flag(generate_debug_info,X) :- + '$do_error'(domain_error(flag_value,generate_domain_info+X),yap_flag(generate_debug_info,X)). +% % show state of $ % yap_flag(dollar_as_lower_case,V) :- @@ -295,6 +305,15 @@ yap_flag(max_integer,X) :- yap_flag(max_integer,X) :- '$do_error'(domain_error(flag_value,max_integer+X),yap_flag(max_integer,X)). +yap_flag(max_tagged_integer,X) :- + var(X), !, + '$max_tagged_integer'(X). +yap_flag(max_tagged_integer,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,max_tagged_integer),yap_flag(max_tagged_integer,X)). +yap_flag(max_tagged_integer,X) :- + '$do_error'(domain_error(flag_value,max_tagged_integer+X),yap_flag(max_tagged_integer,X)). + yap_flag(min_integer,X) :- var(X), !, '$access_yap_flags'(0, 1), @@ -305,6 +324,15 @@ yap_flag(min_integer,X) :- yap_flag(min_integer,X) :- '$do_error'(domain_error(flag_value,min_integer+X),yap_flag(min_integer,X)). +yap_flag(min_tagged_integer,X) :- + var(X), !, + '$min_tagged_integer'( X). +yap_flag(min_tagged_integer,X) :- + integer(X), X > 0, !, + '$do_error'(permission_error(modify,flag,min_tagged_integer),yap_flag(min_tagged_integer,X)). +yap_flag(min_tagged_integer,X) :- + '$do_error'(domain_error(flag_value,min_tagged_integer+X),yap_flag(min_tagged_integer,X)). + yap_flag(char_conversion,X) :- var(X), !, '$access_yap_flags'(5, X1), @@ -621,6 +649,7 @@ yap_flag(verbose_auto_load,X) :- V = gc ; V = gc_margin ; V = gc_trace ; + V = generate_debug_info ; % V = hide ; V = home ; V = host_type ; @@ -631,7 +660,9 @@ yap_flag(verbose_auto_load,X) :- V = language ; V = max_arity ; V = max_integer ; + V = max_tagged_integer ; V = min_integer ; + V = min_tagged_integer ; V = n_of_integer_keys_in_db ; V = profiling ; V = redefine_warnings ; diff --git a/pl/errors.yap b/pl/errors.yap index de3b08d10..2765e2874 100644 --- a/pl/errors.yap +++ b/pl/errors.yap @@ -11,8 +11,38 @@ * File: errors.yap * * comments: error messages for YAP * * * -* Last rev: $Date: 2005-10-18 17:04:43 $,$Author: vsc $ * +* Last rev: $Date: 2005-10-28 17:38:50 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.66 2005/10/18 17:04:43 vsc +* 5.1: +* - improvements to GC +* 2 generations +* generic speedups +* - new scheme for attvars +* - hProlog like interface also supported +* - SWI compatibility layer +* - extra predicates +* - global variables +* - moved to Prolog module +* - CLP(R) by Leslie De Koninck, Tom Schrijvers, Cristian Holzbaur, Bart +* Demoen and Jan Wielemacker +* - load_files/2 +* +* from 5.0.1 +* +* - WIN32 missing include files (untested) +* - -L trouble (my thanks to Takeyuchi Shiramoto-san)! +* - debugging of backtrable user-C preds would core dump. +* - redeclaring a C-predicate as Prolog core dumps. +* - badly protected YapInterface.h. +* - break/0 was failing at exit. +* - YAP_cut_fail and YAP_cut_succeed were different from manual. +* - tracing through data-bases could core dump. +* - cut could break on very large computations. +* - first pass at BigNum issues (reported by Roberto). +* - debugger could get go awol after fail port. +* - weird message on wrong debugger option. +* * Revision 1.65 2005/05/25 21:43:33 vsc * fix compiler bug in 1 << X, found by Nuno Fonseca. * compiler internal errors get their own message. @@ -236,7 +266,7 @@ print_message(Level, Mss) :- '$do_print_message'(declaration(Args,Action)) :- !, format(user_error,'declaration ~w ~w.', [Args,Action]). '$do_print_message'(defined_elsewhere(P,F)) :- !, - format(user_error, 'predicate ~q, at line ~d, previously defined in file ~a.',[P,LN,F]). + format(user_error, 'predicate ~q previously defined in file ~a.',[P,F]). '$do_print_message'(import(Pred,To,From,private)) :- !, format(user_error,'Importing private predicate ~w:~w to ~w.', [From,Pred,To]). diff --git a/pl/modules.yap b/pl/modules.yap index 423371c00..4ef988b13 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -92,7 +92,7 @@ module(N) :- '$process_exports'([Name/Arity|Exports],Mod,[Name/Arity|ExportedPreds]):- !, '$process_exports'(Exports,Mod,ExportedPreds). '$process_exports'([op(Prio,Assoc,Name)|Exports],Mod,ExportedPreds) :- !, - '$opdec'(Prio,Assoc,Name,Mod), +% '$opdec'(Prio,Assoc,Name,Mod), '$process_exports'(Exports,Mod,ExportedPreds). '$process_exports'([Trash|Exports],Mod,_) :- '$do_error'(type_error(predicate_indicator,Trash),module(Mod,[Trash])). @@ -134,7 +134,8 @@ module(N) :- '$do_error'(domain_error(predicate_spec,PS),import([PS|L])). '$check_import'(M,T,N,K) :- - recorded('$import','$import'(M1,T,N,K),R), M1 \= M, /* ZP */ !, + recorded('$import','$import'(MI,T,N,K),_), + \+ '$module_produced by'(M,T,N,K), !, format(user_error,"NAME CLASH: ~w was already imported to module ~w;~n",[M1:N/K,T]), format(user_error," Do you want to import it from ~w ? [y or n] ",M), repeat, @@ -145,6 +146,12 @@ module(N) :- ). '$check_import'(_,_,_,_). +'$module_produced by'(M,M0,N,K) :- + recorded('$import','$import'(M,M0,N,K),_), !. +'$module_produced by'(M,M0,N,K) :- + recorded('$import','$import'(MI,M0,N,K),_), + '$module_produced by'(M,MI,N,K). + % $use_preds(Imports,Publics,Mod,M) '$use_preds'(Imports,Publics,Mod,M) :- var(Imports), !, '$import'(Publics,Mod,M). @@ -461,6 +468,8 @@ source_module(Mod) :- call_with_args(:,?,?,?,?,?,?,?), call_with_args(:,?,?,?,?,?,?,?,?), call_with_args(:,?,?,?,?,?,?,?,?,?), + format(+,:), + format(+,+,:), call_residue(:,?), catch(:,+,:), clause(:,?), diff --git a/pl/utils.yap b/pl/utils.yap index c7068bade..3b3c0f50d 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -24,10 +24,17 @@ if(X,Y,_Z) :- '$execute'(Y). if(_X,_Y,Z) :- '$execute'(Z). - + +call(X,A) :- '$execute'(X,A). + +call(X,A1,A2) :- '$execute'(X,A1,A2). + +call(X,A1,A2,A3) :- '$execute'(X,A1,A2,A3). call_with_args(M:V) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V)). +call_with_args(_:M:A) :- !, + call_with_args(M:A). call_with_args(M:A) :- !, '$call_with_args'(A,M). call_with_args(A) :- atom(A), !, @@ -39,6 +46,8 @@ call_with_args(A) :- call_with_args(M:V,A1) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1)). +call_with_args(_:M:A,A1) :- !, + call_with_args(M:A,A1). call_with_args(M:A,A1) :- !, '$call_with_args'(A,A1,M). call_with_args(A,A1) :- atom(A), !, @@ -49,6 +58,8 @@ call_with_args(A,A1) :- call_with_args(M:V,A1,A2) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2)). +call_with_args(_:M:A,A1,A2) :- !, + call_with_args(M:A,A1,A2). call_with_args(M:A,A1,A2) :- !, '$call_with_args'(A,A1,A2,M). call_with_args(A,A1,A2) :- atom(A), !, @@ -59,6 +70,8 @@ call_with_args(A,A1,A2) :- call_with_args(M:V,A1,A2,A3) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3)). +call_with_args(_:M:A,A1,A2,A3) :- !, + call_with_args(M:A,A1,A2,A3). call_with_args(M:A,A1,A2,A3) :- !, '$call_with_args'(A,A1,A2,A3,M). call_with_args(A,A1,A2,A3) :- atom(A), !, @@ -69,6 +82,8 @@ call_with_args(A,A1,A2,A3) :- call_with_args(M:V,A1,A2,A3,A4) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3,A4)). +call_with_args(_:M:A,A1,A2,A3,A4) :- !, + call_with_args(M:A,A1,A2,A3,A4). call_with_args(M:A,A1,A2,A3,A4) :- !, '$call_with_args'(A,A1,A2,A3,A4,M). call_with_args(A,A1,A2,A3,A4) :- atom(A), !, @@ -79,6 +94,8 @@ call_with_args(A,A1,A2,A3,A4) :- call_with_args(M:V,A1,A2,A3,A4,A5) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3,A4,A5)). +call_with_args(_:M:A,A1,A2,A3,A4,A5) :- !, + call_with_args(M:A,A1,A2,A3,A4,A5). call_with_args(M:A,A1,A2,A3,A4,A5) :- !, '$call_with_args'(A,A1,A2,A3,A4,A5,M). call_with_args(A,A1,A2,A3,A4,A5) :- atom(A), !, @@ -89,6 +106,8 @@ call_with_args(A,A1,A2,A3,A4,A5) :- call_with_args(M:V,A1,A2,A3,A4,A5,A6) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3,A4,A5,A6)). +call_with_args(_:M:A,A1,A2,A3,A4,A5,A6) :- !, + call_with_args(M:A,A1,A2,A3,A4,A5,A6). call_with_args(M:A,A1,A2,A3,A4,A5,A6) :- !, '$call_with_args'(A,A1,A2,A3,A4,A5,A6,M). call_with_args(A,A1,A2,A3,A4,A5,A6) :- atom(A), !, @@ -99,6 +118,8 @@ call_with_args(A,A1,A2,A3,A4,A5,A6) :- call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7)). +call_with_args(_:M:A,A1,A2,A3,A4,A5,A6,A7) :- !, + call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7) :- !, '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :- atom(A), !, @@ -109,6 +130,8 @@ call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :- call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7,A8) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7,A8)). +call_with_args(_:M:A,A1,A2,A3,A4,A5,A6,A7,A8) :- !, + call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8) :- !, '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :- atom(A), !, @@ -119,6 +142,8 @@ call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :- call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7,A8,A9)). +call_with_args(_:M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- !, + call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- !, '$current_module'(M), '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,M). @@ -131,6 +156,8 @@ call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- var(V), !, '$do_error'(instantiation_error,call_with_args(M:V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10)). +call_with_args(_:M:A,A1,A2,A3,A4,A5,A6,A7,A8,A10) :- !, + call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A10). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- !, '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- atom(A), !, diff --git a/pl/yio.yap b/pl/yio.yap index 7e8d8f156..fb8afb8a2 100644 --- a/pl/yio.yap +++ b/pl/yio.yap @@ -923,4 +923,58 @@ current_char_conversion(X,Y) :- current_stream(File, Opts, Stream) :- '$current_stream'(File, Opts, Stream). +'$extend_file_search_path'(P) :- + atom_codes(P,S), + '$env_separator'(ES), + '$split_for_path'(S,0'=,ES,Paths), + '$add_file_search_paths'(Paths). + +'$split_for_path'([], _, _, []). +'$split_for_path'(S, S1, S2, [A1=A2|R]) :- + '$fetch_first_path'(S, S1, A1, SR1), + '$fetch_second_path'(SR1, S2, A2, SR), + '$split_for_path'(SR, S1, S2, R) . + +'$fetch_first_path'([S1|SR],S1,[],SR) :- !. +'$fetch_first_path'([C|S],S1,[C|F],SR) :- + '$fetch_first_path'(S,S1,F,SR). + +'$fetch_second_path'([],_,[],[]). +'$fetch_second_path'([S1|SR],S1,[],SR) :- !. +'$fetch_second_path'([C|S],S1,[C|A2],SR) :- + '$fetch_second_path'(S,S1,A2,SR). + +'$add_file_search_paths'([]). +'$add_file_search_paths'([NS=DS|Paths]) :- + atom_codes(N,NS), + atom_codes(D,DS), + assert(user:file_search_path(N,D)), + '$add_file_search_paths'(Paths). + + +'$format@'(Goal,Out) :- + '$with_output_to_chars'(Goal, _, [], Out). + +'$with_output_to_chars'(Goal, Stream, L0, Chars) :- + charsio:open_mem_write_stream(Stream), + current_output(SO), + set_output(Stream), + '$do_output_to_chars'(Goal, Stream, L0, Chars, SO). + +'$do_output_to_chars'(Goal, Stream, L0, Chars, SO) :- + catch(Goal, Exception, '$handle_exception'(Exception,Stream,SO)), + !, + set_output(SO), + charsio:peek_mem_write_stream(Stream, L0, Chars). +'$do_output_to_chars'(_Goal, Stream, _L0, _Chars, SO) :- + set_output(SO), + close(Stream), + fail. + +'$handle_exception'(Exception, Stream, SO) :- + close(Stream), + current_output(SO), + throw(Exception). + +