WamWord FC Pl_Fct_Fast_Mul(WamWord x, WamWord y) { long vx = UnTag_INT(x); long vy = UnTag_INT(y); return Tag_INT(vx * vy); }
WamWord FC Pl_Fct_Fast_Shr(WamWord x, WamWord y) { long vx = UnTag_INT(x); long vy = UnTag_INT(y); return Tag_INT(vx >> vy); }
Bool FC Pl_Blt_Fast_Gte(WamWord x, WamWord y) { long vx = UnTag_INT(x); long vy = UnTag_INT(y); return vx >= vy; }
WamWord FC Pl_Fct_Fast_Rem(WamWord x, WamWord y) { long vx = UnTag_INT(x); long vy = UnTag_INT(y); if (vy == 0) Pl_Err_Evaluation(pl_evluation_zero_divisor); return Tag_INT(vx % vy); }
/*-------------------------------------------------------------------------* * PL_NUMBER_CODES_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Number_Codes_2(WamWord number_word, WamWord codes_word) { WamWord word, tag_mask; WamWord *lst_adr, list_word; char *str = pl_glob_buff; PlLong c; list_word = codes_word; for (;;) { DEREF(list_word, word, tag_mask); if (word == NIL_WORD) break; if (tag_mask != TAG_LST_MASK) goto from_nb; lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); c = UnTag_INT(word); if (tag_mask != TAG_INT_MASK || !Is_Valid_Code(c)) goto from_nb; *str++ = (char) c; list_word = Cdr(lst_adr); } *str = '\0'; return String_To_Number(pl_glob_buff, number_word); from_nb: DEREF(number_word, word, tag_mask); if (tag_mask == TAG_INT_MASK) { sprintf(pl_glob_buff, "%" PL_FMT_d, UnTag_INT(word)); return Pl_Un_Codes_Check(pl_glob_buff, codes_word); } if (tag_mask != TAG_REF_MASK) { str = Pl_Float_To_String(Pl_Rd_Number_Check(word)); return Pl_Un_Codes_Check(str, codes_word); } Pl_Rd_Codes_Check(codes_word); /* only to raise the correct error */ return FALSE; }
/*-------------------------------------------------------------------------* * PL_CURRENT_STREAM_1 * * * *-------------------------------------------------------------------------*/ Bool Pl_Current_Stream_1(WamWord stm_word) { WamWord word, tag_mask; int stm = 0; DEREF(stm_word, word, tag_mask); /* either an INT or a REF */ if (tag_mask == TAG_INT_MASK) { stm = UnTag_INT(word); return (stm >= 0 && stm <= pl_stm_last_used && pl_stm_tbl[stm] != NULL); } for (; stm <= pl_stm_last_used; stm++) if (pl_stm_tbl[stm]) break; if (stm >= pl_stm_last_used) { if (stm > pl_stm_last_used) return FALSE; } else /* non deterministic case */ { A(0) = stm_word; A(1) = stm + 1; Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(CURRENT_STREAM_ALT, 0), 2); } return Pl_Get_Integer(stm, stm_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; }
WamWord FC Pl_Fct_Fast_Mod(WamWord x, WamWord y) { long vx = UnTag_INT(x); long vy = UnTag_INT(y); long m; if (vy == 0) Pl_Err_Evaluation(pl_evluation_zero_divisor); m = vx % vy; if (m != 0 && (m ^ vy) < 0) /* have m and vy different signs ? */ m += vy; return Tag_INT(m); }
/*-------------------------------------------------------------------------* * PL_CURRENT_PREDICATE_ALT_0 * * * *-------------------------------------------------------------------------*/ Bool Pl_Current_Predicate_Alt_0(void) { WamWord name_word, arity_word; HashScan scan; PredInf *pred; int which_preds; int func, arity; int func1, arity1; Bool all; Pl_Update_Choice_Point((CodePtr) Prolog_Predicate(CURRENT_PREDICATE_ALT, 0), 0); name_word = AB(B, 0); arity_word = AB(B, 1); which_preds = AB(B, 2); scan.endt = (char *) AB(B, 3); scan.cur_t = (char *) AB(B, 4); scan.cur_p = (char *) AB(B, 5); func = Tag_Mask_Of(name_word) == TAG_REF_MASK ? -1 : UnTag_ATM(name_word); arity = Tag_Mask_Of(arity_word) == TAG_REF_MASK ? -1 : UnTag_INT(arity_word); /* here func or arity == -1 (or both) */ all = (func == -1 && arity == -1); for (;;) { pred = (PredInf *) Pl_Hash_Next(&scan); if (pred == NULL) { Delete_Last_Choice_Point(); return FALSE; } func1 = Functor_Of(pred->f_n); arity1 = Arity_Of(pred->f_n); if ((all || func == func1 || arity == arity1) && Pred_Is_Ok(pred, func1, which_preds)) break; } /* non deterministic case */ #if 0 /* the following data is unchanged */ AB(B, 0) = name_word; AB(B, 1) = arity_word; AB(B, 2) = which_preds; AB(B, 3) = (WamWord) scan.endt; #endif AB(B, 4) = (WamWord) scan.cur_t; AB(B, 5) = (WamWord) scan.cur_p; return Pl_Get_Atom(Functor_Of(pred->f_n), name_word) && Pl_Get_Integer(Arity_Of(pred->f_n), arity_word); }
/*-------------------------------------------------------------------------* * 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); }
/*-------------------------------------------------------------------------* * PL_FD_CHECK_FOR_BOOL_VAR * * * *-------------------------------------------------------------------------*/ Bool Pl_Fd_Check_For_Bool_Var(WamWord x_word) { WamWord word, tag_mask; WamWord *adr, *fdv_adr; Range range; DEREF(x_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) { adr = UnTag_REF(word); fdv_adr = Pl_Fd_New_Bool_Variable(); Bind_UV(adr, Tag_REF(fdv_adr)); return TRUE; } if (tag_mask == TAG_INT_MASK) return (unsigned long) (UnTag_INT(word)) <= 1; if (tag_mask != TAG_FDV_MASK) Pl_Err_Type(pl_type_fd_variable, word); fdv_adr = UnTag_FDV(word); if (Min(fdv_adr) > 1) return FALSE; if (Max(fdv_adr) <= 1) return TRUE; /* here max > 1 */ if (Min(fdv_adr) == 1) return Pl_Fd_Unify_With_Integer0(fdv_adr, 1); /* here min == 0 */ if (!Pl_Range_Test_Value(Range(fdv_adr), 1)) return Pl_Fd_Unify_With_Integer0(fdv_adr, 0); /* Check Bool == X in 0..1 */ Pl_Fd_Before_Add_Cstr(); if (Is_Sparse(Range(fdv_adr))) { Range_Init_Interval(&range, 0, 1); if (!Pl_Fd_Tell_Range_Range(fdv_adr, &range)) return FALSE; } else if (!Pl_Fd_Tell_Interv_Interv(fdv_adr, 0, 1)) return FALSE; return Pl_Fd_After_Add_Cstr(); }
/*-------------------------------------------------------------------------* * PL_FD_BOOL_META_3 * * * *-------------------------------------------------------------------------*/ Bool Pl_Fd_Bool_Meta_3(WamWord le_word, WamWord re_word, WamWord op_word) { WamWord word, tag_mask; WamWord *adr, *fdv_adr; WamWord *exp; int op; static WamWord h[3]; /* static to avoid high address */ DEREF(op_word, word, tag_mask); op = UnTag_INT(op_word); h[0] = bool_tbl[op]; /* also works for NOT/1 */ h[1] = le_word; h[2] = re_word; sp = stack; vars_sp = vars_tbl; exp = Simplify(1, Tag_STC(h)); #ifdef DEBUG Display_Stack(exp); DBGPRINTF("\n"); #endif if (!Load_Bool_Into_Word(exp, 1, NULL)) return FALSE; while (--vars_sp >= vars_tbl) if (*vars_sp-- == 0) /* bool var */ { if (!Pl_Fd_Check_For_Bool_Var(*vars_sp)) return FALSE; } else /* FD var */ { DEREF(*vars_sp, word, tag_mask); if (tag_mask == TAG_REF_MASK) { adr = UnTag_REF(word); fdv_adr = Pl_Fd_New_Variable(); Bind_UV(adr, Tag_REF(fdv_adr)); } } return TRUE; }
/*-------------------------------------------------------------------------* * PL_FD_MIN_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Fd_Min_2(WamWord fdv_word, WamWord min_word) { WamWord word, tag_mask; int n; Fd_Deref_Check_Fd_Var(fdv_word, word, tag_mask); if (tag_mask == TAG_INT_MASK) n = UnTag_INT(word); else n = Min(UnTag_FDV(word)); return Pl_Un_Integer_Check(n, min_word); }
/*-------------------------------------------------------------------------* * PL_NUMBER_CHARS_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Number_Chars_2(WamWord number_word, WamWord chars_word) { WamWord word, tag_mask; WamWord *lst_adr, list_word; char *str = pl_glob_buff; int atom; list_word = chars_word; for (;;) { DEREF(list_word, word, tag_mask); if (word == NIL_WORD) break; if (tag_mask != TAG_LST_MASK) goto from_nb; lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); atom = UnTag_ATM(word); if (tag_mask != TAG_ATM_MASK || pl_atom_tbl[atom].prop.length != 1) goto from_nb; *str++ = pl_atom_tbl[atom].name[0]; list_word = Cdr(lst_adr); } *str = '\0'; return String_To_Number(pl_glob_buff, number_word); from_nb: DEREF(number_word, word, tag_mask); if (tag_mask == TAG_INT_MASK) { sprintf(pl_glob_buff, "%" PL_FMT_d, UnTag_INT(word)); return Pl_Un_Chars_Check(pl_glob_buff, chars_word); } if (tag_mask != TAG_REF_MASK) { str = Pl_Float_To_String(Pl_Rd_Number_Check(word)); return Pl_Un_Chars_Check(str, chars_word); } Pl_Rd_Chars_Check(chars_word); /* only to raise the correct error */ return FALSE; }
/*-------------------------------------------------------------------------* * PL_FD_DOM_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Fd_Dom_2(WamWord fdv_word, WamWord list_word) { WamWord word, tag_mask; WamWord *fdv_adr; int x, end; int vec_elem; Pl_Check_For_Un_List(list_word); Fd_Deref_Check_Fd_Var(fdv_word, word, tag_mask); if (tag_mask == TAG_INT_MASK) { x = UnTag_INT(word); if (!Pl_Get_List(list_word) || !Pl_Unify_Integer(x)) return FALSE; list_word = Pl_Unify_Variable(); } else { fdv_adr = UnTag_FDV(word); if (Is_Interval(Range(fdv_adr))) { end = Max(fdv_adr); for (x = Min(fdv_adr); x <= end; x++) { if (!Pl_Get_List(list_word) || !Pl_Unify_Integer(x)) return FALSE; list_word = Pl_Unify_Variable(); } } else { VECTOR_BEGIN_ENUM(Vec(fdv_adr), vec_elem); if (!Pl_Get_List(list_word) || !Pl_Unify_Integer(vec_elem)) return FALSE; list_word = Pl_Unify_Variable(); VECTOR_END_ENUM; } } return Pl_Get_Nil(list_word); }
/*-------------------------------------------------------------------------* * 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); }
/*-------------------------------------------------------------------------* * 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_NUMBER_ATOM_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Number_Atom_2(WamWord number_word, WamWord atom_word) { WamWord word, tag_mask; char *str; DEREF(atom_word, word, tag_mask); if (tag_mask == TAG_ATM_MASK) return String_To_Number(pl_atom_tbl[UnTag_ATM(word)].name, number_word); if (tag_mask != TAG_REF_MASK) Pl_Err_Type(pl_type_atom, word); DEREF(number_word, word, tag_mask); if (tag_mask == TAG_INT_MASK) { sprintf(pl_glob_buff, "%" PL_FMT_d, UnTag_INT(word)); return Pl_Un_String_Check(pl_glob_buff, atom_word); } str = Pl_Float_To_String(Pl_Rd_Number_Check(word)); return Pl_Un_String_Check(str, atom_word); }
/*-------------------------------------------------------------------------* * SHOW_TERM * * * *-------------------------------------------------------------------------*/ static void Show_Term(int depth, int prec, int context, WamWord term_word) { WamWord word, tag_mask; WamWord *adr; if (depth == 0) { Show_Atom(GENERAL_TERM, atom_dots); return; } DEREF(term_word, word, tag_mask); if (tag_mask != TAG_REF_MASK && Try_Portray(word)) return; switch (Tag_From_Tag_Mask(tag_mask)) { case REF: adr = UnTag_REF(word); if (Is_A_Local_Adr(adr)) { Globalize_Local_Unbound_Var(adr, word); adr = UnTag_REF(word); } Show_Global_Var(adr); break; case ATM: Show_Atom(context, UnTag_ATM(word)); break; #ifndef NO_USE_FD_SOLVER case FDV: Show_Fd_Variable(UnTag_FDV(word)); break; #endif case INT: Show_Integer(UnTag_INT(word)); break; case FLT: Show_Float(Pl_Obtain_Float(UnTag_FLT(word))); break; case LST: adr = UnTag_LST(word); if (ignore_op) { Out_String("'.'("); Show_Term(depth - 1, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, Car(adr)); Out_Char(','); Show_Term(depth - 1, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, Cdr(adr)); Out_Char(')'); } else { Out_Char('['); Show_List_Arg(depth, adr); Out_Char(']'); } break; case STC: adr = UnTag_STC(word); Show_Structure(depth, prec, context, adr); break; } }
WamWord FC Pl_Fct_Fast_Sign(WamWord x) { long vx = UnTag_INT(x); return (vx < 0) ? Tag_INT(-1) : (vx == 0) ? Tag_INT(0) : Tag_INT(1); }
WamWord FC Pl_Fct_Fast_Abs(WamWord x) { long vx = UnTag_INT(x); return (vx < 0) ? Tag_INT(-vx) : x; }
/*-------------------------------------------------------------------------* * SIMPLIFY * * * * This function returns the result of the simplified boolean expression * * given in e_word. NOT operators are only applied to variables. * * * * Input: * * sign : current sign of the boolean term (-1 (inside a ~) or +1) * * e_word: boolean term to simplify * * * * Output: * * The returned result is a pointer to a node of the following form: * * * * for binary boolean not operator (~): * * [1]: variable involved (tagged word) * * [0]: operator NOT * * * * for unary boolean operators (<=> ~<=> ==> ~==> /\ ~/\ \/ ~\/): * * [2]: right boolean exp (pointer to node) * * [1]: left boolean exp (pointer to node) * * [0]: operator (EQUIV, NEQUIV, IMPLY, NIMPLY, AND, NAND, OR, NOR) * * * * for boolean false value (0): * * [0]: ZERO * * * * for boolean true value (1): * * [0]: ONE * * * * for boolean variable: * * [0]: tagged word * * * * for binary math operators (= \= < >= > <=) (partial / full AC): * * [2]: right math exp (tagged word) * * [1]: left math exp (tagged word) * * [0]: operator (EQ, NEQ, LT, LTE, EQ_F, NEQ_F, LT_F, LTE_F) * * (GT, GTE, GT_F, and GTE_F becomes LT, LTE, LT_F and LTE_F) * * * * These nodes are stored in a hybrid stack. NB: XOR same as NEQUIV * *-------------------------------------------------------------------------*/ static WamWord * Simplify(int sign, WamWord e_word) { WamWord word, tag_mask; WamWord *adr; WamWord f_n, le_word, re_word; int op, n; WamWord *exp, *sp1; WamWord l, r; #ifdef DEBUG printf("ENTERING %5ld: %2d: ", sp - stack, sign); Pl_Write(e_word); printf("\n"); #endif exp = sp; if (sp - stack > BOOL_STACK_SIZE - 5) Pl_Err_Resource(pl_resource_too_big_fd_constraint); DEREF(e_word, word, tag_mask); if (tag_mask == TAG_REF_MASK || tag_mask == TAG_FDV_MASK) { adr = UnTag_Address(word); if (vars_sp - vars_tbl == VARS_STACK_SIZE) Pl_Err_Resource(pl_resource_too_big_fd_constraint); *vars_sp++ = word; *vars_sp++ = 0; /* bool var */ if (sign != 1) *sp++ = NOT; *sp++ = Tag_REF(adr); return exp; } if (tag_mask == TAG_INT_MASK) { n = UnTag_INT(word); if ((unsigned) n > 1) goto type_error; *sp++ = ZERO + ((sign == 1) ? n : 1 - n); return exp; } 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_bool_evaluable, word); } if (tag_mask != TAG_STC_MASK) goto type_error; adr = UnTag_STC(word); f_n = Functor_And_Arity(adr); if (bool_xor == f_n) op = NEQUIV; else { for (op = 0; op < NB_OF_OP; op++) if (bool_tbl[op] == f_n) break; if (op == NB_OF_OP) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(Functor(adr)); Pl_Unify_Integer(Arity(adr)); goto type_error; } } le_word = Arg(adr, 0); re_word = Arg(adr, 1); if (op == NOT) return Simplify(-sign, le_word); if (sign != 1) op = (op % 2 == EQ % 2) ? op + 1 : op - 1; if (op >= EQ && op <= LTE_F) { Add_Fd_Variables(le_word); Add_Fd_Variables(re_word); n = (op == GT || op == GT_F) ? op - 2 : (op == GTE || op == GTE_F) ? op + 2 : op; *sp++ = n; *sp++ = (n == op) ? le_word : re_word; *sp++ = (n == op) ? re_word : le_word; return exp; } sp += 3; exp[0] = op; exp[1] = (WamWord) Simplify(1, le_word); sp1 = sp; exp[2] = (WamWord) Simplify(1, re_word); l = *(WamWord *) (exp[1]); r = *(WamWord *) (exp[2]); /* NB: beware when calling below Simplify() (while has been just called above) * this can ran into stack overflow (N^2 space complexity). * Try to recover the stack before calling Simplify(). * Other stack recovery are less important (e.g. when only using exp[1]). * * In the following exp[] += sizeof(WamWord) is used to "skip" the NOT * in a simplification (points to the next cell). */ switch (op) { case EQUIV: if (l == ZERO) /* 0 <=> R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (l == ONE) /* 1 <=> R is R */ { return (WamWord *) exp[2]; } if (r == ZERO) /* L <=> 0 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (r == ONE) /* L <=> 1 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X <=> R is X <=> ~R */ { exp[1] += sizeof(WamWord); sp = sp1; exp[2] = (WamWord) Simplify(-1, re_word); break; } if (r == NOT) /* L <=> ~X is ~L <=> X */ { /* NB: cannot recover the stack */ exp[1] = (WamWord) Simplify(-1, le_word); exp[2] += sizeof(WamWord); break; } break; case NEQUIV: if (l == ZERO) /* 0 ~<=> R is R */ { return (WamWord *) exp[2]; } if (l == ONE) /* 1 ~<=> R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ZERO) /* L ~<=> 0 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (r == ONE) /* L ~<=> 1 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (l == NOT) /* ~X ~<=> R is X <=> R */ { exp[0] = EQUIV; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ~<=> ~X is L <=> X */ { exp[0] = EQUIV; exp[2] += sizeof(WamWord); break; } if (IsVar(l) && !IsVar(r)) /* X ~<=> R is X <=> ~R */ { exp[0] = EQUIV; sp = sp1; exp[2] = (WamWord) Simplify(-1, re_word); break; } if (IsVar(r) && !IsVar(l)) /* L ~<=> X is L <=> ~X */ { exp[0] = EQUIV; /* NB: cannot recover the stack */ exp[1] = (WamWord) Simplify(-1, le_word); break; } break; case IMPLY: if (l == ZERO || r == ONE) /* 0 ==> R is 1 , L ==> 1 is 1 */ { sp = exp; *sp++ = ONE; break; } if (l == ONE) /* 1 ==> R is R */ { return (WamWord *) exp[2]; } if (r == ZERO) /* L ==> 0 is ~L */ return sp = exp, Simplify(-1, le_word); if (l == NOT) /* ~X ==> R is X \/ R */ { exp[0] = OR; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ==> ~X is X ==> ~L */ { exp[1] = exp[2] + sizeof(WamWord); exp[2] = (WamWord) Simplify(-1, le_word); break; } break; case NIMPLY: if (l == ZERO || r == ONE) /* 0 ~==> R is 0 , L ~==> 1 is 0 */ { sp = exp; *sp++ = ZERO; break; } if (l == ONE) /* 1 ~==> R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ZERO) /* L ~==> 0 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X ~==> R is X ~\/ R */ { exp[0] = NOR; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ~==> ~X is L /\ X */ { exp[0] = AND; exp[2] += sizeof(WamWord); break; } break; case AND: if (l == ZERO || r == ZERO) /* 0 /\ R is 0 , L /\ 0 is 0 */ { sp = exp; *sp++ = ZERO; break; } if (l == ONE) /* 1 /\ R is R */ { return (WamWord *) exp[2]; } if (r == ONE) /* L /\ 1 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X /\ R is R ~==> X */ { exp[0] = NIMPLY; word = exp[1]; exp[1] = exp[2]; exp[2] = word + sizeof(WamWord); break; } if (r == NOT) /* L /\ ~X is L ~==> X */ { exp[0] = NIMPLY; exp[2] += sizeof(WamWord); break; } break; case NAND: if (l == ZERO || r == ZERO) /* 0 ~/\ R is 1 , L ~/\ 0 is 1 */ { sp = exp; *sp++ = ONE; break; } if (l == ONE) /* 1 ~/\ R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ONE) /* L ~/\ 1 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (l == NOT) /* ~X ~/\ R is R ==> X */ { exp[0] = IMPLY; word = exp[1]; exp[1] = exp[2]; exp[2] = word + sizeof(WamWord); break; } if (r == NOT) /* L ~/\ ~X is L ==> X */ { exp[0] = IMPLY; exp[2] += sizeof(WamWord); break; } break; case OR: if (l == ONE || r == ONE) /* 1 \/ R is 1 , L \/ 1 is 1 */ { sp = exp; *sp++ = ONE; break; } if (l == ZERO) /* 0 \/ R is R */ { return (WamWord *) exp[2]; } if (r == ZERO) /* L \/ 0 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X \/ R is X ==> R */ { exp[0] = IMPLY; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L \/ ~X is X ==> L */ { exp[0] = IMPLY; word = exp[1]; exp[1] = exp[2] + sizeof(WamWord); exp[2] = word; break; } break; case NOR: if (l == ONE || r == ONE) /* 1 ~\/ R is 0 , L ~\/ 1 is 0 */ { sp = exp; *sp++ = ZERO; break; } if (l == ZERO) /* 0 ~\/ R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ZERO) /* L ~\/ 0 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (l == NOT) /* ~X ~\/ R is X ~==> R */ { exp[0] = NIMPLY; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ~\/ ~X is X ~==> L */ { exp[0] = NIMPLY; word = exp[1]; exp[1] = exp[2] + sizeof(WamWord); exp[2] = word; break; } break; } return exp; }
WamWord FC Pl_Fct_Fast_Not(WamWord x) { long vx = UnTag_INT(x); return Tag_INT(~vx); }
WamWord FC Pl_Fct_Fast_Dec(WamWord x) { long vx = UnTag_INT(x); return Tag_INT(vx - 1); }
WamWord FC Pl_Fct_Fast_Inc(WamWord x) { long vx = UnTag_INT(x); return Tag_INT(vx + 1); }
WamWord FC Pl_Fct_Fast_Neg(WamWord x) { long vx = UnTag_INT(x); return Tag_INT(-vx); }
static void Show_List_Arg(int depth, WamWord *lst_adr) { WamWord word, tag_mask; terminal_rec: depth--; Show_Term(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, Car(lst_adr)); if (depth == 0) /* dots already written by Show_Term */ return; DEREF(Cdr(lst_adr), word, tag_mask); switch (Tag_From_Tag_Mask(tag_mask)) { case REF: SHOW_LIST_PIPE; Show_Global_Var(UnTag_REF(word)); break; case ATM: if (word != NIL_WORD) { SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Atom(GENERAL_TERM, UnTag_ATM(word)); } break; #ifndef NO_USE_FD_SOLVER case FDV: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Fd_Variable(UnTag_FDV(word)); break; #endif case INT: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Integer(UnTag_INT(word)); break; case FLT: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Float(Pl_Obtain_Float(UnTag_FLT(word))); break; case LST: Out_Char(','); if (space_args) Out_Space(); lst_adr = UnTag_LST(word); goto terminal_rec; break; case STC: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Structure(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, UnTag_STC(word)); break; } }
/*-------------------------------------------------------------------------* * SHOW_STRUCTURE * * * *-------------------------------------------------------------------------*/ static void Show_Structure(int depth, int prec, int context, WamWord *stc_adr) { WamWord word, tag_mask; WamWord *adr; WamWord f_n = Functor_And_Arity(stc_adr); int functor = Functor(stc_adr); int arity = Arity(stc_adr); OperInf *oper; int nb_args_to_disp; int i, j, n; char str[32]; Bool bracket; Bool surround_space; char *p; depth--; if (name_vars && f_n == dollar_varname_1 && stc_adr >= name_number_above_H) { DEREF(Arg(stc_adr, 0), word, tag_mask); if (tag_mask == TAG_ATM_MASK) { p = pl_atom_tbl[UnTag_ATM(word)].name; if (Is_Valid_Var_Name(p)) { Out_String(p); pl_last_writing = W_IDENTIFIER; return; } } } if (number_vars && f_n == dollar_var_1 && stc_adr >= name_number_above_H) { DEREF(Arg(stc_adr, 0), word, tag_mask); if (tag_mask == TAG_INT_MASK && (n = UnTag_INT(word)) >= 0) { i = n % 26; j = n / 26; Out_Char('A' + i); if (j) { sprintf(str, "%d", j); Out_String(str); } pl_last_writing = W_IDENTIFIER; return; } } if (ignore_op || arity > 2) goto functional; if (f_n == curly_brackets_1) { Out_Char('{'); if (space_args) Out_Space(); Show_Term(depth, MAX_PREC, GENERAL_TERM, Arg(stc_adr, 0)); if (space_args) Out_Space(); Out_Char('}'); return; } bracket = FALSE; if (arity == 1 && (oper = Pl_Lookup_Oper(functor, PREFIX))) { #if 1 /* Koen de Bosschere says "in case of ambiguity : */ /* select the associative operator over the nonassociative */ /* select prefix over postfix". */ OperInf *oper1; if (oper->prec > oper->right && (oper1 = Pl_Lookup_Oper(functor, POSTFIX)) && oper1->left == oper1->prec) { oper = oper1; goto postfix; } #endif if (oper->prec > prec || (context == INSIDE_LEFT_ASSOC_OP && (oper->prec == oper->right && oper->prec == prec))) { /* prevent also the case: fy T yf(x) */ Out_Char('('); bracket = TRUE; } Show_Atom(GENERAL_TERM, functor); last_prefix_op = W_PREFIX_OP_ANY; if (space_args #if SPACE_ARGS_RESTRICTED /* space_args -> space after fx operator */ && oper->prec > oper->right #endif ) Out_Space(); else if (strcmp(pl_atom_tbl[functor].name, "-") == 0) { last_prefix_op = W_PREFIX_OP_MINUS; p_bracket_minus = &bracket; } Show_Term(depth, oper->right, INSIDE_ANY_OP, Arg(stc_adr, 0)); last_prefix_op = W_NO_PREFIX_OP; /* Here we need a while(bracket--) instead of if(bracket) because * in some cases with the minus op and additional bracket is needed. * Example: with op(100, xfx, &) (recall the prec of - is 200). * The term ((-(1)) & b must be displayed as: (- (1)) & b * Concerning the sub-term - (1), the first ( is emitted 10 lines above * because the precedence of - (200) is > precedence of & (100). * The second ( is emitted by Need_Space() because the argument of - begins * by a digit. At the return we have to close 2 ). */ while (bracket--) Out_Char(')'); return; } if (arity == 1 && (oper = Pl_Lookup_Oper(functor, POSTFIX))) { postfix: if (oper->prec > prec) { Out_Char('('); bracket = TRUE; } context = (oper->left == oper->prec) ? INSIDE_LEFT_ASSOC_OP : INSIDE_ANY_OP; Show_Term(depth, oper->left, context, Arg(stc_adr, 0)); if (space_args #if SPACE_ARGS_RESTRICTED /* space_args -> space before xf operator */ && oper->prec > oper->left #endif ) Out_Space(); Show_Atom(GENERAL_TERM, functor); if (bracket) Out_Char(')'); return; } if (arity == 2 && (oper = Pl_Lookup_Oper(functor, INFIX))) { if (oper->prec > prec || (context == INSIDE_LEFT_ASSOC_OP && (oper->prec == oper->right && oper->prec == prec))) { /* prevent also the case: T xfy U yf(x) */ Out_Char('('); bracket = TRUE; } context = (oper->left == oper->prec) ? INSIDE_LEFT_ASSOC_OP : INSIDE_ANY_OP; Show_Term(depth, oper->left, context, Arg(stc_adr, 0)); #if 1 /* to show | unquoted if it is an infix operator with prec > 1000 */ if (functor == ATOM_CHAR('|') && oper->prec > 1000) { if (space_args) Out_Space(); Out_Char('|'); if (space_args) Out_Space(); } else #endif if (functor == ATOM_CHAR(',')) { Out_Char(','); if (space_args) Out_Space(); } else { surround_space = FALSE; if (pl_atom_tbl[functor].prop.type == IDENTIFIER_ATOM || pl_atom_tbl[functor].prop.type == OTHER_ATOM || (space_args #ifdef SPACE_ARGS_RESTRICTED /* space_args -> space around xfx operators */ && oper->left != oper->prec && oper->right != oper->prec #endif )) { surround_space = TRUE; Out_Space(); } Show_Atom(GENERAL_TERM, functor); if (surround_space) Out_Space(); } Show_Term(depth, oper->right, INSIDE_ANY_OP, Arg(stc_adr, 1)); if (bracket) Out_Char(')'); return; } functional: /* functional notation */ Show_Atom(GENERAL_TERM, functor); Out_Char('('); nb_args_to_disp = i = (arity < depth + 1 || depth < 0) ? arity : depth + 1; adr = &Arg(stc_adr, 0); goto start_display; do { Out_Char(','); if (space_args) Out_Space(); start_display: Show_Term(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, *adr++); } while (--i); if (arity != nb_args_to_disp) { Out_Char(','); if (space_args) Out_Space(); Show_Atom(GENERAL_TERM, atom_dots); } Out_Char(')'); }
/*-------------------------------------------------------------------------* * TO_DOUBLE * * * *-------------------------------------------------------------------------*/ static double To_Double(WamWord x) { return (Tag_Is_INT(x)) ? (double) (UnTag_INT(x)) : Pl_Obtain_Float(UnTag_FLT(x)); }