/*-------------------------------------------------------------------------* * 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; }
/*-------------------------------------------------------------------------* * BOUND_VAR * * * *-------------------------------------------------------------------------*/ static void Bound_Var(WamWord *adr) { long *p; for (p = pl_glob_dico_var; p < bound_var_ptr; p++) if (*p == (long) adr) return; if (bound_var_ptr - pl_glob_dico_var >= MAX_VAR_IN_TERM) Pl_Err_Representation(pl_representation_too_many_variables); *bound_var_ptr++ = (long) adr; }
/*-------------------------------------------------------------------------* * COLLECT_VARIABLE * * * *-------------------------------------------------------------------------*/ static Bool Collect_Variable(WamWord *adr) { PlLong *p; for (p = pl_glob_dico_var; p < var_ptr; p++) if (*p == (PlLong) adr) /* already present */ return TRUE; if (var_ptr - pl_glob_dico_var >= MAX_VAR_IN_TERM) Pl_Err_Representation(pl_representation_too_many_variables); *var_ptr++ = (PlLong) adr; return TRUE; }
/*-------------------------------------------------------------------------* * LINK_KEY_VAR * * * *-------------------------------------------------------------------------*/ static void Link_Key_Var(WamWord *adr) { long *p; for (p = pl_glob_dico_var; p < key_var_ptr; p++) if (*p == (long) adr) return; if (next_key_var_ptr < save_key_var_ptr) { /* same as Pl_Unify(Tag_REF(adr), *next_key_var_ptr++) */ *adr = *(WamWord *) (*next_key_var_ptr); next_key_var_ptr++; return; } if (key_var_ptr - pl_glob_dico_var >= MAX_VAR_IN_TERM) Pl_Err_Representation(pl_representation_too_many_variables); *key_var_ptr++ = (long) adr; }
/*-------------------------------------------------------------------------* * 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); }
/*-------------------------------------------------------------------------* * COPY_TERM_REC * * * * p is the next address to use to store the rest of a term. * *-------------------------------------------------------------------------*/ static void Copy_Term_Rec(WamWord *dst_adr, WamWord *src_adr, WamWord **p) { WamWord word, tag_mask; WamWord *adr; WamWord *q; int i; terminal_rec: DEREF(*src_adr, word, tag_mask); switch (Tag_From_Tag_Mask(tag_mask)) { case REF: adr = UnTag_REF(word); q = *p; if (adr < q && adr >= base_copy) /* already a copy */ { *dst_adr = word; return; } if (top_vars >= end_vars) Pl_Err_Representation(pl_representation_too_many_variables); *top_vars++ = word; /* word to restore */ *top_vars++ = (WamWord) adr; /* address to restore */ *adr = *dst_adr = Tag_REF(dst_adr); /* bind to a new copy */ return; #ifndef NO_USE_FD_SOLVER case FDV: adr = UnTag_FDV(word); q = *p; if (adr < q && adr >= base_copy) /* already a copy */ { *dst_adr = Tag_REF(adr); /* since Dont_Separate_Tag */ return; } if (top_vars >= end_vars) Pl_Err_Representation(pl_representation_too_many_variables); *top_vars++ = word; /* word to restore */ *top_vars++ = (WamWord) adr; /* address to restore */ q = *p; *p = q + Fd_Copy_Variable(q, adr); *adr = *dst_adr = Tag_REF(q); /* bind to a new copy */ return; #endif case FLT: adr = UnTag_FLT(word); q = *p; q[0] = adr[0]; #if WORD_SIZE == 32 q[1] = adr[1]; *p = q + 2; #else *p = q + 1; #endif *dst_adr = Tag_FLT(q); return; case LST: adr = UnTag_LST(word); q = *p; *dst_adr = Tag_LST(q); *p = &Cdr(q) + 1; q = &Car(q); adr = &Car(adr); Copy_Term_Rec(q++, adr++, p); dst_adr = q; src_adr = adr; goto terminal_rec; case STC: adr = UnTag_STC(word); q = *p; *dst_adr = Tag_STC(q); Functor_And_Arity(q) = Functor_And_Arity(adr); i = Arity(adr); *p = &Arg(q, i - 1) + 1; q = &Arg(q, 0); adr = &Arg(adr, 0); while (--i) Copy_Term_Rec(q++, adr++, p); dst_adr = q; src_adr = adr; goto terminal_rec; default: *dst_adr = word; return; } }