/*-------------------------------------------------------------------------* * PL_FORMAT_3 * * * *-------------------------------------------------------------------------*/ void Pl_Format_3(WamWord sora_word, WamWord format_word, WamWord args_word) { WamWord word, tag_mask; int stm; StmInf *pstm; char *str; char buff[2048]; stm = (sora_word == NOT_A_WAM_WORD) ? pl_stm_output : Pl_Get_Stream_Or_Alias(sora_word, STREAM_CHECK_OUTPUT); pstm = pl_stm_tbl[stm]; pl_last_output_sora = sora_word; Pl_Check_Stream_Type(stm, TRUE, FALSE); DEREF(format_word, word, tag_mask); if (tag_mask == TAG_ATM_MASK && word != NIL_WORD) str = pl_atom_tbl[UnTag_ATM(word)].name; else { strcpy(buff, Pl_Rd_Codes_Check(format_word)); str = buff; } Format(pl_stm_tbl[stm], str, &args_word); }
/*-------------------------------------------------------------------------* * 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_IS_VALID_VAR_NAME_1 * * * *-------------------------------------------------------------------------*/ Bool Pl_Is_Valid_Var_Name_1(WamWord name_word) { WamWord word, tag_mask; DEREF(name_word, word, tag_mask); return (tag_mask == TAG_ATM_MASK) && Is_Valid_Var_Name(pl_atom_tbl[UnTag_ATM(word)].name); }
/*-------------------------------------------------------------------------* * 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_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_ATOM_PROPERTY_6 * * * *-------------------------------------------------------------------------*/ void Pl_Atom_Property_6(WamWord atom_word, WamWord prefix_op_word, WamWord infix_op_word, WamWord postfix_op_word, WamWord needs_quote_word, WamWord needs_scan_word) { WamWord word, tag_mask; int atom; DEREF(atom_word, word, tag_mask); atom = UnTag_ATM(word); Pl_Get_Integer(Check_Oper(atom, PREFIX) != 0, prefix_op_word); Pl_Get_Integer(Check_Oper(atom, INFIX) != 0, infix_op_word); Pl_Get_Integer(Check_Oper(atom, POSTFIX) != 0, postfix_op_word); Pl_Get_Integer(pl_atom_tbl[atom].prop.needs_quote, needs_quote_word); Pl_Get_Integer(pl_atom_tbl[atom].prop.needs_scan, needs_scan_word); }
/*-------------------------------------------------------------------------* * 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_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(')'); }
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_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; } }
/*-------------------------------------------------------------------------* * PL_SUB_ATOM_5 * * * *-------------------------------------------------------------------------*/ Bool Pl_Sub_Atom_5(WamWord atom_word, WamWord before_word, WamWord length_word, WamWord after_word, WamWord sub_atom_word) { WamWord word, tag_mask; AtomInf *patom; AtomInf *psub_atom = NULL; /* only for the compiler */ int length; PlLong b, l, a; int b1, l1, a1; Bool nondet; int mask = 0; char *str; patom = pl_atom_tbl + Pl_Rd_Atom_Check(atom_word); length = patom->prop.length; DEREF_LG(before_word, b); DEREF_LG(length_word, l); DEREF_LG(after_word, a); DEREF(sub_atom_word, word, tag_mask); if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK) Pl_Err_Type(pl_type_atom, word); sub_atom_word = word; if (tag_mask == TAG_ATM_MASK) { psub_atom = pl_atom_tbl + UnTag_ATM(word); l = psub_atom->prop.length; if (!Pl_Get_Integer(l, length_word)) return FALSE; if ((mask & 5) == 5 && length != b + l + a) /* B and A fixed */ return FALSE; if (mask & 4) /* B fixed */ { a = length - b - l; return strncmp(patom->name + b, psub_atom->name, l) == 0 && Pl_Get_Integer(a, after_word); } if (mask & 1) /* A fixed */ { b = length - l - a; return strncmp(patom->name + b, psub_atom->name, l) == 0 && Pl_Get_Integer(b, before_word); } mask = 8; /* set sub_atom as fixed */ } switch (mask) /* mask <= 7, B L A (1: fixed, 0: var) */ { case 0: /* nothing fixed */ case 2: /* L fixed */ case 4: /* B fixed */ a = length - b - l; nondet = TRUE; break; case 1: /* A fixed */ l = length - b - a; nondet = TRUE; break; case 3: /* L A fixed */ b = length - l - a; nondet = FALSE; break; case 5: /* B A fixed */ l = length - b - a; nondet = FALSE; break; case 6: /* B L fixed */ case 7: /* B L A fixed */ a = length - b - l; nondet = FALSE; break; default: /* sub_atom fixed */ if ((str = strstr(patom->name + b, psub_atom->name)) == NULL) return FALSE; b = str - patom->name; a = length - b - l; nondet = TRUE; break; } if (b < 0 || l < 0 || a < 0) return FALSE; if (nondet && Compute_Next_BLA(mask, patom, psub_atom, b, l, a, &b1, &l1, &a1)) { /* non deterministic case */ A(0) = before_word; A(1) = length_word; A(2) = after_word; A(3) = sub_atom_word; A(4) = (WamWord) patom; A(5) = (WamWord) psub_atom; A(6) = mask; A(7) = b1; A(8) = l1; A(9) = a1; Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(SUB_ATOM_ALT, 0), 10); } if (mask <= 7) { MALLOC_STR(l); strncpy(str, patom->name + b, l); str[l] = '\0'; Pl_Get_Atom(Create_Malloc_Atom(str), sub_atom_word); Pl_Get_Integer(l, length_word); } return Pl_Get_Integer(b, before_word) && Pl_Get_Integer(a, after_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); }
/*-------------------------------------------------------------------------* * PL_TERM_COMPARE * * * *-------------------------------------------------------------------------*/ long Pl_Term_Compare(WamWord start_u_word, WamWord start_v_word) { WamWord u_word, u_tag_mask; WamWord v_word, v_tag_mask; WamWord u_tag, v_tag; int u_func, u_arity; WamWord *u_arg_adr; int v_func, v_arity; WamWord *v_arg_adr; int i, x; double d1, d2; DEREF(start_u_word, u_word, u_tag_mask); DEREF(start_v_word, v_word, v_tag_mask); u_tag = Tag_From_Tag_Mask(u_tag_mask); v_tag = Tag_From_Tag_Mask(v_tag_mask); switch (u_tag) { case REF: return (v_tag != REF) ? -1 : UnTag_REF(u_word) - UnTag_REF(v_word); #ifndef NO_USE_FD_SOLVER case FDV: if (v_tag == REF) return 1; return (v_tag != FDV) ? -1 : UnTag_FDV(u_word) - UnTag_FDV(v_word); #endif case FLT: if (v_tag == REF #ifndef NO_USE_FD_SOLVER || v_tag == FDV #endif ) return 1; if (v_tag != FLT) return -1; d1 = Pl_Obtain_Float(UnTag_FLT(u_word)); d2 = Pl_Obtain_Float(UnTag_FLT(v_word)); return (d1 < d2) ? -1 : (d1 == d2) ? 0 : 1; case INT: if (v_tag == REF || #ifndef NO_USE_FD_SOLVER v_tag == FDV || #endif v_tag == FLT) return 1; return (v_tag != INT) ? -1 : UnTag_INT(u_word) - UnTag_INT(v_word); case ATM: if (v_tag == REF || #ifndef NO_USE_FD_SOLVER v_tag == FDV || #endif v_tag == FLT || v_tag == INT) return 1; return (v_tag != ATM) ? -1 : strcmp(pl_atom_tbl[UnTag_ATM(u_word)].name, pl_atom_tbl[UnTag_ATM(v_word)].name); } /* u_tag == LST / STC */ v_arg_adr = Pl_Rd_Compound(v_word, &v_func, &v_arity); if (v_arg_adr == NULL) /* v_tag != LST / STC */ return 1; u_arg_adr = Pl_Rd_Compound(u_word, &u_func, &u_arity); if (u_arity != v_arity) return u_arity - v_arity; if (u_func != v_func) return strcmp(pl_atom_tbl[u_func].name, pl_atom_tbl[v_func].name); for (i = 0; i < u_arity; i++) if ((x = Pl_Term_Compare(*u_arg_adr++, *v_arg_adr++)) != 0) return x; return 0; }