/*-------------------------------------------------------------------------* * PL_BLT_COMPARE * * * *-------------------------------------------------------------------------*/ Bool FC Pl_Blt_Compare(WamWord cmp_word, WamWord x, WamWord y) { int cmp; char c; Bool res; Pl_Set_C_Bip_Name("compare", 3); cmp = Pl_Term_Compare(x, y); c = (cmp < 0) ? '<' : (cmp == 0) ? '=' : '>'; res = Pl_Un_Atom_Check(ATOM_CHAR(c), cmp_word); if (!res) /* check if it is one of < = > */ { WamWord word, tag_mask; char *s; DEREF(cmp_word, word, tag_mask); /* we know it is an atom */ s = pl_atom_tbl[UnTag_ATM(word)].name; if ((s[0] != '<' && s[0] != '=' && s[0] != '>') || s[1] != '\0') Pl_Err_Domain(pl_domain_order, cmp_word); } Pl_Unset_C_Bip_Name(); return res; }
/*-------------------------------------------------------------------------* * 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_BLT_COMPARE * * * *-------------------------------------------------------------------------*/ Bool FC Pl_Blt_Compare(WamWord cmp_word, WamWord x, WamWord y) { int cmp; char c; Bool res; Pl_Set_C_Bip_Name("compare", 3); cmp = Pl_Term_Compare(x, y); c = (cmp < 0) ? '<' : (cmp == 0) ? '=' : '>'; res = Pl_Un_Atom_Check(ATOM_CHAR(c), cmp_word); Pl_Unset_C_Bip_Name(); return res; }
/*-------------------------------------------------------------------------* * MATH_SUPP_INITIALIZER * * * *-------------------------------------------------------------------------*/ static void Math_Supp_Initializer(void) { arith_tbl[PLUS_1] = Functor_Arity(ATOM_CHAR('+'), 1); arith_tbl[PLUS_2] = Functor_Arity(ATOM_CHAR('+'), 2); arith_tbl[MINUS_1] = Functor_Arity(ATOM_CHAR('-'), 1); arith_tbl[MINUS_2] = Functor_Arity(ATOM_CHAR('-'), 2); arith_tbl[TIMES_2] = Functor_Arity(ATOM_CHAR('*'), 2); arith_tbl[POWER_2] = Functor_Arity(Pl_Create_Atom("**"), 2); arith_tbl[DIV_2] = Functor_Arity(ATOM_CHAR('/'), 2); arith_tbl[MIN_2] = Functor_Arity(Pl_Create_Atom("min"), 2); arith_tbl[MAX_2] = Functor_Arity(Pl_Create_Atom("max"), 2); arith_tbl[DIST_2] = Functor_Arity(Pl_Create_Atom("dist"), 2); arith_tbl[QUOT_2] = Functor_Arity(Pl_Create_Atom("//"), 2); arith_tbl[REM_2] = Functor_Arity(Pl_Create_Atom("rem"), 2); arith_tbl[QUOT_REM_3] = Functor_Arity(Pl_Create_Atom("quot_rem"), 3); }
/*-------------------------------------------------------------------------* * PL_FREE_VARIABLES_4 * * * * Fail if no free variables. * *-------------------------------------------------------------------------*/ Bool Pl_Free_Variables_4(WamWord templ_word, WamWord gen_word, WamWord gen1_word, WamWord key_word) { WamWord gl_key_word; WamWord *save_H, *arg; int nb_free_var = 0; bound_var_ptr = pl_glob_dico_var; /* pl_glob_dico_var: stores bound vars */ Pl_Treat_Vars_Of_Term(templ_word, TRUE, Bound_Var); new_gen_word = Existential_Variables(gen_word); save_H = H++; /* one more word for f/n is possible */ arg = free_var_base = H; /* array is in the heap */ Pl_Treat_Vars_Of_Term(new_gen_word, TRUE, Free_Var); nb_free_var = H - arg; if (nb_free_var == 0) return FALSE; if (nb_free_var <= MAX_ARITY) { *save_H = Functor_Arity(ATOM_CHAR('.'), nb_free_var); gl_key_word = Tag_STC(save_H); } else { H = free_var_base; gl_key_word = Pl_Mk_Proper_List(nb_free_var, arg); } Pl_Unify(new_gen_word, gen1_word); return Pl_Unify(gl_key_word, key_word); }
/*-------------------------------------------------------------------------* * 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(')'); }
/*-------------------------------------------------------------------------* * 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; }
/*-------------------------------------------------------------------------* * ALL_SOLUT_INITIALIZER * * * *-------------------------------------------------------------------------*/ static void All_Solut_Initializer(void) { exist_2 = Functor_Arity(ATOM_CHAR('^'), 2); }
/*-------------------------------------------------------------------------* * 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; }
/*-------------------------------------------------------------------------* * FORMAT * * * *-------------------------------------------------------------------------*/ static void Format(StmInf *pstm, char *format, WamWord *lst_adr) #define IMPOSS -12345678 { WamWord word; Bool has_n; long generic; long n, n1; char *p; long x; double d; int lg, stop; int i, k; char *format_stack[256]; char **top_stack = format_stack; char buff[2048]; *top_stack++ = format; do { format = *--top_stack; while (*format) { if (*format == '%') /* C printf format */ { if (format[1] == '%') { Pl_Stream_Putc('%', pstm); format += 2; continue; } p = buff; n = n1 = IMPOSS; do if ((*p++ = *format++) == '*') { if (n == IMPOSS) n = Arg_Integer(&lst_adr); else n1 = Arg_Integer(&lst_adr); } while ((char *) strchr("diouxXpnceEfgGs", p[-1]) == NULL); *p = '\0'; if (strchr("eEfgG", p[-1]) == NULL) { generic = (p[-1] == 's') ? (long) Arg_Atom(&lst_adr) : Arg_Integer(&lst_adr); if (n != IMPOSS) { if (n1 != IMPOSS) Pl_Stream_Printf(pstm, buff, n, n1, generic); else Pl_Stream_Printf(pstm, buff, n, generic); } else Pl_Stream_Printf(pstm, buff, generic); } else { d = Arg_Float(&lst_adr); if (n != IMPOSS) { if (n1 != IMPOSS) Pl_Stream_Printf(pstm, buff, n, n1, d); else Pl_Stream_Printf(pstm, buff, n, d); } else Pl_Stream_Printf(pstm, buff, d); } continue; } if (*format != '~') { Pl_Stream_Putc(*format, pstm); format++; continue; } if (*++format == '*') { n = Arg_Integer(&lst_adr); format++; has_n = TRUE; } else { p = format; n = strtol(format, &format, 10); has_n = (format != p); } switch (*format) { case 'a': p = Arg_Atom(&lst_adr); if (has_n) Pl_Stream_Printf(pstm, "%*s", -n, p); else Pl_Stream_Puts(p, pstm); break; case 'c': x = Arg_Integer(&lst_adr); if (!Is_Valid_Code(x)) Pl_Err_Representation(pl_representation_character_code); do Pl_Stream_Putc(x, pstm); while (--n > 0); break; case 'e': case 'E': case 'f': case 'g': case 'G': x = *format; d = Arg_Float(&lst_adr); if (has_n) sprintf(buff, "%%.%ld%c", n, (char) x); else sprintf(buff, "%%%c", (char) x); Pl_Stream_Printf(pstm, buff, d); break; case 'd': case 'D': x = Arg_Integer(&lst_adr); if (n == 0 && *format == 'd') { Pl_Stream_Printf(pstm, "%ld", x); break; } if (x < 0) { Pl_Stream_Putc('-', pstm); x = -x; } sprintf(buff, "%ld", x); lg = strlen(buff) - n; if (lg <= 0) { Pl_Stream_Puts("0.", pstm); for (i = 0; i < -lg; i++) Pl_Stream_Putc('0', pstm); Pl_Stream_Printf(pstm, "%ld", x); break; } stop = (*format == 'D') ? lg % 3 : -1; if (stop == 0) stop = 3; for (p = buff, i = 0; *p; p++, i++) { if (i == lg) Pl_Stream_Putc('.', pstm), stop = -1; if (i == stop) Pl_Stream_Putc(',', pstm), stop += 3; Pl_Stream_Putc(*p, pstm); } break; case 'r': case 'R': x = Arg_Integer(&lst_adr); if (!has_n || n < 2 || n > 36) n = 8; k = ((*format == 'r') ? 'a' : 'A') - 10; if (x < 0) { Pl_Stream_Putc('-', pstm); x = -x; } p = buff + sizeof(buff) - 1; *p = '\0'; do { i = x % n; x = x / n; --p; *p = (i < 10) ? i + '0' : i + k; } while (x); Pl_Stream_Puts(p, pstm); break; case 's': case 'S': word = Read_Arg(&lst_adr); if (*format == 's') p = Pl_Rd_Codes_Check(word); else p = Pl_Rd_Chars_Check(word); if (has_n) Pl_Stream_Printf(pstm, "%-*.*s", n, n, p); else Pl_Stream_Printf(pstm, "%s", p); break; case 'i': do Read_Arg(&lst_adr); while (--n > 0); break; case 'k': word = Read_Arg(&lst_adr); Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_IGNORE_OP | WRITE_QUOTED, word); break; case 'q': word = Read_Arg(&lst_adr); Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS | WRITE_NAME_VARS | WRITE_QUOTED, word); break; case 'p': /* only work if print.pl is linked */ word = Read_Arg(&lst_adr); Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS | WRITE_NAME_VARS | WRITE_PORTRAYED, word); break; case 'w': word = Read_Arg(&lst_adr); Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS | WRITE_NAME_VARS, word); break; case '~': Pl_Stream_Putc('~', pstm); break; case 'N': if (pstm->line_pos == 0) break; case 'n': do Pl_Stream_Putc('\n', pstm); while (--n > 0); break; case '?': if (format[1]) *top_stack++ = format + 1; format = Arg_Atom(&lst_adr); continue; default: Pl_Err_Domain(pl_domain_format_control_sequence, Tag_ATM(ATOM_CHAR(*format))); } format++; } } while (top_stack > format_stack); }
/*-------------------------------------------------------------------------* * 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; }
/*-------------------------------------------------------------------------* * 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_ATOM_CHAR * * * *-------------------------------------------------------------------------*/ int Pl_Atom_Char(char c) { return ATOM_CHAR(c); }