/*-------------------------------------------------------------------------* * PL_FD_MATH_UNIFY_X_Y * * * *-------------------------------------------------------------------------*/ Bool Pl_Fd_Math_Unify_X_Y(WamWord x, WamWord y) { WamWord x_word, x_tag; WamWord y_word, y_tag; DEREF(x, x_word, x_tag); DEREF(y, y_word, y_tag); if (x_tag == TAG_FDV_MASK && y_tag == TAG_FDV_MASK) { MATH_CSTR_2(pl_x_eq_y, x, y); return TRUE; } #ifdef DEBUG DBGPRINTF("Prolog Unif: "); Pl_Write_1(x_word); DBGPRINTF(" = "); Pl_Write_1(y_word); DBGPRINTF("\n"); #endif return Pl_Unify(x_word, y_word); }
void layout_deep_copy(MessageLayout* layout, void* to, void* from) { upb_msg_field_iter it; for (upb_msg_field_begin(&it, layout->msgdef); !upb_msg_field_done(&it); upb_msg_field_next(&it)) { const upb_fielddef* field = upb_msg_iter_field(&it); void* to_memory = slot_memory(layout, to, field); uint32_t* to_oneof_case = slot_oneof_case(layout, to, field); void* from_memory = slot_memory(layout, from, field); uint32_t* from_oneof_case = slot_oneof_case(layout, from, field); if (upb_fielddef_containingoneof(field)) { if (*from_oneof_case == upb_fielddef_number(field)) { *to_oneof_case = *from_oneof_case; native_slot_deep_copy(upb_fielddef_type(field), to_memory, from_memory); } } else if (is_map_field(field)) { DEREF(to_memory, VALUE) = Map_deep_copy(DEREF(from_memory, VALUE)); } else if (upb_fielddef_label(field) == UPB_LABEL_REPEATED) { DEREF(to_memory, VALUE) = RepeatedField_deep_copy(DEREF(from_memory, VALUE)); } else { if (field_contains_hasbit(layout, field)) { if (!slot_is_hasbit_set(layout, from, field)) continue; slot_set_hasbit(layout, to, field); } native_slot_deep_copy(upb_fielddef_type(field), to_memory, from_memory); } } }
// Handler for a submessage field in a oneof. static void *oneofsubmsg_handler(void *closure, const void *hd) { MessageHeader* msg = closure; const oneof_handlerdata_t *oneofdata = hd; uint32_t oldcase = DEREF(msg, oneofdata->case_ofs, uint32_t); VALUE subdesc = get_def_obj((void*)oneofdata->md); VALUE subklass = Descriptor_msgclass(subdesc); VALUE submsg_rb; MessageHeader* submsg; if (oldcase != oneofdata->oneof_case_num || DEREF(msg, oneofdata->ofs, VALUE) == Qnil) { DEREF(msg, oneofdata->ofs, VALUE) = rb_class_new_instance(0, NULL, subklass); } // Set the oneof case *after* allocating the new class instance -- otherwise, // if the Ruby GC is invoked as part of a call into the VM, it might invoke // our mark routines, and our mark routines might see the case value // indicating a VALUE is present and expect a valid VALUE. See comment in // layout_set() for more detail: basically, the change to the value and the // case must be atomic w.r.t. the Ruby VM. DEREF(msg, oneofdata->case_ofs, uint32_t) = oneofdata->oneof_case_num; submsg_rb = DEREF(msg, oneofdata->ofs, VALUE); TypedData_Get_Struct(submsg_rb, MessageHeader, &Message_type, submsg); return submsg; }
void insertIntoComplexRe(char ** complexRe, int where, int * len, char * toInsert) { char * buf; int insertLen = strlen(toInsert); int i = where; /* enough space for complexRe+the new range */ *len = *len+(insertLen+1); *complexRe = (char*)realloc(*complexRe, *len); /* buffer the rest */ buf = (char*)malloc(*len); int k; for (k = i+2; k < *len-(insertLen+1); k++) { buf[k-(i+2)] = DEREF(complexRe,k); } /* insert the string */ for (k = 0; k < insertLen; k++) { DEREF(complexRe, i++) = toInsert[k]; } /* put the buffer back in */ for (k = i; k < *len; k++) { DEREF(complexRe,k) = buf[k-i]; } free(buf); }
/*-------------------------------------------------------------------------* * READ_ARG * * * *-------------------------------------------------------------------------*/ static WamWord Read_Arg(WamWord **lst_adr) { WamWord word, tag_mask; WamWord *adr; WamWord car_word; DEREF(**lst_adr, word, tag_mask); if (tag_mask != TAG_LST_MASK) { if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (word == NIL_WORD) Pl_Err_Domain(pl_domain_non_empty_list, word); Pl_Err_Type(pl_type_list, word); } adr = UnTag_LST(word); car_word = Car(adr); *lst_adr = &Cdr(adr); DEREF(car_word, word, tag_mask); return word; }
NODE * do_ext(int nargs) { NODE *obj, *init = NULL, *fini = NULL, *ret = NULL; SRCFILE *s; char *init_func = NULL; char *fini_func = NULL; if (nargs == 3) { fini = POP_STRING(); fini_func = fini->stptr; } if (nargs >= 2) { init = POP_STRING(); init_func = init->stptr; } obj = POP_STRING(); s = add_srcfile(SRC_EXTLIB, obj->stptr, srcfiles, NULL, NULL); if (s != NULL) ret = load_old_ext(s, init_func, fini_func, obj); DEREF(obj); if (fini != NULL) DEREF(fini); if (init != NULL) DEREF(init); if (ret == NULL) ret = dupnode(Nnull_string); return ret; }
void layout_clear(MessageLayout* layout, const void* storage, const upb_fielddef* field) { void* memory = slot_memory(layout, storage, field); uint32_t* oneof_case = slot_oneof_case(layout, storage, field); if (field_contains_hasbit(layout, field)) { slot_clear_hasbit(layout, storage, field); } if (upb_fielddef_containingoneof(field)) { memset(memory, 0, NATIVE_SLOT_MAX_SIZE); *oneof_case = ONEOF_CASE_NONE; } else if (is_map_field(field)) { VALUE map = Qnil; const upb_fielddef* key_field = map_field_key(field); const upb_fielddef* value_field = map_field_value(field); VALUE type_class = field_type_class(value_field); if (type_class != Qnil) { VALUE args[3] = { fieldtype_to_ruby(upb_fielddef_type(key_field)), fieldtype_to_ruby(upb_fielddef_type(value_field)), type_class, }; map = rb_class_new_instance(3, args, cMap); } else { VALUE args[2] = { fieldtype_to_ruby(upb_fielddef_type(key_field)), fieldtype_to_ruby(upb_fielddef_type(value_field)), }; map = rb_class_new_instance(2, args, cMap); } DEREF(memory, VALUE) = map; } else if (upb_fielddef_label(field) == UPB_LABEL_REPEATED) { VALUE ary = Qnil; VALUE type_class = field_type_class(field); if (type_class != Qnil) { VALUE args[2] = { fieldtype_to_ruby(upb_fielddef_type(field)), type_class, }; ary = rb_class_new_instance(2, args, cRepeatedField); } else { VALUE args[1] = { fieldtype_to_ruby(upb_fielddef_type(field)) }; ary = rb_class_new_instance(1, args, cRepeatedField); } DEREF(memory, VALUE) = ary; } else { native_slot_set(upb_fielddef_name(field), upb_fielddef_type(field), field_type_class(field), memory, layout_get_default(field)); } }
void layout_init(MessageLayout* layout, void* storage) { upb_msg_field_iter it; for (upb_msg_field_begin(&it, layout->msgdef); !upb_msg_field_done(&it); upb_msg_field_next(&it)) { const upb_fielddef* field = upb_msg_iter_field(&it); void* memory = slot_memory(layout, storage, field); uint32_t* oneof_case = slot_oneof_case(layout, storage, field); if (upb_fielddef_containingoneof(field)) { memset(memory, 0, NATIVE_SLOT_MAX_SIZE); *oneof_case = ONEOF_CASE_NONE; } else if (is_map_field(field)) { VALUE map = Qnil; const upb_fielddef* key_field = map_field_key(field); const upb_fielddef* value_field = map_field_value(field); VALUE type_class = field_type_class(value_field); if (type_class != Qnil) { VALUE args[3] = { fieldtype_to_ruby(upb_fielddef_type(key_field)), fieldtype_to_ruby(upb_fielddef_type(value_field)), type_class, }; map = rb_class_new_instance(3, args, cMap); } else { VALUE args[2] = { fieldtype_to_ruby(upb_fielddef_type(key_field)), fieldtype_to_ruby(upb_fielddef_type(value_field)), }; map = rb_class_new_instance(2, args, cMap); } DEREF(memory, VALUE) = map; } else if (upb_fielddef_label(field) == UPB_LABEL_REPEATED) { VALUE ary = Qnil; VALUE type_class = field_type_class(field); if (type_class != Qnil) { VALUE args[2] = { fieldtype_to_ruby(upb_fielddef_type(field)), type_class, }; ary = rb_class_new_instance(2, args, cRepeatedField); } else { VALUE args[1] = { fieldtype_to_ruby(upb_fielddef_type(field)) }; ary = rb_class_new_instance(1, args, cRepeatedField); } DEREF(memory, VALUE) = ary; } else { native_slot_init(upb_fielddef_type(field), memory); } } }
/*-------------------------------------------------------------------------* * 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_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); }
SimpleReBuilder * simplifyRe(char ** complexRe, SimpleReBuilder * builder) { int len = strlen(*complexRe); simpleReBuilder(&builder, len); int i,j; for (i = 0, j = 0; i < len; i++, j++) { switch(DEREF(complexRe, i)) { case '\\': handle_escape(builder, complexRe, &len, &j, &i); break; case '.': builder->re[j] = ANY; //nak is ANY break; case '+': builder->re[j] = PLUS; //0x01 is + break; case '?': builder->re[j] = QUESTION; //0x02 is ? break; case '*': builder->re[j] = STAR; //0x03 is * break; case '|': builder->re[j] = ALTERNATE; //0x04 is | break; case '(': builder->re[j] = PAREN_OPEN; //0x05 is ( break; case ')': builder->re[j] = PAREN_CLOSE; //0x06 is ) break; case '[': handle_range(builder, *complexRe, len, &j, &i); break; default: builder->re[j] = DEREF(complexRe,i); break; } } builder->re[j] = '\0'; return builder; }
static void *oneofbytes_handler(void *closure, const void *hd, size_t size_hint) { MessageHeader* msg = closure; const oneof_handlerdata_t *oneofdata = hd; VALUE str = rb_str_new2(""); rb_enc_associate(str, kRubyString8bitEncoding); DEREF(msg, oneofdata->case_ofs, uint32_t) = oneofdata->oneof_case_num; DEREF(msg, oneofdata->ofs, VALUE) = str; return (void*)str; }
PVector_ptr Vector_mul(PVector_ptr a, PVector_ptr b) { REF((heap_object *)a.vector); REF((heap_object *)b.vector); int i; if ( a.vector==NULL || b.vector==NULL || a.vector->length!=b.vector->length ) vector_operation_error(); size_t n = a.vector->length; PVector_ptr c = PVector_init(0, n); for (i=0; i<n; i++) c.vector->nodes[i].data = ith(a, i) * ith(b, i); DEREF((heap_object *)a.vector); DEREF((heap_object *)b.vector); return c; }
bool Vector_eq(PVector_ptr a, PVector_ptr b) { REF((heap_object *)a.vector); REF((heap_object *)b.vector); if (a.vector == NULL || b.vector == NULL) return false; if (a.vector->length != b.vector->length) return false; int i = (int)a.vector->length; for (int j = 0; j < i; j++) { if(a.vector->nodes[j].data != b.vector->nodes[j].data) return false; } DEREF((heap_object *)a.vector); DEREF((heap_object *)b.vector); return true; }
String *String_add(String *s, String *t) { if ( s==NULL ) return t; // don't REF/DEREF as we might free our return value if ( t==NULL ) return s; REF((heap_object *)s); REF((heap_object *)t); size_t n = strlen(s->str) + strlen(t->str); String *u = String_alloc(n); strcpy(u->str, s->str); strcat(u->str, t->str); DEREF((heap_object *)s); DEREF((heap_object *)t); return u; }
PVector_ptr Vector_add(PVector_ptr a, PVector_ptr b) { REF((heap_object *)a.vector); REF((heap_object *)b.vector); int i; if ( a.vector==NULL || b.vector==NULL || a.vector->length!=b.vector->length ) vector_operation_error(); size_t n = a.vector->length; PVector_ptr c = PVector_init(0, n); for (i=0; i<n; i++) c.vector->nodes[i].data = ith(a, i) + ith(b, i); // safe because we have sole ptr to c for now DEREF((heap_object *)a.vector); DEREF((heap_object *)b.vector); return c; }
bool native_slot_eq(upb_fieldtype_t type, void* mem1, void* mem2) { switch (type) { case UPB_TYPE_STRING: case UPB_TYPE_BYTES: case UPB_TYPE_MESSAGE: { VALUE val1 = DEREF(mem1, VALUE); VALUE val2 = DEREF(mem2, VALUE); VALUE ret = rb_funcall(val1, rb_intern("=="), 1, val2); return ret == Qtrue; } default: return !memcmp(mem1, mem2, native_slot_size(type)); } }
/*-------------------------------------------------------------------------* * 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_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_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; }
void layout_set(MessageLayout* layout, void* storage, const upb_fielddef* field, VALUE val) { void* memory = slot_memory(layout, storage, field); uint32_t* oneof_case = slot_oneof_case(layout, storage, field); if (upb_fielddef_containingoneof(field)) { if (val == Qnil) { // Assigning nil to a oneof field clears the oneof completely. *oneof_case = ONEOF_CASE_NONE; memset(memory, 0, NATIVE_SLOT_MAX_SIZE); } else { // The transition between field types for a single oneof (union) slot is // somewhat complex because we need to ensure that a GC triggered at any // point by a call into the Ruby VM sees a valid state for this field and // does not either go off into the weeds (following what it thinks is a // VALUE but is actually a different field type) or miss an object (seeing // what it thinks is a primitive field but is actually a VALUE for the new // field type). // // In order for the transition to be safe, the oneof case slot must be in // sync with the value slot whenever the Ruby VM has been called. Thus, we // use native_slot_set_value_and_case(), which ensures that both the value // and case number are altered atomically (w.r.t. the Ruby VM). native_slot_set_value_and_case( upb_fielddef_name(field), upb_fielddef_type(field), field_type_class(field), memory, val, oneof_case, upb_fielddef_number(field)); } } else if (is_map_field(field)) { check_map_field_type(val, field); DEREF(memory, VALUE) = val; } else if (upb_fielddef_label(field) == UPB_LABEL_REPEATED) { check_repeated_field_type(val, field); DEREF(memory, VALUE) = val; } else { native_slot_set(upb_fielddef_name(field), upb_fielddef_type(field), field_type_class(field), memory, val); } if (layout->fields[upb_fielddef_index(field)].hasbit != MESSAGE_FIELD_NO_HASBIT) { slot_set_hasbit(layout, storage, field); } }
static PyObject *PY_pdbdata_tp_str(PY_pdbdata *self) {intb bpi; char *str; Py_ssize_t size; PyObject *rv; if (_PD_indirection(self->type)) {str = DEREF(self->data); size = SC_arrlen(str);} else {str = self->data; bpi = _PD_lookup_size(self->type, self->fileinfo->file->host_chart); size = bpi * self->nitems;}; #if PY_MAJOR_VERSION >= 3 PyObject *io; io = PyBytes_FromStringAndSize(str, size); rv = PyObject_Str(io); #else rv = PY_STRING_STRING_SIZE(str, size); #endif return(rv);}
/*-------------------------------------------------------------------------* * 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_NAME_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Name_2(WamWord atomic_word, WamWord codes_word) { WamWord word, tag_mask; int syn_flag; Bool is_number; char *str; DEREF(atomic_word, word, tag_mask); if (tag_mask == TAG_ATM_MASK) return Pl_Atom_Codes_2(word, codes_word); if (tag_mask == TAG_INT_MASK || tag_mask == TAG_FLT_MASK) return Pl_Number_Codes_2(word, codes_word); if (tag_mask != TAG_REF_MASK) Pl_Err_Type(pl_type_atomic, word); str = Pl_Rd_Codes_Check(codes_word); syn_flag = Flag_Value(syntax_error); Flag_Value(syntax_error) = PF_ERR_FAIL; is_number = String_To_Number(str, word); /* only fails on syn err */ Flag_Value(syntax_error) = syn_flag; if (is_number) return TRUE; return Pl_Un_String(str, word); }
/*-------------------------------------------------------------------------* * PL_BETWEEN_3 * * * *-------------------------------------------------------------------------*/ Bool Pl_Between_3(WamWord l_word, WamWord u_word, WamWord i_word) { WamWord word, tag_mask; PlLong l, u, i; l = Pl_Rd_Integer_Check(l_word); u = Pl_Rd_Integer_Check(u_word); DEREF(i_word, word, tag_mask); if (tag_mask != TAG_REF_MASK) { i = Pl_Rd_Integer_Check(word); return i >= l && i <= u; } i_word = word; if (l > u) return FALSE; /* here i_word is a variable */ if (l < u) /* non deterministic case */ { A(0) = l + 1; A(1) = u; A(2) = i_word; Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(BETWEEN_ALT, 0), 3); } return Pl_Get_Integer(l, i_word); /* always TRUE */ }
CFUN__PROTO(current_instance, instance_t *) { int_info_t *root; BlockingType block; #if defined(PROFILE) tagged_t *junk; w->node->functor=find_definition(predicates_location,X(0),&junk,FALSE); #endif PredTrace("I",w->node->functor); root = TagToRoot(X(2)); if (root->behavior_on_failure == DYNAMIC) return current_instance_noconc(Arg); else { DEREF(X(4), X(4)); /* Blocking? (MCL) */ #if defined(DEBUG) if (X(4) == atom_block) block = BLOCK; else if (X(4) == atom_no_block) block = NO_BLOCK; else { failc("$current_instance called with unkown 5th argument"); return NULL; } #else block = X(4) == atom_block ? BLOCK : NO_BLOCK; #endif return current_instance_conc(Arg, block); } }
/*-------------------------------------------------------------------------* * PL_CURRENT_ATOM_2 * * * *-------------------------------------------------------------------------*/ Bool Pl_Current_Atom_2(WamWord atom_word, WamWord hide_word) { WamWord word, tag_mask; Bool hide; int atom; hide = Pl_Rd_Integer_Check(hide_word); DEREF(atom_word, word, tag_mask); if (tag_mask != TAG_REF_MASK) return *Pl_Rd_String_Check(word) != '$' || !hide; atom = -1; for (;;) { atom = Pl_Find_Next_Atom(atom); if (atom == -1) return FALSE; if (!hide || pl_atom_tbl[atom].name[0] != '$') break; } /* non deterministic case */ A(0) = atom_word; A(1) = hide; A(2) = atom; Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(CURRENT_ATOM_ALT, 0), 3); return Pl_Get_Atom(atom, atom_word); }
/*-------------------------------------------------------------------------* * PL_THROW_2 * * * *-------------------------------------------------------------------------*/ void Pl_Throw_2(WamWord ball_word, WamWord b_word) { WamWord word, tag_mask; WamWord *b; StmInf *pstm; DEREF(b_word, word, tag_mask); b = From_WamWord_To_B(word); if (b <= pl_query_top_b && pl_query_top_b != NULL) { Assign_B(pl_query_top_b); pl_query_exception = ball_word; Pl_Exit_With_Exception(); } if (b == LSSA) { pstm = pl_stm_tbl[pl_stm_top_level_output]; Pl_Stream_Printf(pstm, "\nsystem_error(cannot_catch_throw("); Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS | WRITE_NAME_VARS | WRITE_QUOTED, NULL, ball_word); Pl_Stream_Printf(pstm, "))\n"); return; } Pl_Cut(b_word); }
/*-------------------------------------------------------------------------* * PL_SETARG_4 * * * *-------------------------------------------------------------------------*/ Bool Pl_Setarg_4(WamWord arg_no_word, WamWord term_word, WamWord new_value_word, WamWord undo_word) { WamWord word, tag_mask; int func, arity; int undo; WamWord *arg_adr; int arg_no; arg_adr = Pl_Rd_Compound_Check(term_word, &func, &arity); arg_no = Pl_Rd_Positive_Check(arg_no_word) - 1; undo = Pl_Rd_Boolean_Check(undo_word); DEREF(new_value_word, word, tag_mask); if (!undo && tag_mask != TAG_ATM_MASK && tag_mask != TAG_INT_MASK) Pl_Err_Type(pl_type_atomic, word); /* pl_type_atomic but float not allowed */ if ((unsigned) arg_no >= (unsigned) arity) return FALSE; if (undo) Bind_OV((arg_adr + arg_no), word); else arg_adr[arg_no] = word; return TRUE; }