diff --git a/C/c_interface.c b/C/c_interface.c index 056a75f07..dda827e18 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -1197,6 +1197,105 @@ execute_cargs(PredEntry *pe, CPredicate exec_code) } } +typedef Int (*CBPredicate)(struct foreign_context *); +typedef Int (*CBPredicate1)(long,struct foreign_context *); +typedef Int (*CBPredicate2)(long,long,struct foreign_context *); +typedef Int (*CBPredicate3)(long,long,long,struct foreign_context *); +typedef Int (*CBPredicate4)(long,long,long,long,struct foreign_context *); +typedef Int (*CBPredicate5)(long,long,long,long,long,struct foreign_context *); +typedef Int (*CBPredicate6)(long,long,long,long,long,long,struct foreign_context *); +typedef Int (*CBPredicate7)(long,long,long,long,long,long,long,struct foreign_context *); +typedef Int (*CBPredicate8)(long,long,long,long,long,long,long,long,struct foreign_context *); + +static Int +execute_cargs_back(PredEntry *pe, CPredicate exec_code, struct foreign_context *ctx) +{ + switch (pe->ArityOfPE) { + case 0: + { + CBPredicate code0 = (CBPredicate)exec_code; + return ((code0)(ctx)); + } + case 1: + { + CBPredicate1 code1 = (CBPredicate1)exec_code; + return ((code1)(Yap_InitSlot(Deref(ARG1)), + ctx)); + } + case 2: + { + CBPredicate2 code2 = (CBPredicate2)exec_code; + return ((code2)(Yap_InitSlot(Deref(ARG1)), + Yap_InitSlot(Deref(ARG2)), + ctx)); + } + case 3: + { + CBPredicate3 code3 = (CBPredicate3)exec_code; + return ((code3)(Yap_InitSlot(Deref(ARG1)), + Yap_InitSlot(Deref(ARG2)), + Yap_InitSlot(Deref(ARG3)), + ctx)); + } + case 4: + { + CBPredicate4 code4 = (CBPredicate4)exec_code; + return ((code4)(Yap_InitSlot(Deref(ARG1)), + Yap_InitSlot(Deref(ARG2)), + Yap_InitSlot(Deref(ARG3)), + Yap_InitSlot(Deref(ARG4)), + ctx)); + } + case 5: + { + CBPredicate5 code5 = (CBPredicate5)exec_code; + return ((code5)(Yap_InitSlot(Deref(ARG1)), + Yap_InitSlot(Deref(ARG2)), + Yap_InitSlot(Deref(ARG3)), + Yap_InitSlot(Deref(ARG4)), + Yap_InitSlot(Deref(ARG5)), ctx)); + } + case 6: + { + CBPredicate6 code6 = (CBPredicate6)exec_code; + return ((code6)(Yap_InitSlot(Deref(ARG1)), + Yap_InitSlot(Deref(ARG2)), + Yap_InitSlot(Deref(ARG3)), + Yap_InitSlot(Deref(ARG4)), + Yap_InitSlot(Deref(ARG5)), + Yap_InitSlot(Deref(ARG6)), + ctx)); + } + case 7: + { + CBPredicate7 code7 = (CBPredicate7)exec_code; + return ((code7)(Yap_InitSlot(Deref(ARG1)), + Yap_InitSlot(Deref(ARG2)), + Yap_InitSlot(Deref(ARG3)), + Yap_InitSlot(Deref(ARG4)), + Yap_InitSlot(Deref(ARG5)), + Yap_InitSlot(Deref(ARG6)), + Yap_InitSlot(Deref(ARG7)), + ctx)); + } + case 8: + { + CBPredicate8 code8 = (CBPredicate8)exec_code; + return ((code8)(Yap_InitSlot(Deref(ARG1)), + Yap_InitSlot(Deref(ARG2)), + Yap_InitSlot(Deref(ARG3)), + Yap_InitSlot(Deref(ARG4)), + Yap_InitSlot(Deref(ARG5)), + Yap_InitSlot(Deref(ARG6)), + Yap_InitSlot(Deref(ARG7)), + Yap_InitSlot(Deref(ARG8)), + ctx)); + } + default: + return(FALSE); + } +} + Int YAP_Execute(PredEntry *pe, CPredicate exec_code) @@ -1223,7 +1322,7 @@ YAP_Execute(PredEntry *pe, CPredicate exec_code) Int YAP_ExecuteFirst(PredEntry *pe, CPredicate exec_code) { - if (pe->PredFlags & SWIEnvPredFlag) { + if (pe->PredFlags & (SWIEnvPredFlag|CArgsPredFlag)) { Int val; CPredicateV codev = (CPredicateV)exec_code; struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1)); @@ -1231,7 +1330,11 @@ YAP_ExecuteFirst(PredEntry *pe, CPredicate exec_code) ctx->control = FRG_FIRST_CALL; ctx->engine = NULL; //(PL_local_data *)Yap_regp; ctx->context = NULL; - val = ((codev)((&ARG1)-LCL0,0,ctx)); + if (pe->PredFlags & CArgsPredFlag) { + val = execute_cargs_back(pe, exec_code, ctx); + } else { + val = ((codev)((&ARG1)-LCL0,0,ctx)); + } if (val == 0) { cut_fail(); } else if (val == 1) { /* TRUE */ @@ -1241,10 +1344,8 @@ YAP_ExecuteFirst(PredEntry *pe, CPredicate exec_code) ctx->context = (int *)(val & ~REDO_PTR); else ctx->context = (int *)((val & ~REDO_PTR)>>FRG_REDO_BITS); + return TRUE; } - } - if (pe->PredFlags & CArgsPredFlag) { - return execute_cargs(pe, exec_code); } else { return (exec_code)(); } @@ -1260,7 +1361,11 @@ YAP_ExecuteNext(PredEntry *pe, CPredicate exec_code) struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1)); ctx->control = FRG_REDO; - val = ((codev)((&ARG1)-LCL0,0,ctx)); + if (pe->PredFlags & CArgsPredFlag) { + val = execute_cargs_back(pe, exec_code, ctx); + } else { + val = ((codev)((&ARG1)-LCL0,0,ctx)); + } if (val == 0) { cut_fail(); } else if (val == 1) { /* TRUE */ @@ -1271,12 +1376,9 @@ YAP_ExecuteNext(PredEntry *pe, CPredicate exec_code) else ctx->context = (int *)((val & ~REDO_PTR)>>FRG_REDO_BITS); } + return TRUE; } - if (pe->PredFlags & CArgsPredFlag) { - return execute_cargs(pe, exec_code); - } else { - return (exec_code)(); - } + return (exec_code)(); } X_API Int diff --git a/include/SWI-Prolog.h b/include/SWI-Prolog.h index 355061e83..cc6a9aabb 100755 --- a/include/SWI-Prolog.h +++ b/include/SWI-Prolog.h @@ -479,6 +479,32 @@ X_API int PL_error(const char *pred, int arity, const char *msg, int id, ...); X_API int PL_warning(const char *msg, ...); + /******************************** + * NON-DETERMINISTIC CALL/RETURN * + *********************************/ + +/* Note 1: Non-deterministic foreign functions may also use the deterministic + return methods PL_succeed and PL_fail. + + Note 2: The argument to PL_retry is a sizeof(ptr)-2 bits signed + integer (use type intptr_t). +*/ + +#define PL_FIRST_CALL (0) +#define PL_CUTTED (1) +#define PL_REDO (2) + +#define PL_retry(n) return _PL_retry(n) +#define PL_retry_address(a) return _PL_retry_address(a) + +PL_EXPORT(foreign_t) _PL_retry(intptr_t); +PL_EXPORT(foreign_t) _PL_retry_address(void *); +PL_EXPORT(int) PL_foreign_control(control_t); +PL_EXPORT(intptr_t) PL_foreign_context(control_t); +PL_EXPORT(void *) PL_foreign_context_address(control_t); + + + #ifdef __cplusplus } #endif diff --git a/library/yap2swi/yap2swi.c b/library/yap2swi/yap2swi.c index 25f1615c8..a94b59578 100644 --- a/library/yap2swi/yap2swi.c +++ b/library/yap2swi/yap2swi.c @@ -2258,6 +2258,63 @@ PL_eval_expression_to_int64_ex(term_t t, int64_t *val) return FALSE; } +foreign_t +_PL_retry(intptr_t n) +{ + /* first we need to get the pointer to the predicate */ + PredEntry *pe = B->cp_ap->u.OtapFs.p; + struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1)); + ctx->context = n; + return LCL0-(CELL *)ctx; +} + +foreign_t +_PL_retry_address(void *addr) +{ + /* first we need to get the pointer to the predicate */ + PredEntry *pe = B->cp_ap->u.OtapFs.p; + struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1)); + ctx->context = (intptr_t)addr; + return LCL0-(CELL *)ctx; +} + + +int +PL_foreign_control(control_t ctx) +{ + switch (ctx->control) { + case FRG_REDO: + return PL_REDO; + case FRG_FIRST_CALL: + return PL_FIRST_CALL; + default: + return PL_CUTTED; + } +} + +intptr_t +PL_foreign_context(control_t ctx) +{ + switch (ctx->control) { + case FRG_FIRST_CALL: + return 0L; + default: + return (intptr_t)(ctx->context); + } +} + + +void * +PL_foreign_context_address(control_t ctx) +{ + switch (ctx->control) { + case FRG_FIRST_CALL: + return NULL; + default: + return (void *)(ctx->context); + } +} + static int SWI_ctime(void)