static void CleanBack(PredEntry *pe, CPredicate Start, CPredicate Cont, CPredicate Cut) { yamop *code; if (pe->cs.p_code.FirstClause != pe->cs.p_code.LastClause || pe->cs.p_code.TrueCodeOfPred != pe->cs.p_code.FirstClause || pe->CodeOfPred != pe->cs.p_code.FirstClause) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "initiating a C Pred with backtracking"); return; } code = (yamop *)(pe->cs.p_code.FirstClause); code->y_u.OtapFs.p = pe; if (pe->PredFlags & UserCPredFlag) code->opc = Yap_opcode(_try_userc); else code->opc = Yap_opcode(_try_c); #ifdef YAPOR INIT_YAMOP_LTT(code, 2); PUT_YAMOP_SEQ(code); #endif /* YAPOR */ code->y_u.OtapFs.f = Start; code = NEXTOP(code, OtapFs); if (pe->PredFlags & UserCPredFlag) code->opc = Yap_opcode(_retry_userc); else code->opc = Yap_opcode(_retry_c); #ifdef YAPOR INIT_YAMOP_LTT(code, 1); PUT_YAMOP_SEQ(code); #endif /* YAPOR */ code->y_u.OtapFs.f = Cont; code = NEXTOP(code, OtapFs); if (pe->PredFlags & UserCPredFlag) code->opc = Yap_opcode(_cut_c); else code->opc = Yap_opcode(_cut_userc); code->y_u.OtapFs.p = pe; code->y_u.OtapFs.f = Cut; }
static void InitOtaplInst(yamop start[1], OPCODE opc, PredEntry *pe) { yamop *ipc = start; /* this is a place holder, it should not really be used */ ipc->opc = Yap_opcode(opc); ipc->y_u.Otapl.s = 0; ipc->y_u.Otapl.p = pe; ipc->y_u.Otapl.d = NULL; #ifdef YAPOR INIT_YAMOP_LTT(ipc, 1); #endif /* YAPOR */ #ifdef TABLING ipc->y_u.Otapl.te = NULL; #endif /* TABLING */ }
void Yap_InitCPredBack_(const char *Name, arity_t Arity, arity_t Extra, CPredicate Start, CPredicate Cont, CPredicate Cut, pred_flags_t flags) { CACHE_REGS PredEntry *pe = NULL; Atom atom = NIL; Functor f = NULL; while (atom == NIL) { atom = Yap_FullLookupAtom(Name); if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (Arity) { while (!f) { f = Yap_MkFunctor(atom, Arity); if (!f && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } } while (pe == NULL) { if (Arity) pe = RepPredProp(PredPropByFunc(f, CurrentModule)); else pe = RepPredProp(PredPropByAtom(atom, CurrentModule)); if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (pe->cs.p_code.FirstClause != NIL) { flags = update_flags_from_prolog(flags, pe); CleanBack(pe, Start, Cont, Cut); } else { StaticClause *cl; yamop *code = ((StaticClause *)NULL)->ClCode; UInt sz = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(code, OtapFs), OtapFs), OtapFs), l); if (flags & UserCPredFlag) pe->PredFlags = UserCPredFlag | BackCPredFlag | CompiledPredFlag | flags; else pe->PredFlags = CompiledPredFlag | StandardPredFlag | BackCPredFlag; #ifdef YAPOR pe->PredFlags |= SequentialPredFlag; #endif /* YAPOR */ cl = (StaticClause *)Yap_AllocCodeSpace(sz); if (cl == NULL) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "No Heap Space in InitCPredBack"); return; } cl->ClFlags = StaticMask; cl->ClNext = NULL; Yap_ClauseSpace += sz; cl->ClSize = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(code, OtapFs), OtapFs), OtapFs), e); cl->usc.ClLine = Yap_source_line_no(); code = cl->ClCode; pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = pe->cs.p_code.FirstClause = pe->cs.p_code.LastClause = code; if (flags & UserCPredFlag) pe->OpcodeOfPred = code->opc = Yap_opcode(_try_userc); else pe->OpcodeOfPred = code->opc = Yap_opcode(_try_c); code->y_u.OtapFs.f = Start; code->y_u.OtapFs.p = pe; code->y_u.OtapFs.s = Arity; code->y_u.OtapFs.extra = Extra; #ifdef YAPOR INIT_YAMOP_LTT(code, 2); PUT_YAMOP_SEQ(code); #endif /* YAPOR */ code = NEXTOP(code, OtapFs); if (flags & UserCPredFlag) code->opc = Yap_opcode(_retry_userc); else code->opc = Yap_opcode(_retry_c); code->y_u.OtapFs.f = Cont; code->y_u.OtapFs.p = pe; code->y_u.OtapFs.s = Arity; code->y_u.OtapFs.extra = Extra; #ifdef YAPOR INIT_YAMOP_LTT(code, 1); PUT_YAMOP_SEQ(code); #endif /* YAPOR */ code = NEXTOP(code, OtapFs); if (flags & UserCPredFlag) code->opc = Yap_opcode(_cut_userc); else code->opc = Yap_opcode(_cut_c); code->y_u.OtapFs.f = Cut; code->y_u.OtapFs.p = pe; code->y_u.OtapFs.s = Arity; code->y_u.OtapFs.extra = Extra; code = NEXTOP(code, OtapFs); code->opc = Yap_opcode(_Ystop); code->y_u.l.l = cl->ClCode; } }
/*add clause to ClauseList returns FALSE on error*/ X_API int Yap_ClauseListExtend(clause_list_t cl, void * clause, void *pred) { CACHE_REGS PredEntry *ap = (PredEntry *)pred; /* fprintf(stderr,"cl=%p\n",clause); */ if (cl->end != H) return FALSE; if (cl->n == 0) { void **ptr; if (!(ptr = (void **)extend_blob(cl->start,1 PASS_REGS))) return FALSE; ptr[0] = clause; } else if (cl->n == 1) { yamop **ptr; yamop *code_p, *fclause; if (!(ptr = (yamop **)extend_blob(cl->start,2*(CELL)NEXTOP((yamop *)NULL,Otapl)/sizeof(CELL)-1 PASS_REGS))) return FALSE; fclause = ptr[-1]; code_p = (yamop *)(ptr-1); code_p->opc = Yap_opcode(_try_clause); code_p->u.Otapl.d = fclause; code_p->u.Otapl.s = ap->ArityOfPE; code_p->u.Otapl.p = ap; #ifdef TABLING code_p->u.Otapl.te = ap->TableOfPred; #endif #ifdef YAPOR INIT_YAMOP_LTT(code_p, 0); #endif /* YAPOR */ code_p = NEXTOP(code_p,Otapl); code_p->opc = Yap_opcode(_trust); code_p->u.Otapl.d = clause; code_p->u.Otapl.s = ap->ArityOfPE; code_p->u.Otapl.p = ap; #ifdef TABLING code_p->u.Otapl.te = ap->TableOfPred; #endif #ifdef YAPOR INIT_YAMOP_LTT(code_p, 0); #endif /* YAPOR */ } else { yamop *code_p; if (!(code_p = (yamop *)extend_blob(cl->start,((CELL)NEXTOP((yamop *)NULL,Otapl))/sizeof(CELL) PASS_REGS))) return FALSE; code_p->opc = Yap_opcode(_trust); code_p->u.Otapl.d = clause; code_p->u.Otapl.s = ap->ArityOfPE; code_p->u.Otapl.p = ap; #ifdef TABLING code_p->u.Otapl.te = ap->TableOfPred; #endif #ifdef YAPOR INIT_YAMOP_LTT(code_p, 0); #endif /* YAPOR */ code_p = PREVOP(code_p,Otapl); code_p->opc = Yap_opcode(_retry); } cl->end = H; cl->n++; return TRUE; }