/*-------------------------------------------------------------------------* * PL_RECOVER_SOLUTIONS_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Recover_Solutions_2(WamWord stop_word, WamWord handle_key_word, WamWord list_word) { int stop; int nb_sol; WamWord *p, *q; OneSol *s; Bool handle_key; stop = Pl_Rd_Integer(stop_word); nb_sol = sol->sol_no - stop; if (nb_sol == 0) return Pl_Get_Nil(list_word); handle_key = Pl_Rd_Integer(handle_key_word); key_var_ptr = pl_glob_dico_var; /* pl_glob_dico_var: key vars */ H += 2 * nb_sol; /* Since we start from the end to the beginning, if nb_sol is very big * when the heap overflow triggers a SIGSEGV the handler will not detect * that the heap is the culprit (and emits a simple Segmentation Violation * message). To avoid this we remain just after the end of the stack. */ if (H > Global_Stack + Global_Size) H = Global_Stack + Global_Size; p = q = H; while (nb_sol--) { p--; *p = Tag_LST(p + 1); *--p = Tag_REF(H); Pl_Copy_Contiguous_Term(H, &sol->term_word); if (handle_key) Handle_Key_Variables(*H); H += sol->term_size; s = sol; sol = sol->prev; Free(s); } q[-1] = NIL_WORD; return Pl_Unify(Tag_LST(p), list_word); }
/*-------------------------------------------------------------------------* * PL_RECOVER_SOLUTIONS_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Recover_Solutions_2(WamWord stop_word, WamWord handle_key_word, WamWord list_word) { int stop; int nb_sol; WamWord *p, *q; OneSol *s; Bool handle_key; stop = Pl_Rd_Integer(stop_word); nb_sol = sol->sol_no - stop; if (nb_sol == 0) return Pl_Get_Nil(list_word); handle_key = Pl_Rd_Integer(handle_key_word); key_var_ptr = pl_glob_dico_var; /* pl_glob_dico_var: key vars */ H += 2 * nb_sol; p = q = H; while (nb_sol--) { p--; *p = Tag_LST(p + 1); *--p = Tag_REF(H); Pl_Copy_Contiguous_Term(H, &sol->term_word); if (handle_key) Handle_Key_Variables(*H); H += sol->term_size; s = sol; sol = sol->prev; Free(s); } q[-1] = NIL_WORD; return Pl_Unify(Tag_LST(p), list_word); }
/*-------------------------------------------------------------------------* * PL_BLT_UNIV * * * *-------------------------------------------------------------------------*/ Bool FC Pl_Blt_Univ(WamWord term_word, WamWord list_word) { WamWord word, tag_mask; WamWord *adr; WamWord car_word; int lst_length; WamWord *arg1_adr; WamWord *term_adr, *lst_adr, *stc_adr; WamWord functor_word, functor_tag; int functor; int arity; Pl_Set_C_Bip_Name("=..", 2); DEREF(term_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) goto list_to_term; /* from term to list functor+args */ if (tag_mask == TAG_LST_MASK) { adr = UnTag_LST(word); car_word = Tag_ATM(ATOM_CHAR('.')); lst_length = 1 + 2; arg1_adr = &Car(adr); } else if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); car_word = Tag_ATM(Functor(adr)); lst_length = 1 + Arity(adr); arg1_adr = &Arg(adr, 0); } #ifndef NO_USE_FD_SOLVER else if (tag_mask == TAG_FDV_MASK) { adr = UnTag_FDV(word); car_word = Tag_REF(adr); /* since Dont_Separate_Tag */ lst_length = 1 + 0; } #endif else /* TAG_ATM/INT/FLT_MASK */ { car_word = word; lst_length = 1 + 0; } Pl_Check_For_Un_List(list_word); Pl_Unset_C_Bip_Name(); for (;;) { if (!Pl_Get_List(list_word) || !Pl_Unify_Value(car_word)) return FALSE; list_word = Pl_Unify_Variable(); if (--lst_length == 0) break; car_word = *arg1_adr++; } return Pl_Get_Nil(list_word); /* from list functor+args to term */ list_to_term: term_adr = UnTag_REF(word); DEREF(list_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (word == NIL_WORD) Pl_Err_Domain(pl_domain_non_empty_list, list_word); if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, list_word); lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), functor_word, functor_tag); if (functor_tag == TAG_REF_MASK) Pl_Err_Instantiation(); DEREF(Cdr(lst_adr), word, tag_mask); if (word == NIL_WORD) { if (functor_tag != TAG_ATM_MASK && functor_tag != TAG_INT_MASK && functor_tag != TAG_FLT_MASK) Pl_Err_Type(pl_type_atomic, functor_word); term_word = functor_word; goto finish; } if (functor_tag != TAG_ATM_MASK) Pl_Err_Type(pl_type_atom, functor_word); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, list_word); functor = UnTag_ATM(functor_word); stc_adr = H; H++; /* space for f/n maybe lost if a list */ arity = 0; for (;;) { arity++; lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); Do_Copy_Of_Word(tag_mask, word); /* since Dont_Separate_Tag */ Global_Push(word); DEREF(Cdr(lst_adr), word, tag_mask); if (word == NIL_WORD) break; if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, list_word); } if (arity > MAX_ARITY) Pl_Err_Representation(pl_representation_max_arity); if (functor == ATOM_CHAR('.') && arity == 2) /* a list */ term_word = Tag_LST(stc_adr + 1); else { *stc_adr = Functor_Arity(functor, arity); term_word = Tag_STC(stc_adr); } finish: Bind_UV(term_adr, term_word); Pl_Unset_C_Bip_Name(); return TRUE; }
/*-------------------------------------------------------------------------* * PL_COPY_CONTIGUOUS_TERM * * * * Copy a contiguous term (dereferenced), the result is a contiguous term. * *-------------------------------------------------------------------------*/ void Pl_Copy_Contiguous_Term(WamWord *dst_adr, WamWord *src_adr) #define Old_Adr_To_New_Adr(adr) ((dst_adr)+((adr)-(src_adr))) { WamWord word, *adr; WamWord *q; int i; terminal_rec: word = *src_adr; switch (Tag_Of(word)) { case REF: adr = UnTag_REF(word); q = Old_Adr_To_New_Adr(adr); *dst_adr = Tag_REF(q); if (adr > src_adr) /* only useful for Dont_Separate_Tag */ Pl_Copy_Contiguous_Term(q, adr); return; #ifndef NO_USE_FD_SOLVER case FDV: adr = UnTag_FDV(word); Fd_Copy_Variable(dst_adr, adr); return; #endif case FLT: adr = UnTag_FLT(word); q = Old_Adr_To_New_Adr(adr); q[0] = adr[0]; #if WORD_SIZE == 32 q[1] = adr[1]; #endif *dst_adr = Tag_FLT(q); return; case LST: adr = UnTag_LST(word); q = Old_Adr_To_New_Adr(adr); *dst_adr = Tag_LST(q); q = &Car(q); adr = &Car(adr); Pl_Copy_Contiguous_Term(q++, adr++); dst_adr = q; src_adr = adr; goto terminal_rec; case STC: adr = UnTag_STC(word); q = Old_Adr_To_New_Adr(adr); *dst_adr = Tag_STC(q); Functor_And_Arity(q) = Functor_And_Arity(adr); i = Arity(adr); q = &Arg(q, 0); adr = &Arg(adr, 0); while (--i) Pl_Copy_Contiguous_Term(q++, adr++); dst_adr = q; src_adr = adr; goto terminal_rec; default: *dst_adr = word; return; } }
/*-------------------------------------------------------------------------* * COPY_TERM_REC * * * * p is the next address to use to store the rest of a term. * *-------------------------------------------------------------------------*/ static void Copy_Term_Rec(WamWord *dst_adr, WamWord *src_adr, WamWord **p) { WamWord word, tag_mask; WamWord *adr; WamWord *q; int i; terminal_rec: DEREF(*src_adr, word, tag_mask); switch (Tag_From_Tag_Mask(tag_mask)) { case REF: adr = UnTag_REF(word); q = *p; if (adr < q && adr >= base_copy) /* already a copy */ { *dst_adr = word; return; } if (top_vars >= end_vars) Pl_Err_Representation(pl_representation_too_many_variables); *top_vars++ = word; /* word to restore */ *top_vars++ = (WamWord) adr; /* address to restore */ *adr = *dst_adr = Tag_REF(dst_adr); /* bind to a new copy */ return; #ifndef NO_USE_FD_SOLVER case FDV: adr = UnTag_FDV(word); q = *p; if (adr < q && adr >= base_copy) /* already a copy */ { *dst_adr = Tag_REF(adr); /* since Dont_Separate_Tag */ return; } if (top_vars >= end_vars) Pl_Err_Representation(pl_representation_too_many_variables); *top_vars++ = word; /* word to restore */ *top_vars++ = (WamWord) adr; /* address to restore */ q = *p; *p = q + Fd_Copy_Variable(q, adr); *adr = *dst_adr = Tag_REF(q); /* bind to a new copy */ return; #endif case FLT: adr = UnTag_FLT(word); q = *p; q[0] = adr[0]; #if WORD_SIZE == 32 q[1] = adr[1]; *p = q + 2; #else *p = q + 1; #endif *dst_adr = Tag_FLT(q); return; case LST: adr = UnTag_LST(word); q = *p; *dst_adr = Tag_LST(q); *p = &Cdr(q) + 1; q = &Car(q); adr = &Car(adr); Copy_Term_Rec(q++, adr++, p); dst_adr = q; src_adr = adr; goto terminal_rec; case STC: adr = UnTag_STC(word); q = *p; *dst_adr = Tag_STC(q); Functor_And_Arity(q) = Functor_And_Arity(adr); i = Arity(adr); *p = &Arg(q, i - 1) + 1; q = &Arg(q, 0); adr = &Arg(adr, 0); while (--i) Copy_Term_Rec(q++, adr++, p); dst_adr = q; src_adr = adr; goto terminal_rec; default: *dst_adr = word; return; } }