new catch and throw mechanism (first try).
hide built-in predicates that should not be seen in trace mode git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@275 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
parent
cedfb57737
commit
5997e5a109
31
C/absmi.c
31
C/absmi.c
@ -1277,8 +1277,37 @@ absmi(int inp)
|
||||
case _retry_profiled:
|
||||
opnum = op_from_opcode(NEXTOP(B->cp_ap,l)->opc);
|
||||
goto restart_cp;
|
||||
default:
|
||||
case _retry_me:
|
||||
case _trust_me:
|
||||
case _profiled_retry_me:
|
||||
case _profiled_trust_me:
|
||||
case _retry_me0:
|
||||
case _trust_me0:
|
||||
case _retry_me1:
|
||||
case _trust_me1:
|
||||
case _retry_me2:
|
||||
case _trust_me2:
|
||||
case _retry_me3:
|
||||
case _trust_me3:
|
||||
case _retry_me4:
|
||||
case _trust_me4:
|
||||
case _retry_and_mark:
|
||||
case _profiled_retry_and_mark:
|
||||
case _retry:
|
||||
case _trust_in:
|
||||
case _trust:
|
||||
case _retry_first:
|
||||
case _trust_first_in:
|
||||
case _trust_first:
|
||||
case _retry_tail:
|
||||
case _trust_tail_in:
|
||||
case _trust_tail:
|
||||
case _retry_head:
|
||||
case _trust_head_in:
|
||||
case _trust_head:
|
||||
low_level_trace(retry_pred, (PredEntry *)(PREG->u.ld.p), &(B->cp_a1));
|
||||
default:
|
||||
break;
|
||||
}
|
||||
}
|
||||
#endif /* LOW_LEVEL_TRACER */
|
||||
|
||||
13
C/arith0.c
13
C/arith0.c
@ -149,7 +149,17 @@ p_env(E_ARGS)
|
||||
#if SBA
|
||||
RINT((Int)YENV);
|
||||
#else
|
||||
RINT(YENV - (CELL *)B);
|
||||
RINT(LCL0 - YENV);
|
||||
#endif
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_tr(E_ARGS)
|
||||
{
|
||||
#if SBA
|
||||
RINT(TR);
|
||||
#else
|
||||
RINT(((CELL *)TR)-LCL0);
|
||||
#endif
|
||||
}
|
||||
|
||||
@ -189,6 +199,7 @@ static InitConstEntry InitConstTab[] = {
|
||||
{"global_sp", p_globalsp},
|
||||
{"$last_choice_pt", p_b},
|
||||
{"$env", p_env},
|
||||
{"$tr", p_tr},
|
||||
{"stackfree", p_stackfree},
|
||||
};
|
||||
|
||||
|
||||
54
C/arrays.c
54
C/arrays.c
@ -1572,60 +1572,6 @@ p_sync_mmapped_arrays(void)
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
/*
|
||||
This is a hack, to steal the first element of a key.
|
||||
|
||||
It first fetches the first element in the chain, and then erases it
|
||||
through its reference.
|
||||
|
||||
Be careful when using this routine. It is especially evil because if
|
||||
the term is ground it should be copied to the stack, as space for
|
||||
the entry may be deleted. For the moment, the terms I want are just
|
||||
integers, so no problemo, amigo.
|
||||
|
||||
*/
|
||||
static Term
|
||||
StealFirstFromDB(DBRef ref)
|
||||
{
|
||||
Term TermDB, out;
|
||||
|
||||
if ((TermDB = FetchTermFromDB(ref,3)) == (CELL)0) {
|
||||
/* oops, we are in trouble, not enough stack space */
|
||||
return(TermNil);
|
||||
}
|
||||
if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
|
||||
/* it's not a wonderful world afterall */
|
||||
return(TermNil);
|
||||
out = ArgOfTerm(1,TermDB);
|
||||
/* now, return what once was there, only nevermore */
|
||||
return(out);
|
||||
}
|
||||
|
||||
Int
|
||||
SetDBForThrow(Term Message)
|
||||
{
|
||||
Term cut_pt_term;
|
||||
Atom a = FullLookupAtom("$catch_queue");
|
||||
AtomEntry *ae = RepAtom(a);
|
||||
StaticArrayEntry *ptr;
|
||||
DBRef ref;
|
||||
READ_LOCK(ae->ARWLock);
|
||||
ptr = RepStaticArrayProp(ae->PropsOfAE);
|
||||
while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
|
||||
ptr = RepStaticArrayProp(ptr->NextOfPE);
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
ref = ptr->ValueOfVE.terms[0];
|
||||
|
||||
cut_pt_term = StealFirstFromDB(ref);
|
||||
if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
|
||||
/* ooops, babe we are in trouble */
|
||||
return(-1);
|
||||
}
|
||||
/* OK, we've got the place to cut to, next store the new throw */
|
||||
ptr->ValueOfVE.terms[1] = StoreTermInDB(Message,3);
|
||||
return(IntegerOfTerm(cut_pt_term));
|
||||
}
|
||||
|
||||
void
|
||||
InitArrayPreds(void)
|
||||
{
|
||||
|
||||
108
C/errors.c
108
C/errors.c
@ -207,74 +207,6 @@ exit_yap (int value, char *msg)
|
||||
exit(value);
|
||||
}
|
||||
|
||||
void
|
||||
Abort (char *format,...)
|
||||
{
|
||||
va_list ap;
|
||||
va_start (ap, format);
|
||||
|
||||
PrologMode &= ~AbortMode;
|
||||
if (format || !strcmp(format,""))
|
||||
{
|
||||
char ch;
|
||||
while ((ch = *format++)!=0)
|
||||
if (ch != '%')
|
||||
YP_putc (ch, YP_stderr);
|
||||
else
|
||||
{
|
||||
switch (*format++)
|
||||
{
|
||||
case 'c':
|
||||
YP_putc (va_arg (ap, int), YP_stderr);
|
||||
break;
|
||||
case 's':
|
||||
YP_fprintf(YP_stderr, "%s", va_arg (ap, char *));
|
||||
break;
|
||||
case 'd':
|
||||
#if SHORT_INTS
|
||||
YP_fprintf(YP_stderr, "%ld", va_arg (ap, Int));
|
||||
#else
|
||||
YP_fprintf(YP_stderr, "%d", va_arg (ap, Int));
|
||||
#endif
|
||||
break;
|
||||
case 'x':
|
||||
#if SHORT_INTS
|
||||
YP_fprintf(YP_stderr, "%lx", va_arg (ap, Int));
|
||||
#else
|
||||
YP_fprintf(YP_stderr, "%x", va_arg (ap, Int));
|
||||
#endif
|
||||
break;
|
||||
}
|
||||
}
|
||||
YP_putc ('\n', YP_stderr);
|
||||
}
|
||||
va_end (ap);
|
||||
#ifdef DEBUGX
|
||||
DumpActiveGoals();
|
||||
#endif /* DEBUG */
|
||||
if (PrologMode & BootMode) {
|
||||
exit_yap (1, NIL);
|
||||
} else {
|
||||
PutValue(AtomThrow, MkAtomTerm(AtomFalse));
|
||||
CreepFlag = CalculateStackGap();
|
||||
#if PUSH_REGS
|
||||
restore_absmi_regs(&standard_regs);
|
||||
#endif
|
||||
#if defined(__GNUC__)
|
||||
#if (defined(hppa) || defined(__alpha))
|
||||
/* siglongjmp resets the TR hardware register */
|
||||
save_TR();
|
||||
#endif
|
||||
#if defined(__alpha)
|
||||
/* siglongjmp resets the H hardware register */
|
||||
save_H();
|
||||
#endif
|
||||
#endif
|
||||
siglongjmp (RestartEnv, 1);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static void detect_bug_location(char *tp, int psize)
|
||||
{
|
||||
Atom pred_name;
|
||||
@ -1806,34 +1738,24 @@ Error (yap_error_number type, Term where, char *format,...)
|
||||
}
|
||||
nt[1] = MkAtomTerm(LookupAtom(p));
|
||||
if (serious) {
|
||||
Int depth;
|
||||
|
||||
choiceptr newb;
|
||||
PredEntry *p = RepPredProp(PredPropByFunc(FunctorThrow,0));
|
||||
|
||||
CreepFlag = CalculateStackGap();
|
||||
ASP--;
|
||||
newb = ((choiceptr)ASP)-1;
|
||||
newb->cp_h = H;
|
||||
newb->cp_tr = TR;
|
||||
newb->cp_cp = CP;
|
||||
newb->cp_ap = (yamop *)(p->CodeOfPred);
|
||||
newb->cp_env = ENV;
|
||||
newb->cp_b = B;
|
||||
if (type == PURE_ABORT)
|
||||
depth = SetDBForThrow(MkAtomTerm(LookupAtom("abort")));
|
||||
ARG1 = newb->cp_a1 = MkAtomTerm(LookupAtom("abort"));
|
||||
else
|
||||
depth = SetDBForThrow(MkApplTerm(fun, 2, nt));
|
||||
if (depth == -1) {
|
||||
/* if we did not find an error already */
|
||||
if (P != (yamop *)FAILCODE)
|
||||
/* oops, we lost our trap handler, backtrack until the root or
|
||||
until an instance of do_goal */
|
||||
while (B->cp_b != NULL && B->cp_ap != (yamop *) NOCODE)
|
||||
B = B->cp_b;
|
||||
P = (yamop *)FAILCODE;
|
||||
PrologMode &= ~InErrorMode;
|
||||
return(P);
|
||||
}
|
||||
/* make the abstract machine jump where we want them to jump to */
|
||||
#ifdef YAPOR
|
||||
#if SBA
|
||||
CUT_prune_to((choiceptr)depth);
|
||||
#else
|
||||
CUT_prune_to((choiceptr)(LCL0-depth));
|
||||
#endif
|
||||
#else
|
||||
B = (choiceptr)(LCL0-depth);
|
||||
#endif /* YAPOR */
|
||||
ARG1 = newb->cp_a1 = MkApplTerm(fun, 2, nt);
|
||||
B = newb;
|
||||
ASP = YENV = (CELL *)B;
|
||||
P = (yamop *)FAILCODE;
|
||||
}
|
||||
PrologMode &= ~InErrorMode;
|
||||
|
||||
40
C/exec.c
40
C/exec.c
@ -833,7 +833,6 @@ exec_absmi(int top)
|
||||
int lval;
|
||||
if (top && (lval = sigsetjmp (RestartEnv, 1)) != 0) {
|
||||
if (lval == 1) { /* restart */
|
||||
int depth;
|
||||
/* otherwise, SetDBForThrow will fail entering critical mode */
|
||||
PrologMode = UserMode;
|
||||
/* find out where to cut to */
|
||||
@ -846,17 +845,6 @@ exec_absmi(int top)
|
||||
/* siglongjmp resets the H hardware register */
|
||||
restore_H();
|
||||
#endif
|
||||
#endif
|
||||
depth = SetDBForThrow(MkAtomTerm(LookupAtom("abort")));
|
||||
if (depth == 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "database entry for throw corrupted");
|
||||
}
|
||||
/* make the abstract machine jump where we want them to jump to */
|
||||
|
||||
#ifdef SBA
|
||||
B = (choiceptr)depth;
|
||||
#else
|
||||
B = (choiceptr)(LCL0-depth);
|
||||
#endif
|
||||
yap_flags[SPY_CREEP_FLAG] = 0;
|
||||
CreepFlag = CalculateStackGap();
|
||||
@ -1262,20 +1250,38 @@ p_clean_ifcp(void) {
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
/* This does very nasty stuff!!!!! */
|
||||
static Int
|
||||
p_jump_env(void) {
|
||||
CELL *env = LCL0-IntegerOfTerm(Deref(ARG1)), *prev = NULL, *cur = ENV;
|
||||
choiceptr old, cptr, ocptr;
|
||||
|
||||
while (cur != env) {
|
||||
prev = cur;
|
||||
cur = (CELL *)cur[E_E];
|
||||
}
|
||||
ENV[E_CP] = prev[E_CP];
|
||||
ENV[E_E] = prev[E_E];
|
||||
return(TRUE);
|
||||
if (prev != NULL) {
|
||||
CP = (yamop *)(prev[E_CP]);
|
||||
}
|
||||
ENV = env;
|
||||
/* force trail reset */
|
||||
old = (choiceptr)(env[E_CB]);
|
||||
cptr = ocptr = B;
|
||||
while (ocptr->cp_b < old) {
|
||||
ocptr = ocptr->cp_b;
|
||||
}
|
||||
while (cptr != ocptr) {
|
||||
cptr->cp_tr = ocptr->cp_tr;
|
||||
cptr = cptr->cp_b;
|
||||
}
|
||||
/* I could do this, but it is easier to leave the undwindig to the emulator */
|
||||
B->cp_env = env;
|
||||
B->cp_cp = CP;
|
||||
B->cp_h = H;
|
||||
env[CP->u.yx.y] = ARG2;
|
||||
return(FALSE);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
InitExecFs(void)
|
||||
{
|
||||
@ -1305,6 +1311,6 @@ InitExecFs(void)
|
||||
InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag);
|
||||
InitCPred("$restore_regs", 2, p_restore_regs2, SafePredFlag);
|
||||
InitCPred("$clean_ifcp", 1, p_clean_ifcp, SafePredFlag);
|
||||
InitCPred("$jump_env", 1, p_jump_env, SafePredFlag);
|
||||
InitCPred("$jump_env_and_store_ball", 2, p_jump_env, SafePredFlag);
|
||||
}
|
||||
|
||||
|
||||
2
C/init.c
2
C/init.c
@ -929,7 +929,6 @@ InitCodes(void)
|
||||
heap_regs->atom_stack_free = LookupAtom("stackfree");
|
||||
AtomStream = LookupAtom ("$stream");
|
||||
AtomStreamPos = LookupAtom ("$stream_position");
|
||||
heap_regs->atom_throw = LookupAtom("$throw");
|
||||
heap_regs->atom_true = LookupAtom("true");
|
||||
AtomSpy = LookupAtom("$spy");
|
||||
heap_regs->atom_user = LookupAtom ("user");
|
||||
@ -987,6 +986,7 @@ InitCodes(void)
|
||||
heap_regs->functor_stream_eOS = MkFunctor (LookupAtom("end_of_stream"), 1);
|
||||
heap_regs->functor_change_module = MkFunctor (LookupAtom("$change_module"), 1);
|
||||
heap_regs->functor_current_module = MkFunctor (LookupAtom("$current_module"), 1);
|
||||
heap_regs->functor_throw = MkFunctor( LookupAtom("throw"), 1);
|
||||
heap_regs->functor_u_minus = MkFunctor (heap_regs->atom_minus, 1);
|
||||
heap_regs->functor_u_plus = MkFunctor (heap_regs->atom_plus, 1);
|
||||
heap_regs->functor_v_bar = MkFunctor(LookupAtom("|"), 2);
|
||||
|
||||
@ -4781,7 +4781,7 @@ p_stream(void)
|
||||
void
|
||||
InitBackIO (void)
|
||||
{
|
||||
InitCPredBack ("current_stream", 3, 1, init_cur_s, cont_cur_s, SafePredFlag|SyncPredFlag);
|
||||
InitCPredBack ("$current_stream", 3, 1, init_cur_s, cont_cur_s, SafePredFlag|SyncPredFlag);
|
||||
}
|
||||
|
||||
void
|
||||
|
||||
2
C/save.c
2
C/save.c
@ -1051,7 +1051,6 @@ restore_codes(void)
|
||||
heap_regs->atom_repeat = AtomAdjust(heap_regs->atom_repeat);
|
||||
heap_regs->atom_restore_regs = AtomAdjust(heap_regs->atom_restore_regs);
|
||||
heap_regs->atom_stack_free = AtomAdjust(heap_regs->atom_stack_free);
|
||||
heap_regs->atom_throw = AtomAdjust(heap_regs->atom_throw);
|
||||
heap_regs->atom_true = AtomAdjust(heap_regs->atom_true);
|
||||
heap_regs->atom_user = AtomAdjust(heap_regs->atom_user);
|
||||
heap_regs->atom_usr_err = AtomAdjust(heap_regs->atom_usr_err);
|
||||
@ -1102,6 +1101,7 @@ restore_codes(void)
|
||||
heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS);
|
||||
heap_regs->functor_change_module = FuncAdjust(heap_regs->functor_change_module);
|
||||
heap_regs->functor_current_module = FuncAdjust(heap_regs->functor_current_module);
|
||||
heap_regs->functor_throw = FuncAdjust(heap_regs->functor_throw);
|
||||
heap_regs->functor_u_minus = FuncAdjust(heap_regs->functor_u_minus);
|
||||
heap_regs->functor_u_plus = FuncAdjust(heap_regs->functor_u_plus);
|
||||
heap_regs->functor_v_bar = FuncAdjust(heap_regs->functor_v_bar);
|
||||
|
||||
@ -1230,9 +1230,7 @@ static Int
|
||||
p_abort(void)
|
||||
{ /* abort */
|
||||
/* make sure we won't go creeping around */
|
||||
CreepFlag = CalculateStackGap();
|
||||
yap_flags[SPY_CREEP_FLAG] = 0;
|
||||
Abort("");
|
||||
Error(PURE_ABORT, TermNil, "");
|
||||
return(FALSE);
|
||||
}
|
||||
|
||||
|
||||
6
H/Heap.h
6
H/Heap.h
@ -10,7 +10,7 @@
|
||||
* File: Heap.h *
|
||||
* mods: *
|
||||
* comments: Heap Init Structure *
|
||||
* version: $Id: Heap.h,v 1.16 2002-01-01 05:26:25 vsc Exp $ *
|
||||
* version: $Id: Heap.h,v 1.17 2002-01-07 06:28:03 vsc Exp $ *
|
||||
*************************************************************************/
|
||||
|
||||
/* information that can be stored in Code Space */
|
||||
@ -197,7 +197,6 @@ typedef struct various_codes {
|
||||
atom_repeat,
|
||||
atom_restore_regs,
|
||||
atom_stack_free,
|
||||
atom_throw,
|
||||
atom_true,
|
||||
atom_unwritable,
|
||||
atom_user,
|
||||
@ -254,6 +253,7 @@ typedef struct various_codes {
|
||||
functor_stream_eOS,
|
||||
functor_change_module,
|
||||
functor_current_module,
|
||||
functor_throw,
|
||||
functor_u_minus,
|
||||
functor_u_plus,
|
||||
functor_v_bar,
|
||||
@ -388,7 +388,6 @@ typedef struct various_codes {
|
||||
#define AtomRepeat heap_regs->atom_repeat
|
||||
#define AtomRestoreRegs heap_regs->atom_restore_regs
|
||||
#define AtomStackFree heap_regs->atom_stack_free
|
||||
#define AtomThrow heap_regs->atom_throw
|
||||
#define AtomTrue heap_regs->atom_true
|
||||
#define AtomUser heap_regs->atom_user
|
||||
#define AtomUsrErr heap_regs->atom_usr_err
|
||||
@ -444,6 +443,7 @@ typedef struct various_codes {
|
||||
#define FunctorChangeModule heap_regs->functor_change_module
|
||||
#define FunctorCurrentModule heap_regs->functor_current_module
|
||||
#define FunctorModSwitch heap_regs->functor_mod_switch
|
||||
#define FunctorThrow heap_regs->functor_throw
|
||||
#define FunctorUMinus heap_regs->functor_u_minus
|
||||
#define FunctorUPlus heap_regs->functor_u_plus
|
||||
#define FunctorVBar heap_regs->functor_v_bar
|
||||
|
||||
@ -10,7 +10,7 @@
|
||||
* File: Yap.proto *
|
||||
* mods: *
|
||||
* comments: Function declarations for YAP *
|
||||
* version: $Id: Yapproto.h,v 1.6 2002-01-02 20:56:22 vsc Exp $ *
|
||||
* version: $Id: Yapproto.h,v 1.7 2002-01-07 06:28:03 vsc Exp $ *
|
||||
*************************************************************************/
|
||||
|
||||
/* prototype file for Yap */
|
||||
@ -133,7 +133,6 @@ void STD_PROTO(WakeUp,(CELL *));
|
||||
/* dbase.c */
|
||||
int STD_PROTO(DBTrailOverflow,(void));
|
||||
CELL STD_PROTO(EvalMasks,(Term,CELL *));
|
||||
Int STD_PROTO(SetDBForThrow,(Term));
|
||||
void STD_PROTO(InitBackDB,(void));
|
||||
void STD_PROTO(InitDBPreds,(void));
|
||||
|
||||
@ -276,7 +275,6 @@ void STD_PROTO(InitUtilCPreds,(void));
|
||||
|
||||
/* yap.c */
|
||||
|
||||
void STD_PROTO(Abort,(char *msg, ...));
|
||||
void STD_PROTO(addclause,(Term,CODEADDR,int,int));
|
||||
|
||||
/* ypsocks.c */
|
||||
|
||||
241
pl/boot.yap
241
pl/boot.yap
@ -30,7 +30,7 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||
;
|
||||
'$format'(user_error,"[~w]~n", [Module])
|
||||
),
|
||||
'$system_catch'('$enter_top_level',Error,user:'$Error'(Error)).
|
||||
'$system_catch'('$enter_top_level',Module,Error,user:'$Error'(Error)).
|
||||
|
||||
|
||||
'$init_system' :-
|
||||
@ -43,7 +43,6 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||
'$set_yap_flags'(10,0),
|
||||
'$set_value'('$gc',on),
|
||||
'$init_catch',
|
||||
% '$init_newcatch', commented out for now
|
||||
prompt(' ?- '),
|
||||
(
|
||||
'$get_value'('$break',0)
|
||||
@ -61,7 +60,6 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||
( exists('~/.prologrc') -> [-'~/.prologrc'] ; true ),
|
||||
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true )
|
||||
),
|
||||
'$clean_catch_and_throw',
|
||||
'$db_clean_queues'(0),
|
||||
'$startup_reconsult',
|
||||
'$startup_goals'
|
||||
@ -103,7 +101,7 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||
'$recorded'('$restore_goal',G,R),
|
||||
erase(R),
|
||||
prompt(_,' | '),
|
||||
'$system_catch'('$do_yes_no'((G->true),user),Error,user:'$Error'(Error)),
|
||||
'$system_catch'('$do_yes_no'((G->true),user),user,Error,user:'$Error'(Error)),
|
||||
fail.
|
||||
'$enter_top_level' :-
|
||||
( '$get_value'('$trace', 1) ->
|
||||
@ -138,7 +136,8 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||
|
||||
'$startup_goals' :-
|
||||
'$recorded'('$startup_goal',G,_),
|
||||
'$system_catch'('$query'((G->true), []),Error,user:'$Error'(Error)),
|
||||
'$current_module'(Module),
|
||||
'$system_catch'('$query'((G->true), []),Module,Error,user:'$Error'(Error)),
|
||||
fail.
|
||||
'$startup_goals'.
|
||||
|
||||
@ -885,20 +884,20 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
|
||||
'$get_value'('$consulting_file',OldF),
|
||||
'$set_consulting_file'(Stream),
|
||||
H0 is heapused, T0 is cputime,
|
||||
current_stream(File,_,Stream),
|
||||
'$current_stream'(File,_,Stream),
|
||||
'$start_consult'(consult,File,LC),
|
||||
'$get_value'('$consulting',Old),
|
||||
'$set_value'('$consulting',true),
|
||||
'$recorda'('$initialisation','$',_),
|
||||
( '$get_value'('$verbose',on) ->
|
||||
tab(user_error,LC),
|
||||
'$tab'(user_error,LC),
|
||||
'$format'(user_error, "[ consulting ~w... ]~n", [F])
|
||||
; true ),
|
||||
'$loop'(Stream,consult),
|
||||
'$end_consult',
|
||||
( LC == 0 -> prompt(_,' |: ') ; true),
|
||||
( '$get_value'('$verbose',on) ->
|
||||
tab(user_error,LC) ;
|
||||
'$tab'(user_error,LC) ;
|
||||
true ),
|
||||
H is heapused-H0, T is cputime-T0,
|
||||
( '$get_value'('$verbose',off) ->
|
||||
@ -954,11 +953,11 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
|
||||
'$current_module'(OldModule),
|
||||
'$change_alias_to_stream'('$loop_stream',Stream),
|
||||
repeat,
|
||||
( current_stream(_,_,Stream) -> true
|
||||
( '$current_stream'(_,_,Stream) -> true
|
||||
; '$current_module'(_,OldModule), '$abort_loop'(Stream)
|
||||
),
|
||||
prompt('| '), prompt(_,'| '),
|
||||
'$system_catch'('$enter_command'(Stream,Status), Error,
|
||||
'$system_catch'('$enter_command'(Stream,Status), OldModule, Error,
|
||||
user:'$LoopError'(Error)),
|
||||
!,
|
||||
'$exec_initialisation_goals',
|
||||
@ -1119,96 +1118,29 @@ expand_term(Term,Expanded) :-
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% catch/throw implementation
|
||||
|
||||
/* new design, not working for now:
|
||||
/* new design, not working for now: */
|
||||
|
||||
% at each catch point I need to know:
|
||||
% what is ball;
|
||||
% where was the previous catch
|
||||
newcatch(G, C, A) :-
|
||||
catch(G, C, A) :-
|
||||
'$mark_tr'(Ball),
|
||||
array_element('$catch', 0, OldEnv),
|
||||
Env is '$env',
|
||||
update_array('$catch', 0, Env),
|
||||
'$execute'(G),
|
||||
update_array('$catch', 0, Env),
|
||||
array_element('$catch', 1, V),
|
||||
(var(V) ->
|
||||
true
|
||||
'$force_to_1st'(Ball),
|
||||
( var(Ball) ->
|
||||
% no throw, just get rid of this.
|
||||
update_array('$catch', 0, OldEnv)
|
||||
;
|
||||
!, '$handle_throw'(C, A)
|
||||
% jmp_env will reset both fields for me!
|
||||
!, '$handle_throw'(C, A, Ball)
|
||||
).
|
||||
|
||||
'$handle_throw'(C, A) :-
|
||||
% reset info
|
||||
array_element('$catch', 1, _),
|
||||
array_element('$catch', 2, Ball),
|
||||
(C = Ball ->
|
||||
'$execute'(A)
|
||||
;
|
||||
throw(Ball)
|
||||
).
|
||||
|
||||
newthrow(Ball) :-
|
||||
% say we are throwing something.
|
||||
array_element('$catch', 1, []),
|
||||
update_array('$catch', 2, Ball),
|
||||
array_element('$catch', 0, Env),
|
||||
'$jump_env'(Env).
|
||||
|
||||
'$init_newcatch' :-
|
||||
'$create_array'('$catch', 3).
|
||||
|
||||
|
||||
*/
|
||||
|
||||
catch(G,C,A) :- var(G), !,
|
||||
throw(error(instantiation_error,catch(G,C,A))).
|
||||
catch(G,C,A) :- number(G), !,
|
||||
throw(error(type_error(callable,G),catch(G,C,A))).
|
||||
catch(R,C,A) :- db_reference(R), !,
|
||||
throw(error(type_error(callable,R),catch(R,C,A))).
|
||||
catch(G,C,A) :-
|
||||
'$catch'(G,C,A).
|
||||
|
||||
'$catch'(G,C,A) :-
|
||||
'$get_value'('$catch', I),
|
||||
I1 is I+1,
|
||||
'$set_value'('$catch', I1),
|
||||
'$current_module'(M),
|
||||
'$catch'(G,C,A,I,M).
|
||||
|
||||
'$catch'(G,_,_,I,_) :-
|
||||
% on entry we push the catch choice point
|
||||
X is '$last_choice_pt',
|
||||
'$catch_call'(X,G,I, NX),
|
||||
(X = NX -> !, '$erase_catch_elements'(I) ; true).
|
||||
% someone sent us a throw.
|
||||
'$catch'(_,C,A,_,M) :-
|
||||
array_element('$catch_queue', 1, X), X \= '$',
|
||||
update_array('$catch_queue', 1, '$'),
|
||||
array_element('$catch_queue', 0, catch(_,Lev,Q)), !,
|
||||
update_array('$catch_queue', 0, Q),
|
||||
'$db_clean_queues'(Lev),
|
||||
'$erase_catch_elements'(Lev),
|
||||
( C=X -> '$current_module'(_,M), '$execute'(A) ; throw(X)).
|
||||
% normal exit: make sure we only erase what we should erase!
|
||||
'$catch'(_,_,_,I,_) :-
|
||||
'$erase_catch_elements'(I),
|
||||
fail.
|
||||
|
||||
'$catch_call'(X,G,I,NX) :-
|
||||
array_element('$catch_queue', 0, OldCatch),
|
||||
update_array('$catch_queue', 0, catch(X,I,OldCatch)),
|
||||
'$execute'(G),
|
||||
NX is '$last_choice_pt',
|
||||
(
|
||||
array_element('$catch_queue', 0, catch(X,I,Catch)),
|
||||
update_array('$catch_queue', 0, Catch)
|
||||
;
|
||||
% on backtracking reinstate the catch before backtracking to G
|
||||
array_element('$catch_queue', 0, Catch),
|
||||
update_array('$catch_queue', 0, catch(X,I,Catch)),
|
||||
fail
|
||||
).
|
||||
% just create a choice-point
|
||||
'$mark_tr'(_).
|
||||
'$mark_tr'(_) :- fail.
|
||||
|
||||
%
|
||||
% system_catch is like catch, but it avoids the overhead of a full
|
||||
@ -1216,104 +1148,47 @@ catch(G,C,A) :-
|
||||
% This way it
|
||||
% also avoids module preprocessing and goal_expansion
|
||||
%
|
||||
'$system_catch'(G,C,A) :-
|
||||
'$get_value'('$catch', I),
|
||||
I1 is I+1,
|
||||
'$set_value'('$catch', I1),
|
||||
'$current_module'(M),
|
||||
'$system_catch'(G,C,A,I,M).
|
||||
|
||||
'$system_catch'(G,_,_,I,_) :-
|
||||
% on entry we push the catch choice point
|
||||
X is '$last_choice_pt',
|
||||
'$system_catch_call'(X,G,I,NX),
|
||||
( X = NX -> !, '$erase_catch_elements'(I) ; true).
|
||||
% someone sent us a throw.
|
||||
'$system_catch'(_,C,A,_,M) :-
|
||||
array_element('$catch_queue', 1, X), X \= '$',
|
||||
update_array('$catch_queue', 1, '$'),
|
||||
array_element('$catch_queue', 0, catch(_,Lev,Q)), !,
|
||||
update_array('$catch_queue', 0, Q),
|
||||
'$db_clean_queues'(Lev),
|
||||
'$erase_catch_elements'(Lev),
|
||||
( C=X ->
|
||||
'$execute'(M:A)
|
||||
'$system_catch'(G, M, C, A) :-
|
||||
% check current trail
|
||||
'$mark_tr'(Ball),
|
||||
% update current catch handler
|
||||
array_element('$catch', 0, OldEnv),
|
||||
Env is '$env',
|
||||
update_array('$catch', 0, Env),
|
||||
'$execute0'(G, M),
|
||||
% this says where Ball is, for the benefit of jump_env
|
||||
'$force_to_1st'(Ball),
|
||||
(
|
||||
var(Ball) ->
|
||||
% no throw, just get rid of this.
|
||||
update_array('$catch', 0, OldEnv)
|
||||
;
|
||||
throw(X)
|
||||
).
|
||||
% normal exit: make sure we only erase what we should erase!
|
||||
'$system_catch'(_,_,_,I,_) :-
|
||||
'$erase_catch_elements'(I),
|
||||
fail.
|
||||
% process the throw, if we can.
|
||||
!, '$handle_throw'(C, A, Ball)
|
||||
).
|
||||
|
||||
'$erase_catch_elements'(I) :-
|
||||
array_element('$catch_queue', 0, OldCatch),
|
||||
'$erase_catch_elements'(OldCatch, I, Catch),
|
||||
update_array('$catch_queue', 0, Catch).
|
||||
'$force_to_1st'(_).
|
||||
|
||||
'$erase_catch_elements'(catch(_, J, P), I, Catch) :-
|
||||
J >= I, !,
|
||||
'$erase_catch_elements'(P, I, Catch).
|
||||
'$erase_catch_elements'(Catch, _, Catch).
|
||||
|
||||
'$system_catch_call'(X,G,I, NX) :-
|
||||
array_element('$catch_queue', 0, OldCatch),
|
||||
update_array('$catch_queue', 0, catch(X,I,OldCatch)),
|
||||
'$current_module'(M),
|
||||
'$execute0'(G,M),
|
||||
NX is '$last_choice_pt',
|
||||
( % on exit remove the catch
|
||||
array_element('$catch_queue', 0, catch(X,I,Catch)),
|
||||
update_array('$catch_queue', 0, Catch)
|
||||
;
|
||||
% on backtracking reinstate the catch before backtracking to G
|
||||
array_element('$catch_queue', 0, Catch),
|
||||
update_array('$catch_queue', 0, catch(X,I,Catch)),
|
||||
fail
|
||||
).
|
||||
|
||||
throw(A) :-
|
||||
% fetch the point to jump to
|
||||
array_element('$catch_queue', 0, catch(X,_,_)), !,
|
||||
% now explain why we are jumping.
|
||||
update_array('$catch_queue', 1, A),
|
||||
'$$cut_by'(X),
|
||||
fail.
|
||||
throw(G) :-
|
||||
'$format'(user_error,"system_error_at(~w)",[G]),
|
||||
abort.
|
||||
'$handle_throw'(C, A, '$ball'(Ball)) :-
|
||||
% reset info
|
||||
(C = Ball ->
|
||||
'$execute'(A)
|
||||
;
|
||||
throw(Ball)
|
||||
).
|
||||
|
||||
throw(Ball) :-
|
||||
% get this off the unwound computation.
|
||||
copy_term(Ball,NewBall),
|
||||
% get current jump point
|
||||
array_element('$catch', 0, Env),
|
||||
% jump
|
||||
'$jump_env_and_store_ball'(Env, '$ball'(NewBall)).
|
||||
% restore bindings.
|
||||
throw(_).
|
||||
|
||||
'$init_catch' :-
|
||||
% initialise access to the catch queue
|
||||
( '$has_static_array'('$catch_queue') ->
|
||||
true
|
||||
;
|
||||
static_array('$catch_queue',2, term)
|
||||
),
|
||||
update_array('$catch_queue', 0, '$'),
|
||||
update_array('$catch_queue', 1, '$').
|
||||
|
||||
|
||||
'$check_list'(V, _) :- var(V), !.
|
||||
'$check_list'([], _) :- !.
|
||||
'$check_list'([_|B], T) :- !,
|
||||
'$check_list'(B,T).
|
||||
'$check_list'(S, T) :-
|
||||
throw(error(type_error(list,S),T)).
|
||||
|
||||
'$clean_catch_and_throw' :-
|
||||
'$set_value'('$catch', 0),
|
||||
fail.
|
||||
'$clean_catch_and_throw' :-
|
||||
'$recorded'('$catch',_,R),
|
||||
erase(R),
|
||||
fail.
|
||||
'$clean_catch_and_throw' :-
|
||||
'$recorded'('$throw',_,R),
|
||||
erase(R),
|
||||
fail.
|
||||
'$clean_catch_and_throw'.
|
||||
'$create_array'('$catch', 1).
|
||||
|
||||
'$exec_initialisation_goals' :-
|
||||
'$recorded'('$blocking_code',_,R),
|
||||
@ -1330,7 +1205,8 @@ throw(G) :-
|
||||
'$recorded'('$initialisation',G,R),
|
||||
erase(R),
|
||||
G \= '$',
|
||||
'$system_catch'(once(G), Error, user:'$LoopError'(Error)),
|
||||
'$current_module'(M),
|
||||
'$system_catch'(once(M:G), M, Error, user:'$LoopError'(Error)),
|
||||
fail.
|
||||
'$exec_initialisation_goals'.
|
||||
|
||||
@ -1342,4 +1218,3 @@ throw(G) :-
|
||||
'$run_toplevel_hooks'.
|
||||
|
||||
|
||||
|
||||
|
||||
@ -31,7 +31,7 @@ ensure_loaded(V) :-
|
||||
'$change_module'(M0).
|
||||
'$ensure_loaded'(X) :- atom(X), !,
|
||||
'$find_in_path'(X,Y),
|
||||
( open(Y,'$csult',Stream), !,
|
||||
( '$open'(Y, '$csult', Stream, 0), !,
|
||||
( '$loaded'(Stream) ->
|
||||
( '$consulting_file_name'(Stream,TFN),
|
||||
'$recorded'('$module','$module'(TFN,M,P),_) ->
|
||||
@ -43,14 +43,14 @@ ensure_loaded(V) :-
|
||||
'$record_loaded'(Stream),
|
||||
'$reconsult'(X,Stream)
|
||||
),
|
||||
close(Stream)
|
||||
'$close'(Stream)
|
||||
;
|
||||
|
||||
throw(error(permission_error(input,stream,X),ensure_loaded(X)))
|
||||
).
|
||||
'$ensure_loaded'(library(X)) :- !,
|
||||
'$find_in_path'(library(X),Y),
|
||||
( open(Y,'$csult',Stream), !,
|
||||
( '$open'(Y,'$csult',Stream, 0), !,
|
||||
( '$loaded'(Stream) ->
|
||||
( '$consulting_file_name'(Stream,TFN),
|
||||
'$recorded'('$module','$module'(TFN,M,P),_) ->
|
||||
@ -62,7 +62,7 @@ ensure_loaded(V) :-
|
||||
'$record_loaded'(Stream),
|
||||
'$reconsult'(Y,Stream)
|
||||
),
|
||||
close(Stream)
|
||||
'$close'(Stream)
|
||||
;
|
||||
throw(error(permission_error(input,stream,library(X)),ensure_loaded(library(X))))
|
||||
).
|
||||
@ -107,17 +107,17 @@ reconsult(Fs) :-
|
||||
'$reconsult'(Fs).
|
||||
'$reconsult'(X) :- atom(X), !,
|
||||
'$find_in_path'(X,Y),
|
||||
( open(Y,'$csult',Stream), !,
|
||||
( '$open'(Y,'$csult',Stream,0), !,
|
||||
'$record_loaded'(Stream),
|
||||
'$reconsult'(X,Stream), close(Stream)
|
||||
'$reconsult'(X,Stream), '$close'(Stream)
|
||||
;
|
||||
throw(error(permission_error(input,stream,X),reconsult(X)))
|
||||
).
|
||||
'$reconsult'(library(X)) :- !,
|
||||
'$find_in_path'(library(X),Y),
|
||||
( open(Y,'$csult',Stream), !,
|
||||
( '$open'(Y,'$csult',Stream,0), !,
|
||||
'$record_loaded'(Stream),
|
||||
'$reconsult'(library(X),Stream), close(Stream)
|
||||
'$reconsult'(library(X),Stream), '$close'(Stream)
|
||||
;
|
||||
throw(error(permission_error(input,stream,library(X)),reconsult(library(X))))
|
||||
).
|
||||
@ -136,7 +136,7 @@ reconsult(Fs) :-
|
||||
'$start_consult'(reconsult,File,LC),
|
||||
'$recorda'('$initialisation','$',_),
|
||||
( '$get_value'('$verbose',on) ->
|
||||
tab(user_error,LC),
|
||||
'$tab'(user_error,LC),
|
||||
'$format'(user_error, "[ reconsulting ~w... ]~n", [F])
|
||||
; true ),
|
||||
'$loop'(Stream,reconsult),
|
||||
@ -144,7 +144,7 @@ reconsult(Fs) :-
|
||||
'$clear_reconsulting',
|
||||
( LC == 0 -> prompt(_,' |: ') ; true),
|
||||
( '$get_value'('$verbose',on) ->
|
||||
tab(user_error,LC) ;
|
||||
'$tab'(user_error,LC) ;
|
||||
true ),
|
||||
H is heapused-H0, T is cputime-T0,
|
||||
( '$get_value'('$verbose',off) ->
|
||||
@ -162,11 +162,11 @@ reconsult(Fs) :-
|
||||
'$recorda'('$reconsulting',F,_).
|
||||
|
||||
'EMACS_FILE'(F,File0) :-
|
||||
format('''EMACS_RECONSULT''(~w).~n',[File0]),
|
||||
'$format'('''EMACS_RECONSULT''(~w).~n',[File0]),
|
||||
'$getcwd'(OldD),
|
||||
open(F,'$csult',Stream),
|
||||
'$open'(F,'$csult',Stream,0),
|
||||
'$find_in_path'(File0,File),
|
||||
open(File,'$csult',Stream0),
|
||||
'$open'(File,'$csult',Stream0,0),
|
||||
'$get_value'('$consulting_file',OldF),
|
||||
'$set_consulting_file'(Stream0),
|
||||
H0 is heapused, T0 is cputime,
|
||||
@ -176,7 +176,7 @@ reconsult(Fs) :-
|
||||
'$start_consult'(reconsult,File,LC),
|
||||
'$recorda'('$initialisation','$',_),
|
||||
( '$get_value'('$verbose',on) ->
|
||||
tab(user_error,LC),
|
||||
'$tab'(user_error,LC),
|
||||
'$format'(user_error, "[ reconsulting ~w... ]~n", [F])
|
||||
; true ),
|
||||
'$loop'(Stream,reconsult),
|
||||
@ -184,7 +184,7 @@ reconsult(Fs) :-
|
||||
'$clear_reconsulting',
|
||||
( LC == 0 -> prompt(_,' |: ') ; true),
|
||||
( '$get_value'('$verbose',on) ->
|
||||
tab(user_error,LC) ;
|
||||
'$tab'(user_error,LC) ;
|
||||
true ),
|
||||
H is heapused-H0, T is cputime-T0,
|
||||
( '$get_value'('$verbose',off) ->
|
||||
@ -220,8 +220,8 @@ reconsult(Fs) :-
|
||||
'$include'(X, Status) :- atom(X), !,
|
||||
'$find_in_path'(X,Y),
|
||||
'$values'('$included_file',OY,Y),
|
||||
( open(Y,'$csult',Stream), !,
|
||||
'$loop'(Stream,Status), close(Stream)
|
||||
( '$open'(Y,'$csult',Stream,0), !,
|
||||
'$loop'(Stream,Status), '$close'(Stream)
|
||||
;
|
||||
throw(error(permission_error(input,stream,Y),include(X)))
|
||||
),
|
||||
@ -236,10 +236,10 @@ reconsult(Fs) :-
|
||||
'$set_value'('$verbose',off)
|
||||
),
|
||||
'$find_in_path'(X,Y),
|
||||
( open(Y,'$csult',Stream), !,
|
||||
( '$open'(Y,'$csult',Stream,0), !,
|
||||
'$record_loaded'(Stream),
|
||||
( '$access_yap_flags'(15, 0) -> true ; '$skip_unix_comments'(Stream) ),
|
||||
'$reconsult'(X,Stream), close(Stream)
|
||||
'$reconsult'(X,Stream), '$close'(Stream)
|
||||
;
|
||||
'$output_error_message'(permission_error(input,stream,X),reconsult(X))
|
||||
),
|
||||
|
||||
19
pl/debug.yap
19
pl/debug.yap
@ -463,7 +463,7 @@ debugging :-
|
||||
'$creepcall_dynamic_clause'(G,M,Cl).
|
||||
|
||||
'$catch_spycall_stdpred'(G,M) :-
|
||||
'$system_catch'('$spycall_stdpred'(G,M), Error, user:'$DebugError'(Error)).
|
||||
'$system_catch'('$spycall_stdpred'(G,M), M, Error, user:'$DebugError'(Error)).
|
||||
|
||||
'$spycall_stdpred'(G,M) :-
|
||||
functor(G,F,N),
|
||||
@ -480,7 +480,7 @@ debugging :-
|
||||
|
||||
|
||||
'$call_clause'(G,M,Cl) :-
|
||||
'$system_catch'('$do_execute_clause'(G,M,Cl),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$do_execute_clause'(G,M,Cl),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$do_execute_clause'(G,M,Cl) :-
|
||||
'$some_recordedp'(M:G), !,
|
||||
@ -497,7 +497,7 @@ debugging :-
|
||||
'$execute'(G,M,Cl) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail.
|
||||
|
||||
'$call_log_updclause'(G,M,Cl,Index) :-
|
||||
'$system_catch'('$do_execute_log_upd_clause'(G,M,Cl,Index),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$do_execute_log_upd_clause'(G,M,Cl,Index),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$do_execute_log_upd_clause'(G,M,Cl,Index) :-
|
||||
'$check_depth_for_interpreter'(D),
|
||||
@ -526,10 +526,10 @@ debugging :-
|
||||
D1 is D0-1.
|
||||
|
||||
'$debug_catch_call'(Clause,M,CP) :-
|
||||
'$system_catch'('$call'(Clause,CP,Clause,M),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$call'(Clause,CP,Clause,M),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$call_dynamic_clause'(G,M,Cl) :-
|
||||
'$system_catch'('$do_execute_dynamic_clause'(G,M,Cl),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$do_execute_dynamic_clause'(G,M,Cl),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$do_execute_dynamic_clause'(G,M,Cl) :-
|
||||
'$check_depth_for_interpreter'(D),
|
||||
@ -544,7 +544,7 @@ debugging :-
|
||||
).
|
||||
|
||||
'$creepcallclause'(G,M,Cl) :-
|
||||
'$system_catch'('$do_creep_execute'(G,M,Cl),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$do_creep_execute'(G,M,Cl),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$do_creep_execute'(G,M,Cl) :-
|
||||
% fast skip should ignore source mode
|
||||
@ -567,7 +567,7 @@ debugging :-
|
||||
Next is Cl+1, '$set_value'(spy_cl,Next), fail.
|
||||
|
||||
'$creepcall_log_upd_clause'(G,M,Cl,Index) :-
|
||||
'$system_catch'('$do_creep_log_upd_execute'(G,M,Cl,Index),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$do_creep_log_upd_execute'(G,M,Cl,Index),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$do_creep_log_upd_execute'(G,M,Cl,Index) :-
|
||||
'$check_depth_for_interpreter'(D),
|
||||
@ -592,10 +592,10 @@ debugging :-
|
||||
).
|
||||
|
||||
'$catch_creep_call'(Clause,M,CP) :-
|
||||
'$system_catch'('$creep_call'(Clause,M,CP),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$creep_call'(Clause,M,CP),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$creepcall_dynamic_clause'(G,M,Cl) :-
|
||||
'$system_catch'('$do_creep_execute_dynamic'(G,M,Cl),Error,user:'$DebugError'(Error)).
|
||||
'$system_catch'('$do_creep_execute_dynamic'(G,M,Cl),M,Error,user:'$DebugError'(Error)).
|
||||
|
||||
'$do_creep_execute_dynamic'(G,M,Cl) :-
|
||||
'$check_depth_for_interpreter'(D),
|
||||
@ -988,6 +988,7 @@ debugging :-
|
||||
% do not try to handle other throws or aborts.
|
||||
%
|
||||
'$DebugError'(T) :- !,
|
||||
'$trace'(exception,T),
|
||||
throw(T).
|
||||
|
||||
'$init_spy_cl'(G,M) :-
|
||||
|
||||
@ -38,7 +38,7 @@
|
||||
'$directive'(wait(_)).
|
||||
|
||||
'$exec_directive'(multifile(D), _, M) :-
|
||||
'$system_catch'('$multifile'(D, M),
|
||||
'$system_catch'('$multifile'(D, M), M,
|
||||
Error,
|
||||
user:'$LoopError'(Error)).
|
||||
'$exec_directive'(discontiguous(D), _, M) :-
|
||||
|
||||
212
pl/errors.yap
212
pl/errors.yap
@ -46,312 +46,312 @@ print_message(Severity, Msg) :-
|
||||
print_message(error,error(Msg,Where)) :-
|
||||
'$output_error_message'(Msg, Where), !.
|
||||
print_message(error,Throw) :-
|
||||
format(user_error,"[ No handler for ball ~w ]~n", [Throw]).
|
||||
'$format'(user_error,"[ No handler for ball ~w ]~n", [Throw]).
|
||||
print_message(informational,debug(trace)) :-
|
||||
format(user_error,"[ The debugger will first creep -- showing everything (trace) ]~n",[]).
|
||||
'$format'(user_error,"[ The debugger will first creep -- showing everything (trace) ]~n",[]).
|
||||
print_message(informational,M) :-
|
||||
format(user_error,"[ ", []),
|
||||
'$format'(user_error,"[ ", []),
|
||||
'$do_print_message'(M),
|
||||
format(user_error," ]", []).
|
||||
'$format'(user_error," ]", []).
|
||||
print_message(warning,M) :-
|
||||
format(user_error,"[ Warning: ", []),
|
||||
'$format'(user_error,"[ Warning: ", []),
|
||||
'$do_print_message'(M),
|
||||
format(user_error," ]~n", []).
|
||||
'$format'(user_error," ]~n", []).
|
||||
print_message(help,M) :-
|
||||
format(user_error,"help on ~p",[M]).
|
||||
'$format'(user_error,"help on ~p",[M]).
|
||||
|
||||
|
||||
'$do_print_message'(debug(trace)) :- !,
|
||||
format(user_error,"[ The debugger will first creep -- showing everything (trace) ]~n",[]).
|
||||
'$do_print_message'(format(Msg, Args)) :- !,
|
||||
format(user_error,Msg,Args).
|
||||
'$format'(user_error,"[ The debugger will first creep -- showing everything (trace) ]~n",[]).
|
||||
'$do_print_message'('$format'(Msg, Args)) :- !,
|
||||
'$format'(user_error,Msg,Args).
|
||||
'$do_print_message'(import(Pred,To,From,private)) :-
|
||||
format(user_error,"importing private predicate ~w:~w to ~w",
|
||||
'$format'(user_error,"importing private predicate ~w:~w to ~w",
|
||||
[From,Pred,To]).
|
||||
'$do_print_message'(Messg) :-
|
||||
format(user_error,"~q",Messg).
|
||||
'$format'(user_error,"~q",Messg).
|
||||
|
||||
'$output_error_message'(context_error(Goal,Who),Where) :-
|
||||
format(user_error,"[ CONTEXT ERROR- ~w: ~w appeared in ~w ]~n",
|
||||
'$format'(user_error,"[ CONTEXT ERROR- ~w: ~w appeared in ~w ]~n",
|
||||
[Goal,Who,Where]).
|
||||
'$output_error_message'(domain_error(array_overflow,Opt), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid index for array ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid index for array ~w ]~n",
|
||||
[Where,Opt]).
|
||||
'$output_error_message'(domain_error(array_type,Opt), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid static array type ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid static array type ~w ]~n",
|
||||
[Where,Opt]).
|
||||
'$output_error_message'(domain_error(builtin_procedure,P), P) :-
|
||||
format(user_error,"[ DOMAIN ERROR- non-iso built-in procedure ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- non-iso built-in procedure ~w ]~n",
|
||||
[P]).
|
||||
'$output_error_message'(domain_error(character_code_list,Opt), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid list of codes ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid list of codes ~w ]~n",
|
||||
[Where,Opt]).
|
||||
'$output_error_message'(domain_error(delete_file_option,Opt), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid list of options ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid list of options ~w ]~n",
|
||||
[Where,Opt]).
|
||||
'$output_error_message'(domain_error(operator_specifier,Op), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid operator specifier ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid operator specifier ~w ]~n",
|
||||
[Where,Op]).
|
||||
'$output_error_message'(domain_error(close_option,Opt), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid close option ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid close option ~w ]~n",
|
||||
[Where,Opt]).
|
||||
'$output_error_message'(domain_error(radix,Opt), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid radix ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid radix ~w ]~n",
|
||||
[Where,Opt]).
|
||||
'$output_error_message'(domain_error(shift_count_overflow,Opt), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: shift count overflow in ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: shift count overflow in ~w ]~n",
|
||||
[Where,Opt]).
|
||||
'$output_error_message'(domain_error(flag_value,F+V), W) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid value ~w for flag ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid value ~w for flag ~w ]~n",
|
||||
[W,V,F]).
|
||||
'$output_error_message'(domain_error(io_mode,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid io mode ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid io mode ~w ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(mutable,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: invalid mutable ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: invalid mutable ~w ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(module_decl_options,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: expect module declaration options, found ~w ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: expect module declaration options, found ~w ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(not_empty_list,_), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: found empty list ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: found empty list ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(domain_error(not_less_than_zero,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: number ~w less than zero ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: number ~w less than zero ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(not_newline,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: number ~w not newline ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: number ~w not newline ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(not_zero,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: number ~w not zero ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: number ~w not zero ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(operator_priority,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w invalid operator priority ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w invalid operator priority ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(operator_specifier,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w invalid operator specifier ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w invalid operator specifier ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(read_option,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w invalid option to read ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w invalid option to read ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(semantics_indicator,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected predicate indicator, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected predicate indicator, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(domain_error(source_sink,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w is not a source sink term ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w is not a source sink term ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(domain_error(stream,What), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream ]~n",
|
||||
[Where,What]).
|
||||
'$output_error_message'(domain_error(stream_or_alias,What), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream ]~n",
|
||||
[Where,What]).
|
||||
'$output_error_message'(domain_error(stream_option,What), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream option ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream option ]~n",
|
||||
[Where,What]).
|
||||
'$output_error_message'(domain_error(stream_position,What), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream position ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream position ]~n",
|
||||
[Where,What]).
|
||||
'$output_error_message'(domain_error(stream_property,What), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream property ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w not a stream property ]~n",
|
||||
[Where,What]).
|
||||
'$output_error_message'(domain_error(syntax_error_handler,What), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w not a syntax error handler ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w not a syntax error handler ]~n",
|
||||
[Where,What]).
|
||||
'$output_error_message'(domain_error(time_out_spec,What), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w not a valid specification for a time out ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w not a valid specification for a time out ]~n",
|
||||
[Where,What]).
|
||||
'$output_error_message'(domain_error(write_option,N), Where) :-
|
||||
format(user_error,"[ DOMAIN ERROR- ~w: ~w invalid option to write ]~n",
|
||||
'$format'(user_error,"[ DOMAIN ERROR- ~w: ~w invalid option to write ]~n",
|
||||
[Where,N]).
|
||||
'$output_error_message'(existence_error(array,F), W) :-
|
||||
format(user_error,"[ EXISTENCE ERROR- ~w could not open array ~w ]~n",
|
||||
'$format'(user_error,"[ EXISTENCE ERROR- ~w could not open array ~w ]~n",
|
||||
[W,F]).
|
||||
'$output_error_message'(existence_error(procedure,P), _) :-
|
||||
format(user_error,"[ EXISTENCE ERROR- procedure ~w undefined ]~n",
|
||||
'$format'(user_error,"[ EXISTENCE ERROR- procedure ~w undefined ]~n",
|
||||
[P]).
|
||||
'$output_error_message'(existence_error(source_sink,F), W) :-
|
||||
format(user_error,"[ EXISTENCE ERROR- ~w could not find file ~w ]~n",
|
||||
'$format'(user_error,"[ EXISTENCE ERROR- ~w could not find file ~w ]~n",
|
||||
[W,F]).
|
||||
'$output_error_message'(existence_error(stream,Stream), Where) :-
|
||||
format(user_error,"[ EXISTENCE ERROR- ~w: ~w not an open stream ]~n",
|
||||
'$format'(user_error,"[ EXISTENCE ERROR- ~w: ~w not an open stream ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(evaluation_error(int_overflow), Where) :-
|
||||
format(user_error,"[ INTEGER OVERFLOW ERROR- ~w ]~n",
|
||||
'$format'(user_error,"[ INTEGER OVERFLOW ERROR- ~w ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(evaluation_error(float_overflow), Where) :-
|
||||
format(user_error,"[ FLOATING POINT OVERFLOW ERROR- ~w ]~n",
|
||||
'$format'(user_error,"[ FLOATING POINT OVERFLOW ERROR- ~w ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(evaluation_error(undefined), Where) :-
|
||||
format(user_error,"[ UNDEFINED ARITHMETIC RESULT ERROR- ~w ]~n",
|
||||
'$format'(user_error,"[ UNDEFINED ARITHMETIC RESULT ERROR- ~w ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(evaluation_error(underflow), Where) :-
|
||||
format(user_error,"[ UNDERFLOW ERROR- ~w ]~n",
|
||||
'$format'(user_error,"[ UNDERFLOW ERROR- ~w ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(evaluation_error(float_underflow), Where) :-
|
||||
format(user_error,"[ FLOATING POINT UNDERFLOW ERROR- ~w ]~n",
|
||||
'$format'(user_error,"[ FLOATING POINT UNDERFLOW ERROR- ~w ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(evaluation_error(zero_divisor), Where) :-
|
||||
format(user_error,"[ ZERO DIVISOR ERROR- ~w ]~n",
|
||||
'$format'(user_error,"[ ZERO DIVISOR ERROR- ~w ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(instantiation_error, Where) :-
|
||||
format(user_error,"[ INSTANTIATION ERROR- ~w: expected bound value ]~n",
|
||||
'$format'(user_error,"[ INSTANTIATION ERROR- ~w: expected bound value ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(permission_error(access,private_procedure,P), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot see clauses for ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot see clauses for ~w ]~n",
|
||||
[Where,P]).
|
||||
'$output_error_message'(permission_error(access,static_procedure,P), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot access static procedure ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot access static procedure ~w ]~n",
|
||||
[Where,P]).
|
||||
'$output_error_message'(permission_error(alias,new,P), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot create alias ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot create alias ~w ]~n",
|
||||
[Where,P]).
|
||||
'$output_error_message'(permission_error(create,array,P), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot create array ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot create array ~w ]~n",
|
||||
[Where,P]).
|
||||
'$output_error_message'(permission_error(create,operator,P), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot create operator ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot create operator ~w ]~n",
|
||||
[Where,P]).
|
||||
'$output_error_message'(permission_error(input,binary_stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot read from binary stream ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot read from binary stream ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(input,closed_stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: trying to read from closed stream ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: trying to read from closed stream ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(input,past_end_of_stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: past end of stream ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: past end of stream ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(input,stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot read from ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot read from ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(input,text_stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot read from text stream ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot read from text stream ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(modify,dynamic_procedure,_), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: modifying a dynamic procedure ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: modifying a dynamic procedure ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(permission_error(modify,flag,W), _) :-
|
||||
format(user_error,"[ PERMISSION ERROR- cannot modify flag ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- cannot modify flag ~w ]~n",
|
||||
[W]).
|
||||
'$output_error_message'(permission_error(modify,operator,W), _) :-
|
||||
format(user_error,"[ PERMISSION ERROR- T cannot declare ~w an operator ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- T cannot declare ~w an operator ]~n",
|
||||
[W]).
|
||||
'$output_error_message'(permission_error(modify,static_procedure,_), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: modifying a static procedure ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: modifying a static procedure ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(permission_error(modify,static_procedure_in_use,_), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: modifying a static procedure in use ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: modifying a static procedure in use ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(permission_error(open,source_sink,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot open file ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot open file ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(output,binary_stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot write to binary stream ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot write to binary stream ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(output,stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot write to ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot write to ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(output,text_stream,Stream), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot write to text stream ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot write to text stream ~w ]~n",
|
||||
[Where,Stream]).
|
||||
'$output_error_message'(permission_error(resize,array,P), Where) :-
|
||||
format(user_error,"[ PERMISSION ERROR- ~w: cannot resize array ~w ]~n",
|
||||
'$format'(user_error,"[ PERMISSION ERROR- ~w: cannot resize array ~w ]~n",
|
||||
[Where,P]).
|
||||
'$output_error_message'(representation_error(character), Where) :-
|
||||
format(user_error,"[ REPRESENTATION ERROR- ~w: expected character ]~n",
|
||||
'$format'(user_error,"[ REPRESENTATION ERROR- ~w: expected character ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(representation_error(character_code), Where) :-
|
||||
format(user_error,"[ REPRESENTATION ERROR- ~w: expected character code ]~n",
|
||||
'$format'(user_error,"[ REPRESENTATION ERROR- ~w: expected character code ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(representation_error(max_arity), Where) :-
|
||||
format(user_error,"[ REPRESENTATION ERROR- ~w: number too big ]~n",
|
||||
'$format'(user_error,"[ REPRESENTATION ERROR- ~w: number too big ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(syntax_error(Error), Where) :-
|
||||
format(user_error,"[ SYNTAX ERROR- ~w: ~w ]~n",
|
||||
'$format'(user_error,"[ SYNTAX ERROR- ~w: ~w ]~n",
|
||||
[Where, Error]).
|
||||
'$output_error_message'(system_error, Where) :-
|
||||
format(user_error,"[ SYSTEM ERROR- ~w ]~n",
|
||||
'$format'(user_error,"[ SYSTEM ERROR- ~w ]~n",
|
||||
[Where]).
|
||||
'$output_error_message'(system_error(Message), Where) :-
|
||||
format(user_error,"[ SYSTEM ERROR- ~w at ~w]~n",
|
||||
'$format'(user_error,"[ SYSTEM ERROR- ~w at ~w]~n",
|
||||
[Message,Where]).
|
||||
'$output_error_message'(type_error(T,_,Err,M), _Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected ~w, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected ~w, got ~w ]~n",
|
||||
[T,Err,M]).
|
||||
'$output_error_message'(type_error(array,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected array, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected array, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(atom,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected atom, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected atom, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(atomic,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected atomic, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected atomic, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(byte,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected byte, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected byte, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(callable,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected callable goal, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected callable goal, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(character,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected character, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected character, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(character_code,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected character code, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected character code, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(compound,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected compound, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected compound, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(db_reference,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected data base reference, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected data base reference, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(db_term,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected data base term, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected data base term, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(evaluable,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected evaluable term, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected evaluable term, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(float,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected float, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected float, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(in_byte,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected byte, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected byte, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(in_character,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected atom character, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected atom character, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(in_character_code,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected character code, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected character code, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(integer,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected integer, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected integer, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(key,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected database key, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected database key, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(leash_mode,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected modes for leash, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected modes for leash, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(list,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected list, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected list, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(number,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected number, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected number, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(pointer,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected pointer, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected pointer, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(predicate_indicator,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected predicate indicator, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected predicate indicator, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(unsigned_byte,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected unsigned byte, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected unsigned byte, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(type_error(variable,W), Where) :-
|
||||
format(user_error,"[ TYPE ERROR- ~w: expected unbound variable, got ~w ]~n",
|
||||
'$format'(user_error,"[ TYPE ERROR- ~w: expected unbound variable, got ~w ]~n",
|
||||
[Where,W]).
|
||||
'$output_error_message'(unknown, Where) :-
|
||||
format(user_error,"[ EXISTENCE ERROR- procedure ~w undefined ]~n",
|
||||
'$format'(user_error,"[ EXISTENCE ERROR- procedure ~w undefined ]~n",
|
||||
[Where]).
|
||||
|
||||
|
||||
|
||||
@ -75,7 +75,7 @@ portray_clause(Pred) :-
|
||||
'$write_clause'(Head,Body) :-
|
||||
writeq(Head),
|
||||
( Body = true ;
|
||||
tab(1), write((:-)),
|
||||
'$tab'(1), write((:-)),
|
||||
'$write_body'(Body,3,',')
|
||||
),
|
||||
put("."), nl,
|
||||
@ -90,50 +90,50 @@ portray_clause(Pred) :-
|
||||
'$write_body'(Q,I,',').
|
||||
'$write_body'((P->Q;S),I,_) :-
|
||||
!,
|
||||
nl, tab(I-2), put("("),
|
||||
nl, '$tab'(I-2), put("("),
|
||||
'$write_body'(P,I,'('),
|
||||
put("-"), put(">"),
|
||||
'$write_body'(Q,I,'->'),
|
||||
put(";"),
|
||||
'$write_body'(S,I,';'),
|
||||
tab(1), put(")").
|
||||
'$tab'(1), put(")").
|
||||
'$write_body'((P->Q|S),I,_) :-
|
||||
!,
|
||||
nl, tab(I-2), put("("),
|
||||
nl, '$tab'(I-2), put("("),
|
||||
'$write_body'(P,I,'('),
|
||||
put("-"), put(">"),
|
||||
'$write_body'(Q,I,'->'),
|
||||
put("|"),
|
||||
'$write_body'(S,I,'|'),
|
||||
tab(1), put(")").
|
||||
'$tab'(1), put(")").
|
||||
'$write_body'((P->Q),I,_) :-
|
||||
!,
|
||||
nl, tab(I-2), put("("),
|
||||
nl, '$tab'(I-2), put("("),
|
||||
'$write_body'(P,I,'('),
|
||||
put("-"), put(">"),
|
||||
'$write_body'(Q,I,'->'),
|
||||
tab(1), put(")").
|
||||
'$tab'(1), put(")").
|
||||
'$write_body'((P;Q),I,_) :-
|
||||
!,
|
||||
nl, tab(I-2), put("("),
|
||||
nl, '$tab'(I-2), put("("),
|
||||
'$write_body'(P,I,'('),
|
||||
put(";"),
|
||||
'$write_body'(Q,I,';'),
|
||||
tab(1), put(")").
|
||||
'$tab'(1), put(")").
|
||||
'$write_body'((P|Q),I,_) :-
|
||||
!,
|
||||
nl, tab(I-2), put("("),
|
||||
nl, '$tab'(I-2), put("("),
|
||||
'$write_body'(P,I,'('),
|
||||
put("|"),
|
||||
'$write_body'(Q,I,'|'),
|
||||
tab(1), put(")").
|
||||
'$tab'(1), put(")").
|
||||
'$write_body'((P|Q),I,_) :-
|
||||
!,
|
||||
nl, tab(I-2), put("("),
|
||||
nl, '$tab'(I-2), put("("),
|
||||
'$write_body'(P,I,'('),
|
||||
put("|"),
|
||||
'$write_body'(Q,I,'|'),
|
||||
tab(1), put(")").
|
||||
'$tab'(1), put(")").
|
||||
'$write_body'(X,I,T) :-
|
||||
'$beforelit'(T,I),
|
||||
writeq(X).
|
||||
@ -141,8 +141,8 @@ portray_clause(Pred) :-
|
||||
'$aftercomma'(',',I,I) :- !.
|
||||
'$aftercomma'(_,I0,I) :- I is I0+3.
|
||||
|
||||
'$beforelit'('(',_) :- !, tab(1).
|
||||
'$beforelit'(_,I) :- nl, tab(I).
|
||||
'$beforelit'('(',_) :- !, '$tab'(1).
|
||||
'$beforelit'(_,I) :- nl, '$tab'(I).
|
||||
|
||||
'$beautify_vars'(T) :-
|
||||
'$list_get_vars'(T,[],L),
|
||||
|
||||
@ -51,7 +51,7 @@ use_module(File,Imports) :-
|
||||
atom(File), !,
|
||||
'$current_module'(M),
|
||||
'$find_in_path'(File,X),
|
||||
( open(X,'$csult',Stream), !,
|
||||
( '$open'(X,'$csult',Stream,0), !,
|
||||
'$consulting_file_name'(Stream,TrueFileName),
|
||||
( '$loaded'(Stream) -> true
|
||||
;
|
||||
@ -60,12 +60,12 @@ use_module(File,Imports) :-
|
||||
'$recorda'('$importing','$importing'(TrueFileName),R),
|
||||
'$reconsult'(File,Stream)
|
||||
),
|
||||
close(Stream),
|
||||
'$close'(Stream),
|
||||
( var(R) -> true; erased(R) -> true; erase(R)),
|
||||
( '$recorded'('$module','$module'(TrueFileName,Mod,Publics),_) ->
|
||||
'$use_preds'(Imports,Publics,Mod,M)
|
||||
;
|
||||
format(user_error,'[ use_module/2 can not find a module in file ~w]~n',File),
|
||||
'$format'(user_error,'[ use_module/2 can not find a module in file ~w]~n',File),
|
||||
fail
|
||||
)
|
||||
;
|
||||
@ -74,7 +74,7 @@ use_module(File,Imports) :-
|
||||
use_module(library(File),Imports) :- !,
|
||||
'$current_module'(M),
|
||||
'$find_in_path'(library(File),X),
|
||||
( open(X,'$csult',Stream), !,
|
||||
( '$open'(X,'$csult',Stream,0), !,
|
||||
'$consulting_file_name'(Stream,TrueFileName),
|
||||
( '$loaded'(Stream) -> true
|
||||
;
|
||||
@ -83,12 +83,12 @@ use_module(library(File),Imports) :- !,
|
||||
'$recorda'('$importing','$importing'(TrueFileName),R),
|
||||
'$reconsult'(library(File),Stream)
|
||||
),
|
||||
close(Stream),
|
||||
'$close'(Stream),
|
||||
( var(R) -> true; erased(R) -> true; erase(R)),
|
||||
( '$recorded'('$module','$module'(TrueFileName,Mod,Publics),_) ->
|
||||
'$use_preds'(Imports,Publics,Mod,M)
|
||||
;
|
||||
format(user_error,'[ use_module/2 can not find a module in file ~w]~n',[File]),
|
||||
'$format'(user_error,'[ use_module/2 can not find a module in file ~w]~n',[File]),
|
||||
fail
|
||||
)
|
||||
;
|
||||
@ -100,7 +100,7 @@ use_module(V,Decls) :-
|
||||
use_module(Module,File,Imports) :-
|
||||
'$current_module'(M),
|
||||
'$find_in_path'(File,X),
|
||||
( open(X,'$csult',Stream), !,
|
||||
( '$open'(X,'$csult',Stream,0), !,
|
||||
'$consulting_file_name'(Stream,TrueFileName),
|
||||
( '$loaded'(Stream) -> true
|
||||
;
|
||||
@ -109,12 +109,12 @@ use_module(Module,File,Imports) :-
|
||||
'$recorda'('$importing','$importing'(TrueFileName),R),
|
||||
'$reconsult'(File,Stream)
|
||||
),
|
||||
close(Stream),
|
||||
'$close'(Stream),
|
||||
( var(R) -> true; erased(R) -> true; erase(R)),
|
||||
( '$recorded'('$module','$module'(TrueFileName,Module,Publics),_) ->
|
||||
'$use_preds'(Imports,Publics,Module,M)
|
||||
;
|
||||
format(user_error,'[ use_module/2 can not find module ~w in file ~w]~n',[Module,File]),
|
||||
'$format'(user_error,'[ use_module/2 can not find module ~w in file ~w]~n',[Module,File]),
|
||||
fail
|
||||
)
|
||||
;
|
||||
@ -132,7 +132,7 @@ use_module(Module,V,Decls) :-
|
||||
'$module_dec'(N,P).
|
||||
'$module'(consult,N,P) :-
|
||||
( '$recorded'('$module','$module'(F,N,_),_),
|
||||
format(user_error,'[ Module ~w was already defined in file ~w]~n',[N,F]),
|
||||
'$format'(user_error,'[ Module ~w was already defined in file ~w]~n',[N,F]),
|
||||
'$abolish_module_data'(N),
|
||||
fail
|
||||
;
|
||||
@ -212,7 +212,7 @@ module(N) :-
|
||||
'$import'([N/K|L],M,T) :-
|
||||
integer(K), atom(N), !,
|
||||
( '$check_import'(M,T,N,K) ->
|
||||
% format(user_error,'[vsc1: Importing ~w to ~w]~n',[M:N/K,T]),
|
||||
% '$format'(user_error,'[vsc1: Importing ~w to ~w]~n',[M:N/K,T]),
|
||||
( T = user ->
|
||||
recordz('$import','$import'(M,user,N,K),_)
|
||||
;
|
||||
@ -223,13 +223,13 @@ module(N) :-
|
||||
),
|
||||
'$import'(L,M,T).
|
||||
'$import'([PS|L],M,T) :-
|
||||
format(user_error,'[Illegal pred specification(~w) in module declaration for module ~w]~n',[PS,M]),
|
||||
'$format'(user_error,'[Illegal pred specification(~w) in module declaration for module ~w]~n',[PS,M]),
|
||||
'$import'(L,M,T).
|
||||
|
||||
'$check_import'(M,T,N,K) :-
|
||||
'$recorded'('$import','$import'(M1,T0,N,K),R), T0 == T, M1 \= M, /* ZP */ !,
|
||||
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),
|
||||
'$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,
|
||||
get0(C), '$skipeol'(C),
|
||||
( C is "y" -> erase(R), !;
|
||||
@ -248,9 +248,9 @@ module(N) :-
|
||||
print_message(warning,import(N/K,Mod,M,private))
|
||||
),
|
||||
( '$check_import'(M,Mod,N,K) ->
|
||||
% format(user_error,'[ Importing ~w to ~w]~n',[M:N/K,Mod]),
|
||||
% '$format'(user_error,'[ Importing ~w to ~w]~n',[M:N/K,Mod]),
|
||||
% '$trace_module'(importing(M:N/K,Mod)),
|
||||
% format(user_error,'[vsc2: Importing ~w to ~w]~n',[M:N/K,T]),
|
||||
% '$format'(user_error,'[vsc2: Importing ~w to ~w]~n',[M:N/K,T]),
|
||||
(Mod = user ->
|
||||
recordz('$import','$import'(M,user,N,K),_)
|
||||
;
|
||||
@ -464,9 +464,9 @@ module(N) :-
|
||||
functor(G,F,N),
|
||||
user:'$meta_predicate'(F,Mod,N,D), !,
|
||||
functor(G1,F,N),
|
||||
% format(user_error,'[expanding ~w:~w in ~w',[Mod,G,MP]),
|
||||
% '$format'(user_error,'[expanding ~w:~w in ~w',[Mod,G,MP]),
|
||||
'$meta_expansion_loop'(N,D,G,G1,HVars,MP).
|
||||
% format(user_error,' gives ~w~n]',[G1]).
|
||||
% '$format'(user_error,' gives ~w~n]',[G1]).
|
||||
|
||||
% expand argument
|
||||
'$meta_expansion_loop'(0,_,_,_,_,_) :- !.
|
||||
|
||||
@ -473,7 +473,7 @@ abolish(X) :-
|
||||
'$access_yap_flags'(8, 2), % only do this in sicstus mode
|
||||
'$undefined'(G, Module),
|
||||
functor(G,Name,Arity),
|
||||
format(user_error,'[ Warning: abolishing undefined predicate (~w:~w/~w) ]~n',[Module,Name,Arity]),
|
||||
'$format'(user_error,"[ Warning: abolishing undefined predicate (~w:~w/~w) ]~n",[Module,Name,Arity]),
|
||||
fail.
|
||||
% I cannot allow modifying static procedures in YAPOR
|
||||
% this code has to be here because of abolish/2
|
||||
|
||||
@ -35,9 +35,9 @@
|
||||
'$make_system_preds'(woken_att_do) :- !.
|
||||
'$make_system_preds'(convert_att_var) :- !.
|
||||
'$make_system_preds'(Name) :-
|
||||
% format("~NProtecting ~a",Name),
|
||||
% '$format'("~NProtecting ~a",Name),
|
||||
'$pred_defined_for'(Name,Pred),
|
||||
% format("~NProtecting ~q",Pred),
|
||||
% '$format'("~NProtecting ~q",Pred),
|
||||
'$protect_system_pred'(Pred),
|
||||
fail.
|
||||
'$make_system_preds'(_).
|
||||
|
||||
13
pl/setof.yap
13
pl/setof.yap
@ -32,7 +32,7 @@ _^Goal :-
|
||||
|
||||
|
||||
findall(Template, Generator, Answers) :-
|
||||
'$check_list'(Answers, findall(Template, Generator, Answers)),
|
||||
'$check_list_for_bags'(Answers, findall(Template, Generator, Answers)),
|
||||
'$init_db_queue'(Ref),
|
||||
'$findall'(Template, Generator, Ref, [], Answers).
|
||||
|
||||
@ -84,7 +84,7 @@ findall(Template, Generator, Answers, SoFar) :-
|
||||
% This is the setof predicate
|
||||
|
||||
setof(Template, Generator, Set) :-
|
||||
'$check_list'(Set, setof(Template, Generator, Set)),
|
||||
'$check_list_for_bags'(Set, setof(Template, Generator, Set)),
|
||||
'$bagof'(Template, Generator, Bag),
|
||||
'$sort'(Bag, Set).
|
||||
|
||||
@ -98,7 +98,7 @@ bagof(Template, Generator, Bag) :-
|
||||
'$bagof'(Template, Generator, Bag).
|
||||
|
||||
'$bagof'(Template, Generator, Bag) :-
|
||||
'$check_list'(Bag, bagof(Template, Generator, Bag)),
|
||||
'$check_list_for_bags'(Bag, bagof(Template, Generator, Bag)),
|
||||
'$variables_in_term'(Template, [], TemplateV),
|
||||
'$excess_vars'(Generator, TemplateV, [], FreeVars),
|
||||
FreeVars \== [],
|
||||
@ -215,3 +215,10 @@ all(T,G,S) :- '$recorda'('$$one','$',R), (
|
||||
'$$split'([T1|Tn],T,X,S1,[T1|S2]) :- '$$split'(Tn,T,X,S1,S2).
|
||||
|
||||
|
||||
'$check_list_for_bags'(V, _) :- var(V), !.
|
||||
'$check_list_for_bags'([], _) :- !.
|
||||
'$check_list_for_bags'([_|B], T) :- !,
|
||||
'$check_list_for_bags'(B,T).
|
||||
'$check_list_for_bags'(S, T) :-
|
||||
throw(error(type_error(list,S),T)).
|
||||
|
||||
|
||||
@ -22,8 +22,8 @@ socket_accept(S,F) :-
|
||||
socket_accept(S, _, F).
|
||||
|
||||
socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams) :-
|
||||
'$check_list'(Socks, socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams)),
|
||||
'$check_list'(Streams, socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams)),
|
||||
'$check_list_for_sockets'(Socks, socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams)),
|
||||
'$check_list_for_sockets'(Streams, socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams)),
|
||||
'$select_cp_fds'(Socks, Streams, Fds),
|
||||
'$check_select_time'(TimeOut, Sec, USec, socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams)),
|
||||
'$socket_select'(Fds, Sec, USec, NFds),
|
||||
@ -32,12 +32,12 @@ socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams) :-
|
||||
|
||||
|
||||
/* check whether a list of options is valid */
|
||||
'$check_list'(V,G) :- var(V), !,
|
||||
'$check_list_for_sockets'(V,G) :- var(V), !,
|
||||
throw(error(instantiation_error,G)).
|
||||
'$check_list'([],_) :- !.
|
||||
'$check_list'([_|T],G) :- !,
|
||||
'$check_list'(T,G).
|
||||
'$check_io_opts'(T,G) :-
|
||||
'$check_list_for_sockets'([],_) :- !.
|
||||
'$check_list_for_sockets'([_|T],G) :- !,
|
||||
'$check_list_for_sockets'(T,G).
|
||||
'$check_list_for_sockets'(T,G) :-
|
||||
throw(error(type_error(list,T),G)).
|
||||
|
||||
'$select_cp_fds'([], Fds, Fds).
|
||||
|
||||
44
pl/utils.yap
44
pl/utils.yap
@ -361,37 +361,37 @@ statistics :-
|
||||
|
||||
'$statistics'(Runtime,CPUtime,Walltime,HpSpa,HpInUse,_HpMax,TrlSpa, TrlInUse,_TrlMax,StkSpa, GlobInU, LocInU,GlobMax,LocMax,NOfHO,TotHOTime,NOfSO,TotSOTime,NOfTO,TotTOTime,NOfGC,TotGCTime,TotGCSize) :-
|
||||
TotalMemory is HpSpa+StkSpa+TrlSpa,
|
||||
format(user_error,"memory (total)~t~d bytes~35+~n", [TotalMemory]),
|
||||
format(user_error," program space~t~d bytes~35+", [HpSpa]),
|
||||
format(user_error,":~t ~d in use~19+", [HpInUse]),
|
||||
'$format'(user_error,"memory (total)~t~d bytes~35+~n", [TotalMemory]),
|
||||
'$format'(user_error," program space~t~d bytes~35+", [HpSpa]),
|
||||
'$format'(user_error,":~t ~d in use~19+", [HpInUse]),
|
||||
HpFree is HpSpa-HpInUse,
|
||||
format(user_error,",~t ~d free~19+~n", [HpFree]),
|
||||
format(user_error," stack space~t~d bytes~35+", [StkSpa]),
|
||||
'$format'(user_error,",~t ~d free~19+~n", [HpFree]),
|
||||
'$format'(user_error," stack space~t~d bytes~35+", [StkSpa]),
|
||||
StackInUse is GlobInU+LocInU,
|
||||
format(user_error,":~t ~d in use~19+", [StackInUse]),
|
||||
'$format'(user_error,":~t ~d in use~19+", [StackInUse]),
|
||||
StackFree is StkSpa-StackInUse,
|
||||
format(user_error,",~t ~d free~19+~n", [StackFree]),
|
||||
format(user_error," global stack:~t~35+", []),
|
||||
format(user_error," ~t ~d in use~19+", [GlobInU]),
|
||||
format(user_error,",~t ~d max~19+~n", [GlobMax]),
|
||||
format(user_error," local stack:~t~35+", []),
|
||||
format(user_error," ~t ~d in use~19+", [LocInU]),
|
||||
format(user_error,",~t ~d max~19+~n", [LocMax]),
|
||||
format(user_error," trail stack~t~d bytes~35+", [TrlSpa]),
|
||||
format(user_error,":~t ~d in use~19+", [TrlInUse]),
|
||||
'$format'(user_error,",~t ~d free~19+~n", [StackFree]),
|
||||
'$format'(user_error," global stack:~t~35+", []),
|
||||
'$format'(user_error," ~t ~d in use~19+", [GlobInU]),
|
||||
'$format'(user_error,",~t ~d max~19+~n", [GlobMax]),
|
||||
'$format'(user_error," local stack:~t~35+", []),
|
||||
'$format'(user_error," ~t ~d in use~19+", [LocInU]),
|
||||
'$format'(user_error,",~t ~d max~19+~n", [LocMax]),
|
||||
'$format'(user_error," trail stack~t~d bytes~35+", [TrlSpa]),
|
||||
'$format'(user_error,":~t ~d in use~19+", [TrlInUse]),
|
||||
TrlFree is TrlSpa-TrlInUse,
|
||||
format(user_error,",~t ~d free~19+~n", [TrlFree]),
|
||||
'$format'(user_error,",~t ~d free~19+~n", [TrlFree]),
|
||||
OvfTime is TotHOTime+TotSOTime+TotTOTime,
|
||||
format(user_error,"~n~t~3f~12+ sec. for ~w code, ~w stack, and ~w trail space overflows~n",
|
||||
'$format'(user_error,"~n~t~3f~12+ sec. for ~w code, ~w stack, and ~w trail space overflows~n",
|
||||
[OvfTime,NOfHO,NOfSO,NOfTO]),
|
||||
format(user_error,"~t~3f~12+ sec. for ~w garbage collections which collected ~d bytes~n",
|
||||
'$format'(user_error,"~t~3f~12+ sec. for ~w garbage collections which collected ~d bytes~n",
|
||||
[TotGCTime,NOfGC,TotGCSize]),
|
||||
RTime is float(Runtime)/1000,
|
||||
format(user_error,"~t~3f~12+ sec. runtime~n", [RTime]),
|
||||
'$format'(user_error,"~t~3f~12+ sec. runtime~n", [RTime]),
|
||||
CPUTime is float(CPUtime)/1000,
|
||||
format(user_error,"~t~3f~12+ sec. cputime~n", [CPUTime]),
|
||||
'$format'(user_error,"~t~3f~12+ sec. cputime~n", [CPUTime]),
|
||||
WallTime is float(Walltime)/1000,
|
||||
format(user_error,"~t~3f~12+ sec. elapsed time~n~n", [WallTime]),
|
||||
'$format'(user_error,"~t~3f~12+ sec. elapsed time~n~n", [WallTime]),
|
||||
fail.
|
||||
'$statistics'(_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_).
|
||||
|
||||
@ -492,7 +492,7 @@ unknown(V0,V) :-
|
||||
'$unknown_warning'(P) :-
|
||||
P=M:F,
|
||||
functor(F,Na,Ar),
|
||||
format(user_error,"[ EXISTENCE ERROR: ~w, procedure ~w:~w/~w undefined ]~n",
|
||||
'$format'(user_error,"[ EXISTENCE ERROR: ~w, procedure ~w:~w/~w undefined ]~n",
|
||||
[P,M,Na,Ar]),
|
||||
fail.
|
||||
|
||||
|
||||
24
pl/yio.yap
24
pl/yio.yap
@ -292,7 +292,7 @@ seeing(File) :- current_input(Stream),
|
||||
'$user_file_name'(Stream,NFile),
|
||||
( '$user_file_name'(user_input,NFile) -> File = user ; NFile = File).
|
||||
|
||||
seen :- current_input(Stream), close(Stream), set_input(user).
|
||||
seen :- current_input(Stream), '$close'(Stream), set_input(user).
|
||||
|
||||
tell(user) :- !, set_output(user_output).
|
||||
tell(F) :- var(F), !,
|
||||
@ -309,7 +309,7 @@ telling(File) :- current_output(Stream),
|
||||
'$user_file_name'(Stream,NFile),
|
||||
( '$user_file_name'(user_output,NFile) -> File = user ; File = NFile ).
|
||||
|
||||
told :- current_output(Stream), close(Stream), set_output(user).
|
||||
told :- current_output(Stream), '$close'(Stream), set_output(user).
|
||||
|
||||
|
||||
/* Term IO */
|
||||
@ -734,7 +734,7 @@ stream_position(user,N) :- !,
|
||||
'$show_stream_position'(user_input,N).
|
||||
stream_position(A,N) :-
|
||||
atom(A),
|
||||
current_stream(_,_,S), '$user_file_name'(S,A), !,
|
||||
'$current_stream'(_,_,S), '$user_file_name'(S,A), !,
|
||||
'$show_stream_position'(S,N).
|
||||
stream_position(S,N) :-
|
||||
'$show_stream_position'(S,N).
|
||||
@ -743,7 +743,7 @@ stream_position(user,N,M) :- !,
|
||||
'$stream_position'(user_input,N,M).
|
||||
stream_position(A,N,M) :-
|
||||
atom(A),
|
||||
current_stream(_,_,S), '$user_file_name'(S,A), !,
|
||||
'$current_stream'(_,_,S), '$user_file_name'(S,A), !,
|
||||
'$stream_position'(S,N,M).
|
||||
stream_position(S,N,M) :-
|
||||
'$stream_position'(S,N,M).
|
||||
@ -763,17 +763,17 @@ set_stream_position(user,N) :- !,
|
||||
'$set_stream_position'(user_input,N).
|
||||
set_stream_position(A,N) :-
|
||||
atom(A),
|
||||
current_stream(_,_,S), '$user_file_name'(S,A), !,
|
||||
'$current_stream'(_,_,S), '$user_file_name'(S,A), !,
|
||||
'$set_stream_position'(S,N).
|
||||
set_stream_position(S,N) :-
|
||||
'$set_stream_position'(S,N).
|
||||
|
||||
stream_property(Stream, Prop) :- var(Prop), !,
|
||||
(var(Stream) -> current_stream(_,_,Stream) ; true),
|
||||
(var(Stream) -> '$current_stream'(_,_,Stream) ; true),
|
||||
'$generate_prop'(Prop),
|
||||
'$stream_property'(Stream, Prop).
|
||||
stream_property(Stream, Props) :- var(Stream), !,
|
||||
current_stream(_,_,Stream),
|
||||
'$current_stream'(_,_,Stream),
|
||||
'$stream_property'(Stream, Props).
|
||||
stream_property(Stream, Props) :-
|
||||
'$check_stream'(Stream), !,
|
||||
@ -798,7 +798,7 @@ stream_property(Stream, Props) :-
|
||||
'$stream_property'(Stream, Props0) :-
|
||||
'$check_stream_props'(Props0, Props),
|
||||
'$check_io_opts'(Props, stream_property(Stream, Props)),
|
||||
current_stream(F,Mode,Stream),
|
||||
'$current_stream'(F,Mode,Stream),
|
||||
'$process_stream_properties'(Props, Stream, F, Mode).
|
||||
|
||||
'$check_stream_props'([], []) :- !.
|
||||
@ -883,9 +883,9 @@ absolute_file_name(RelFile, AbsFile) :-
|
||||
'$exists'(F,Mode,AbsFile) :-
|
||||
'$get_value'(fileerrors,V),
|
||||
'$set_value'(fileerrors,0),
|
||||
( open(F,Mode,S), !,
|
||||
( '$open'(F,Mode,S,0), !,
|
||||
'$file_name'(S, AbsFile),
|
||||
close(S), '$set_value'(fileerrors,V);
|
||||
'$close'(S), '$set_value'(fileerrors,V);
|
||||
'$set_value'(fileerrors,V), fail).
|
||||
|
||||
|
||||
@ -902,3 +902,7 @@ current_char_conversion(X,Y) :-
|
||||
'$fetch_char_conversion'(List,X,Y).
|
||||
|
||||
|
||||
current_stream(File, Opts, Stream) :-
|
||||
'$current_stream'(File, Opts, Stream).
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user