/*-------------------------------------------------------------------------* * PL_FD_PROLOG_TO_ARRAY_INT * * * *-------------------------------------------------------------------------*/ WamWord * Pl_Fd_Prolog_To_Array_Int(WamWord list_word) { WamWord word, tag_mask; WamWord save_list_word; WamWord *lst_adr; WamWord val; int n = 0; WamWord *array; WamWord *save_array; array = CS; save_list_word = list_word; save_array = array; array++; /* +1 for the nb of elems */ for (;;) { DEREF(list_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (word == NIL_WORD) break; if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, save_list_word); lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_INT_MASK) Pl_Err_Type(pl_type_integer, word); val = UnTag_INT(word); *array++ = val; n++; list_word = Cdr(lst_adr); } *save_array = n; CS = array; return save_array; }
/*-------------------------------------------------------------------------* * PL_FD_LIST_INT_TO_RANGE * * * *-------------------------------------------------------------------------*/ void Pl_Fd_List_Int_To_Range(Range *range, WamWord list_word) { WamWord word, tag_mask; WamWord save_list_word; WamWord *lst_adr; WamWord val; int n = 0; save_list_word = list_word; range->extra_cstr = FALSE; Vector_Allocate_If_Necessary(range->vec); Pl_Vector_Empty(range->vec); for (;;) { DEREF(list_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (word == NIL_WORD) break; if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, save_list_word); lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_INT_MASK) Pl_Err_Type(pl_type_integer, word); val = UnTag_INT(word); if ((unsigned) val > (unsigned) pl_vec_max_integer) range->extra_cstr = TRUE; else { Vector_Set_Value(range->vec, val); n++; } list_word = Cdr(lst_adr); } if (n == 0) Set_To_Empty(range); else Pl_Range_From_Vector(range); }
/*-------------------------------------------------------------------------* * READ_ARG * * * *-------------------------------------------------------------------------*/ static WamWord Read_Arg(WamWord **lst_adr) { WamWord word, tag_mask; WamWord *adr; WamWord car_word; DEREF(**lst_adr, word, tag_mask); if (tag_mask != TAG_LST_MASK) { if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (word == NIL_WORD) Pl_Err_Domain(pl_domain_non_empty_list, word); Pl_Err_Type(pl_type_list, word); } adr = UnTag_LST(word); car_word = Car(adr); *lst_adr = &Cdr(adr); DEREF(car_word, word, tag_mask); return word; }
/*-------------------------------------------------------------------------* * PL_FD_PROLOG_TO_FD_VAR * * * *-------------------------------------------------------------------------*/ WamWord * Pl_Fd_Prolog_To_Fd_Var(WamWord arg_word, Bool pl_var_ok) { WamWord word, tag_mask; WamWord *adr, *fdv_adr; DEREF(arg_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) { if (!pl_var_ok) Pl_Err_Instantiation(); adr = UnTag_REF(word); fdv_adr = Pl_Fd_New_Variable(); Bind_UV(adr, Tag_REF(fdv_adr)); return fdv_adr; } if (tag_mask == TAG_INT_MASK) return Pl_Fd_New_Int_Variable(UnTag_INT(word)); if (tag_mask == TAG_FDV_MASK) return UnTag_FDV(word); Pl_Err_Type(pl_type_fd_variable, word); return NULL; }
/*-------------------------------------------------------------------------* * PL_GET_PRED_INDICATOR * * * * returns the functor and initializes the arity of the predicate indicator* * func= -1 if it is a variable, arity= -1 if it is a variable * *-------------------------------------------------------------------------*/ int Pl_Get_Pred_Indicator(WamWord pred_indic_word, Bool must_be_ground, int *arity) { WamWord word, tag_mask; int func; DEREF(pred_indic_word, word, tag_mask); if (tag_mask == TAG_REF_MASK && must_be_ground) Pl_Err_Instantiation(); if (!Pl_Get_Structure(ATOM_CHAR('/'), 2, pred_indic_word)) { if (!Flag_Value(FLAG_STRICT_ISO) && Pl_Rd_Callable(word, &func, arity) != NULL) return func; Pl_Err_Type(pl_type_predicate_indicator, pred_indic_word); } pl_pi_name_word = Pl_Unify_Variable(); pl_pi_arity_word = Pl_Unify_Variable(); if (must_be_ground) func = Pl_Rd_Atom_Check(pl_pi_name_word); else { DEREF(pl_pi_name_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) func = -1; else func = Pl_Rd_Atom_Check(pl_pi_name_word); } if (must_be_ground) { *arity = Pl_Rd_Positive_Check(pl_pi_arity_word); if (*arity > MAX_ARITY) Pl_Err_Representation(pl_representation_max_arity); } else { DEREF(pl_pi_arity_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) *arity = -1; else { *arity = Pl_Rd_Positive_Check(pl_pi_arity_word); if (*arity > MAX_ARITY) Pl_Err_Representation(pl_representation_max_arity); } } return func; }
/*-------------------------------------------------------------------------* * PL_SET_STREAM_POSITION_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Set_Stream_Position_2(WamWord sora_word, WamWord position_word) { WamWord word, tag_mask; WamWord p_word[4]; int p[4]; int i; int stm; StmInf *pstm; stm = Pl_Get_Stream_Or_Alias(sora_word, STREAM_CHECK_EXIST); pstm = pl_stm_tbl[stm]; if (!pstm->prop.reposition) Pl_Err_Permission(pl_permission_operation_reposition, pl_permission_type_stream, sora_word); DEREF(position_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (!Pl_Get_Structure(pl_atom_stream_position, 4, position_word)) dom_error: Pl_Err_Domain(pl_domain_stream_position, position_word); for (i = 0; i < 4; i++) { p_word[i] = Pl_Unify_Variable(); DEREF(p_word[i], word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_INT_MASK) goto dom_error; p[i] = UnTag_INT(word); } return Pl_Stream_Set_Position(pstm, SEEK_SET, p[0], p[1], p[2], p[3]) == 0; }
/*-------------------------------------------------------------------------* * PL_FD_PROLOG_TO_VALUE * * * *-------------------------------------------------------------------------*/ int Pl_Fd_Prolog_To_Value(WamWord arg_word) { WamWord word, tag_mask; DEREF(arg_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_INT_MASK) Pl_Err_Type(pl_type_integer, word); return UnTag_INT(word); }
/*-------------------------------------------------------------------------* * CHAR_ASCII * * * *-------------------------------------------------------------------------*/ PlBool char_ascii(PlFIOArg *c, PlFIOArg *ascii) { if (!c->is_var) /* Char is not a variable */ { ascii->unify = PL_TRUE; /* enforce unif. of Code */ ascii->value.l = c->value.l; /* set Code */ return PL_TRUE; /* succeed */ } if (ascii->is_var) /* Code is also a variable */ Pl_Err_Instantiation(); /* emit instantiation_error */ c->value.l = ascii->value.l; /* set Char */ return PL_TRUE; /* succeed */ }
/*-------------------------------------------------------------------------* * CHAR_ASCII2 * * * *-------------------------------------------------------------------------*/ PlBool char_ascii2(PlFIOArg *c, PlFIOArg *ascii) { if (!c->is_var) { if (!ascii->is_var) return ascii->value.l == c->value.l; ascii->value.l = c->value.l; return PL_TRUE; } if (ascii->is_var) Pl_Err_Instantiation(); c->value.l = ascii->value.l; return PL_TRUE; }
/*-------------------------------------------------------------------------* * LOAD_MATH_EXPRESSION * * * *-------------------------------------------------------------------------*/ static WamWord Load_Math_Expression(WamWord exp) { WamWord word, tag_mask; WamWord *adr; WamWord *lst_adr; ArithInf *arith; DEREF(exp, word, tag_mask); if (tag_mask == TAG_INT_MASK || tag_mask == TAG_FLT_MASK) return word; if (tag_mask == TAG_LST_MASK) { lst_adr = UnTag_LST(word); DEREF(Cdr(lst_adr), word, tag_mask); if (word != NIL_WORD) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(ATOM_CHAR('.')); Pl_Unify_Integer(2); Pl_Err_Type(pl_type_evaluable, word); } DEREF(Car(lst_adr), word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_INT_MASK) { Pl_Err_Type(pl_type_integer, word); } return word; } if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); arith = (ArithInf *) Pl_Hash_Find(arith_tbl, Functor_And_Arity(adr)); if (arith == NULL) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(Functor(adr)); Pl_Unify_Integer(Arity(adr)); Pl_Err_Type(pl_type_evaluable, word); } if (Arity(adr) == 1) return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0))); return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0)), Load_Math_Expression(Arg(adr, 1))); } if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask == TAG_ATM_MASK) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Value(exp); Pl_Unify_Integer(0); /* then type_error */ } Pl_Err_Type(pl_type_evaluable, word); return word; }
/*-------------------------------------------------------------------------* * PL_ATOM_CONCAT_3 * * * *-------------------------------------------------------------------------*/ Bool Pl_Atom_Concat_3(WamWord atom1_word, WamWord atom2_word, WamWord atom3_word) { WamWord word, tag_mask; int tag1, tag2, tag3; AtomInf *patom1, *patom2, *patom3; char *str; int l; DEREF(atom1_word, word, tag_mask); if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK) Pl_Err_Type(pl_type_atom, atom1_word); tag1 = tag_mask; atom1_word = word; DEREF(atom2_word, word, tag_mask); if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK) Pl_Err_Type(pl_type_atom, atom2_word); tag2 = tag_mask; atom2_word = word; DEREF(atom3_word, word, tag_mask); if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK) Pl_Err_Type(pl_type_atom, atom3_word); tag3 = tag_mask; atom3_word = word; if (tag3 == TAG_REF_MASK && (tag1 == TAG_REF_MASK || tag2 == TAG_REF_MASK)) Pl_Err_Instantiation(); if (tag1 == TAG_ATM_MASK) { patom1 = pl_atom_tbl + UnTag_ATM(atom1_word); if (tag2 == TAG_ATM_MASK) { patom2 = pl_atom_tbl + UnTag_ATM(atom2_word); l = patom1->prop.length + patom2->prop.length; MALLOC_STR(l); strcpy(str, patom1->name); strcpy(str + patom1->prop.length, patom2->name); return Pl_Get_Atom(Create_Malloc_Atom(str), atom3_word); } patom3 = pl_atom_tbl + UnTag_ATM(atom3_word); l = patom3->prop.length - patom1->prop.length; if (l < 0 || strncmp(patom1->name, patom3->name, patom1->prop.length) != 0) return FALSE; MALLOC_STR(l); strcpy(str, patom3->name + patom1->prop.length); return Pl_Get_Atom(Create_Malloc_Atom(str), atom2_word); } if (tag2 == TAG_ATM_MASK) /* here tag1 == REF */ { patom2 = pl_atom_tbl + UnTag_ATM(atom2_word); patom3 = pl_atom_tbl + UnTag_ATM(atom3_word); l = patom3->prop.length - patom2->prop.length; if (l < 0 || strncmp(patom2->name, patom3->name + l, patom2->prop.length) != 0) return FALSE; MALLOC_STR(l); strncpy(str, patom3->name, l); str[l] = '\0'; return Pl_Get_Atom(Create_Malloc_Atom(str), atom1_word); } /* A1 and A2 are variables: non deterministic case */ patom3 = pl_atom_tbl + UnTag_ATM(atom3_word); if (patom3->prop.length > 0) { A(0) = atom1_word; A(1) = atom2_word; A(2) = (WamWord) patom3; A(3) = (WamWord) (patom3->name + 1); Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(ATOM_CONCAT_ALT, 0), 4); } return Pl_Get_Atom(pl_atom_void, atom1_word) && Pl_Get_Atom_Tagged(atom3_word, atom2_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_BLT_FUNCTOR * * * *-------------------------------------------------------------------------*/ Bool FC Pl_Blt_Functor(WamWord term_word, WamWord functor_word, WamWord arity_word) { WamWord word, tag_mask; WamWord *adr; WamWord tag_functor; int arity; Bool res; Pl_Set_C_Bip_Name("functor", 3); DEREF(term_word, word, tag_mask); if (tag_mask != TAG_REF_MASK) { if (tag_mask == TAG_LST_MASK) res = Pl_Un_Atom_Check(ATOM_CHAR('.'), functor_word) && Pl_Un_Integer_Check(2, arity_word); else if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); res = Pl_Un_Atom_Check(Functor(adr), functor_word) && Pl_Un_Integer_Check(Arity(adr), arity_word); } else res = Pl_Unify(word, functor_word) && Pl_Un_Integer_Check(0, arity_word); goto finish; } /* tag_mask == TAG_REF_MASK */ DEREF(functor_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_ATM_MASK && tag_mask != TAG_INT_MASK && tag_mask != TAG_FLT_MASK) Pl_Err_Type(pl_type_atomic, functor_word); tag_functor = tag_mask; functor_word = word; arity = Pl_Rd_Positive_Check(arity_word); if (arity > MAX_ARITY) Pl_Err_Representation(pl_representation_max_arity); if (tag_functor == TAG_ATM_MASK && UnTag_ATM(functor_word) == ATOM_CHAR('.') && arity == 2) { res = (Pl_Get_List(term_word)) ? Pl_Unify_Void(2), TRUE : FALSE; goto finish; } if (tag_functor == TAG_ATM_MASK && arity > 0) { res = (Pl_Get_Structure(UnTag_ATM(functor_word), arity, term_word)) ? Pl_Unify_Void(arity), TRUE : FALSE; goto finish; } if (arity != 0) Pl_Err_Type(pl_type_atom, functor_word); res = Pl_Unify(functor_word, term_word); finish: Pl_Unset_C_Bip_Name(); return res; }
/*-------------------------------------------------------------------------* * PL_OPEN_3 * * * *-------------------------------------------------------------------------*/ void Pl_Open_3(WamWord source_sink_word, WamWord mode_word, WamWord stm_word) { WamWord word, tag_mask; int atom; int mode; Bool text; StmProp prop; char *path; int atom_file_name; int stm; FILE *f; int mask = SYS_VAR_OPTION_MASK; Bool reposition; DEREF(source_sink_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_ATM_MASK) Pl_Err_Domain(pl_domain_source_sink, source_sink_word); atom_file_name = UnTag_ATM(word); path = pl_atom_tbl[atom_file_name].name; if ((path = Pl_M_Absolute_Path_Name(path)) == NULL) Pl_Err_Existence(pl_existence_source_sink, source_sink_word); text = mask & 1; mask >>= 1; atom = Pl_Rd_Atom_Check(mode_word); if (atom == pl_atom_read) mode = STREAM_MODE_READ; else if (atom == pl_atom_write) mode = STREAM_MODE_WRITE; else if (atom == pl_atom_append) mode = STREAM_MODE_APPEND; else Pl_Err_Domain(pl_domain_io_mode, mode_word); stm = Pl_Add_Stream_For_Stdio_File(path, mode, text); if (stm < 0) { if (errno == ENOENT || errno == ENOTDIR) Pl_Err_Existence(pl_existence_source_sink, source_sink_word); else Pl_Err_Permission(pl_permission_operation_open, pl_permission_type_source_sink, source_sink_word); } prop = pl_stm_tbl[stm]->prop; f = (FILE *) pl_stm_tbl[stm]->file; /* change properties wrt to specified ones */ if ((mask & 2) != 0) /* reposition specified */ { reposition = mask & 1; if (reposition && !prop.reposition) { fclose(f); word = Pl_Put_Structure(pl_atom_reposition, 1); Pl_Unify_Atom(pl_atom_true); Pl_Err_Permission(pl_permission_operation_open, pl_permission_type_source_sink, word); } prop.reposition = reposition; } mask >>= 2; if ((mask & 4) != 0) /* eof_action specified */ prop.eof_action = mask & 3; mask >>= 3; if ((mask & 4) != 0) /* buffering specified */ if (prop.buffering != (unsigned) (mask & 3)) /* cast for MSVC warning */ { prop.buffering = mask & 3; Pl_Stdio_Set_Buffering(f, prop.buffering); } mask >>= 3; pl_stm_tbl[stm]->atom_file_name = atom_file_name; pl_stm_tbl[stm]->prop = prop; Pl_Get_Integer(stm, stm_word); }
/*-------------------------------------------------------------------------* * NORMALIZE * * * * This functions normalizes a term. * * Input: * * e_word: term to normalize * * sign : current sign of the term (-1 or +1) * * * * Output: * * p : the associated polynomial term * * * * Normalizes the term and loads it into p. * * Non-Linear operations are simplified and loaded into a stack to be * * executed later. * * * * T1*T2 : T1 and T2 are normalized to give the polynomials p1 and p2, with* * p1 = c1 + a1X1 + a2X2 + ... + anXn * * p2 = c2 + b1X1 + b2X2 + ... + bmXm * * and replaced by c1*c2 + * * a1X1 * c2 + a1X1 * b1X1 + ... + a1X1 * bmXm * * ... * * anX1 * c2 + anXn * b1X1 + ... + anXn * bmXm * * * * T1**T2: T1 and T2 are loaded into 2 new words word1 and word2 that can * * be integers or variables (tagged words). The code emitted * * depends on 3 possibilities (var**var is not allowed) * * (+ optim 1**T2, 0**T2, T1**0, T1**1), NB 0**0=1 * *-------------------------------------------------------------------------*/ static Bool Normalize(WamWord e_word, int sign, Poly *p) { WamWord word, tag_mask; WamWord *adr; WamWord *fdv_adr; WamWord word1, word2, word3; WamWord f_n, le_word, re_word; int i; PlLong n1, n2, n3; terminal_rec: DEREF(e_word, word, tag_mask); if (tag_mask == TAG_FDV_MASK) { fdv_adr = UnTag_FDV(word); Add_Monom(p, sign, 1, Tag_REF(fdv_adr)); return TRUE; } if (tag_mask == TAG_INT_MASK) { n1 = UnTag_INT(word); if (n1 > MAX_COEF_FOR_SORT) sort = TRUE; Add_Cst_To_Poly(p, sign, n1); return TRUE; } if (tag_mask == TAG_REF_MASK) { if (vars_sp - vars_tbl >= VARS_STACK_SIZE) Pl_Err_Resource(pl_resource_too_big_fd_constraint); *vars_sp++ = word; Add_Monom(p, sign, 1, word); return TRUE; } if (tag_mask == TAG_ATM_MASK) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Value(e_word); Pl_Unify_Integer(0); type_error: Pl_Err_Type(pl_type_fd_evaluable, word); } if (tag_mask != TAG_STC_MASK) goto type_error; adr = UnTag_STC(word); f_n = Functor_And_Arity(adr); for (i = 0; i < NB_OF_OP; i++) if (arith_tbl[i] == f_n) break; le_word = Arg(adr, 0); re_word = Arg(adr, 1); switch (i) { case PLUS_1: e_word = le_word; goto terminal_rec; case PLUS_2: if (!Normalize(le_word, sign, p)) return FALSE; e_word = re_word; goto terminal_rec; case MINUS_2: if (!Normalize(le_word, sign, p)) return FALSE; e_word = re_word; sign = -sign; goto terminal_rec; case MINUS_1: e_word = le_word; sign = -sign; goto terminal_rec; case TIMES_2: #ifdef DEVELOP_TIMES_2 #if 1 /* optimize frequent use: INT*VAR */ DEREF(le_word, word, tag_mask); if (tag_mask != TAG_INT_MASK) goto any; n1 = UnTag_INT(word); if (n1 > MAX_COEF_FOR_SORT) sort = TRUE; DEREF(re_word, word, tag_mask); if (tag_mask != TAG_REF_MASK) { if (tag_mask != TAG_FDV_MASK) goto any; else { fdv_adr = UnTag_FDV(word); word = Tag_REF(fdv_adr); } } Add_Monom(p, sign, n1, word); return TRUE; any: #endif { Poly p1, p2; int i1, i2; New_Poly(p1); New_Poly(p2); if (!Normalize(le_word, 1, &p1) || !Normalize(re_word, 1, &p2)) return FALSE; Add_Cst_To_Poly(p, sign, p1.c * p2.c); for (i1 = 0; i1 < p1.nb_monom; i1++) { Add_Monom(p, sign, p1.m[i1].a * p2.c, p1.m[i1].x_word); for (i2 = 0; i2 < p2.nb_monom; i2++) if (!Add_Multiply_Monom(p, sign, p1.m + i1, p2.m + i2)) return FALSE; } for (i2 = 0; i2 < p2.nb_monom; i2++) Add_Monom(p, sign, p2.m[i2].a * p1.c, p2.m[i2].x_word); return TRUE; } #else if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = n1 * n2; Add_Cst_To_Poly(p, sign, n1); return TRUE; } Add_Monom(p, sign, n1, word2); return TRUE; } if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); Add_Monom(p, sign, n2, word1); return TRUE; } word1 = (word1 == word2) ? Push_Delayed_Cstr(DC_X2_EQ_Y, word1, 0, 0) : Push_Delayed_Cstr(DC_XY_EQ_Z, word1, word2, 0); Add_Monom(p, sign, 1, word1); return TRUE; #endif case POWER_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); if ((n1 = Pl_Power(n1, n2)) < 0) return FALSE; Add_Cst_To_Poly(p, sign, n1); return TRUE; } if (n1 == 1) { Add_Cst_To_Poly(p, sign, 1); return TRUE; } word = (n1 == 0) ? Push_Delayed_Cstr(DC_ZERO_POWER_N_EQ_Y, word2, 0, 0) : Push_Delayed_Cstr(DC_A_POWER_N_EQ_Y, word1, word2, 0); goto end_power; } if (Tag_Mask_Of(word2) != TAG_INT_MASK) Pl_Err_Instantiation(); else { n2 = UnTag_INT(word2); if (n2 == 0) { Add_Cst_To_Poly(p, sign, 1); return TRUE; } word = (n2 == 1) ? word1 : (n2 == 2) ? Push_Delayed_Cstr(DC_X2_EQ_Y, word1, 0, 0) : Push_Delayed_Cstr(DC_X_POWER_A_EQ_Y, word1, word2, 0); } end_power: Add_Monom(p, sign, 1, word); return TRUE; case MIN_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = math_min(n1, n2); Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_MIN_X_A_EQ_Z, word2, word1, 0); goto end_min; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_MIN_X_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_MIN_X_Y_EQ_Z, word1, word2, 0); end_min: Add_Monom(p, sign, 1, word); return TRUE; case MAX_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = math_max(n1, n2); Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_MAX_X_A_EQ_Z, word2, word1, 0); goto end_max; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_MAX_X_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_MAX_X_Y_EQ_Z, word1, word2, 0); end_max: Add_Monom(p, sign, 1, word); return TRUE; case DIST_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = (n1 >= n2) ? n1 - n2 : n2 - n1; Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_ABS_X_MINUS_A_EQ_Z, word2, word1, 0); goto end_dist; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_ABS_X_MINUS_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_ABS_X_MINUS_Y_EQ_Z, word1, word2, 0); end_dist: Add_Monom(p, sign, 1, word); return TRUE; case QUOT_2: word3 = Make_Self_Ref(H); /* word3 = remainder */ Global_Push(word3); goto quot_rem; case REM_2: word3 = Make_Self_Ref(H); /* word3 = remainder */ Global_Push(word3); goto quot_rem; case QUOT_REM_3: quot_rem: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2) || (i == QUOT_REM_3 && !Load_Term_Into_Word(Arg(adr, 2), &word3))) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); if (n2 == 0) return FALSE; n3 = n1 % n2; if (i == QUOT_2 || i == QUOT_REM_3) { if (i == QUOT_REM_3) PRIM_CSTR_2(pl_x_eq_c, word3, word); else H--; /* recover word3 space */ n3 = n1 / n2; } Add_Cst_To_Poly(p, sign, n3); return TRUE; } word = Push_Delayed_Cstr(DC_QUOT_REM_A_Y_R_EQ_Z, word1, word2, word3); goto end_quot_rem; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_QUOT_REM_X_A_R_EQ_Z, word1, word2, word3); else word = Push_Delayed_Cstr(DC_QUOT_REM_X_Y_R_EQ_Z, word1, word2, word3); end_quot_rem: Add_Monom(p, sign, 1, (i == REM_2) ? word3 : word); return TRUE; case DIV_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); if (n2 == 0 || n1 % n2 != 0) return FALSE; n1 /= n2; Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_DIV_A_Y_EQ_Z, word1, word2, 0); goto end_div; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_DIV_X_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_DIV_X_Y_EQ_Z, word1, word2, 0); end_div: Add_Monom(p, sign, 1, word); return TRUE; default: word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(Functor(adr)); Pl_Unify_Integer(Arity(adr)); goto type_error; } return TRUE; }
/*-------------------------------------------------------------------------* * PL_FD_PROLOG_TO_ARRAY_FDV * * * *-------------------------------------------------------------------------*/ WamWord * Pl_Fd_Prolog_To_Array_Fdv(WamWord list_word, Bool pl_var_ok) { WamWord word, tag_mask; WamWord save_list_word; WamWord *lst_adr; int n = 0; WamWord *save_array; WamWord *array; /* compute the length of the list to */ /* reserve space in the heap for the */ /* array before pushing new FD vars. */ save_list_word = list_word; for (;;) { DEREF(list_word, word, tag_mask); if (tag_mask != TAG_LST_MASK) break; lst_adr = UnTag_LST(word); n++; list_word = Cdr(lst_adr); } array = CS; CS = CS + n + 1; list_word = save_list_word; save_array = array; array++; /* +1 for the nb of elems */ for (;;) { DEREF(list_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (word == NIL_WORD) break; if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, save_list_word); lst_adr = UnTag_LST(word); *array++ = (WamWord) Pl_Fd_Prolog_To_Fd_Var(Car(lst_adr), pl_var_ok); list_word = Cdr(lst_adr); } *save_array = n; return save_array; }