int prolog_code_call(CTXTdeclc Cell term, int value) { Psc psc; if (isconstr(term)) { int disp; char *addr; psc = get_str_psc(term); addr = (char *)(clref_val(term)); for (disp = 1; disp <= (int)get_arity(psc); ++disp) { bld_copy(reg+disp, cell((CPtr)(addr)+disp)); } bld_int(reg+get_arity(psc)+1, value); } else bld_int(reg+1, value); return TRUE; }
void set_psc_ep_to_psc(Psc psc_to_set, Psc target_psc) { if (get_arity(psc_to_set) != get_arity(target_psc)) { xsb_abort("[IMPORT AS] Cannot import predicate as a predicate with a different arity: %s/%d\n", get_name(psc_to_set),get_arity(psc_to_set)); } else if (get_ep(psc_to_set) != (byte *)&(psc_to_set->load_inst) && get_ep(psc_to_set) != (byte *)&(target_psc->load_inst)) { xsb_warn("[IMPORT AS] Redefining entry to import-as predicate: %s/%d\n", get_name(psc_to_set),get_arity(psc_to_set)); set_ep(psc_to_set,(byte *)&(target_psc->load_inst)); } else { set_ep(psc_to_set,(byte *)&(target_psc->load_inst)); } }
prolog_term intern_rec(CTXTdeclc prolog_term term) { int areaindex, reclen, i, j; CPtr hc_term; Cell dterm[255]; Cell arg; // printf("intern_rec\n"); // create term-record with all fields dereffed in dterm XSB_Deref(term); if (isinternstr(term)) {printf("old\n"); return term;} if (isconstr(term)) { areaindex = get_arity(get_str_psc(term)); reclen = areaindex + 1; cell(dterm) = (Cell)get_str_psc(term); // copy psc ptr j=1; } else if (islist(term)) { areaindex = LIST_INDEX; reclen = 2; j=0; } else return 0; for (i=j; i<reclen; i++) { arg = get_str_arg(term,i); // works for lists and strs XSB_Deref(arg); if (isref(arg) || (isstr(arg) && !isinternstr(arg)) || isattv(arg)) { return 0; } cell(dterm+i) = arg; } hc_term = insert_interned_rec(reclen, areaindex, dterm); if (islist(term)) return makelist(hc_term); else return makecs(hc_term); }
int prolog_call0(CTXTdeclc Cell term) { Psc psc; if (isconstr(term)) { int disp; char *addr; psc = get_str_psc(term); addr = (char *)(clref_val(term)); for (disp = 1; disp <= (int)get_arity(psc); ++disp) { bld_copy(reg+disp, cell((CPtr)(addr)+disp)); } } else if (isstring(term)) { int value; Pair sym; if (string_val(term) == true_string) return TRUE; /* short-circuit if calling "true" */ sym = insert(string_val(term),0,(Psc)flags[CURRENT_MODULE],&value); psc = pair_psc(sym); } else { if (isnonvar(term)) xsb_type_error(CTXTc "callable",term,"call/1",1); else xsb_instantiation_error(CTXTc "call/1",1); return FALSE; } #ifdef CP_DEBUG pscreg = psc; #endif pcreg = get_ep(psc); if (asynint_val) intercept(CTXTc psc); return TRUE; }
void printTrieSymbol(FILE *fp, Cell symbol) { if ( symbol == ESCAPE_NODE_SYMBOL ) fprintf(fp, "%lu [ESCAPE_NODE_SYMBOL]", ESCAPE_NODE_SYMBOL); else { switch(TrieSymbolType(symbol)) { case XSB_INT: fprintf(fp, IntegerFormatString, int_val(symbol)); break; case XSB_FLOAT: fprintf(fp, "%f", float_val(symbol)); break; case XSB_STRING: fprintf(fp, "%s", string_val(symbol)); break; case XSB_TrieVar: fprintf(fp, "V" IntegerFormatString, DecodeTrieVar(symbol)); break; case XSB_STRUCT: { Psc psc = DecodeTrieFunctor(symbol); fprintf(fp, "%s/%d", get_name(psc), get_arity(psc)); } break; case XSB_LIST: fprintf(fp, "LIST"); break; default: fprintf(fp, "Unknown symbol (tag = %ld)", cell_tag(symbol)); break; } } }
void expand_symbol_table() { Pair *new_table, *bucket_ptr, cur_pair, next_pair; Psc cur_psc; size_t index, new_size, new_index; new_size = next_prime(symbol_table.size); new_table = (Pair *)mem_calloc(new_size, sizeof(void *),ATOM_SPACE); for (bucket_ptr = (Pair *)symbol_table.table, index = 0; index < symbol_table.size; bucket_ptr++, index++) for (cur_pair = *bucket_ptr; cur_pair != NULL; cur_pair = next_pair) { next_pair = pair_next(cur_pair); cur_psc = pair_psc(cur_pair); new_index = hash(get_name(cur_psc), get_arity(cur_psc), new_size); pair_next(cur_pair) = new_table[new_index]; new_table[new_index] = cur_pair; } mem_dealloc((void *)symbol_table.table,symbol_table.size,ATOM_SPACE); symbol_table.size = new_size; symbol_table.table = (void **)new_table; /*printf("expanded atom table to: %d\n",new_size);*/ }
Pair link_sym(Psc psc, Psc mod_psc) { Pair *search_ptr, found_pair; char *name, message[120]; byte arity, global_flag; name = get_name(psc); arity = get_arity(psc); if ( (global_flag = is_globalmod(mod_psc)) ) search_ptr = (Pair *)symbol_table.table + hash(name, arity, symbol_table.size); else search_ptr = (Pair *)&get_data(mod_psc); if ((found_pair = search(arity, name, search_ptr))) { if (pair_psc(found_pair) != psc) { /* * Invalidate the old name!! It is no longer accessible * through the global chain. */ if ( get_type(pair_psc(found_pair)) != T_ORDI ) { sprintf(message, "%s/%d (type %d) was defined in another module!", name, arity, get_type(pair_psc(found_pair))); xsb_warn(message); } pair_psc(found_pair) = psc; } } else { found_pair = make_psc_pair(psc, search_ptr); if (global_flag) symbol_table_increment_and_check_for_overflow; } return found_pair; } /* link_sym */
virtual bool call_match(const std::vector<Boxed_Value> &vals, const Dynamic_Cast_Conversions &t_conversions) const { if (int(vals.size()) != get_arity()) { return false; } return compare_types(m_types, vals) || detail::compare_types_cast(m_dummy_func, vals, t_conversions); }
/* reg 1: tag for this call reg 2: filter list of goals to keep (keep all if []) reg 3: returned list of changed goals reg 4: used as temp (in case of heap expansion) */ int create_changed_call_list(CTXTdecl){ callnodeptr call1; VariantSF subgoal; TIFptr tif; int j, count = 0,arity; Psc psc; CPtr oldhreg = NULL; reg[4] = makelist(hreg); new_heap_free(hreg); // make heap consistent new_heap_free(hreg); while ((call1 = delete_calllist_elt(&changed_gl)) != EMPTY){ subgoal = (VariantSF) call1->goal; tif = (TIFptr) subgoal->tif_ptr; psc = TIF_PSC(tif); if (in_reg2_list(CTXTc psc)) { count++; arity = get_arity(psc); check_glstack_overflow(4,pcreg,2+arity*200); // guess for build_subgoal_args... oldhreg = hreg-2; if(arity>0){ sreg = hreg; follow(oldhreg++) = makecs(hreg); hreg += arity + 1; new_heap_functor(sreg, psc); for (j = 1; j <= arity; j++) { new_heap_free(sreg); cell_array1[arity-j] = cell(sreg-1); } build_subgoal_args(subgoal); }else{ follow(oldhreg++) = makestring(get_name(psc)); } follow(oldhreg) = makelist(hreg); new_heap_free(hreg); // make heap consistent new_heap_free(hreg); } } if (count>0) follow(oldhreg) = makenil; else reg[4] = makenil; return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4)); /* int i; for(i=0; i<callqptr; i++){ if(IsNonNULL(callq[i]) && (callq[i]->deleted==1)){ sfPrintGoal(stdout,(VariantSF)callq[i]->goal,NO); printf(" %d %d\n",callq[i]->falsecount,callq[i]->deleted); } } printf("-----------------------------\n"); */ }
/* * Takes the top operator off of operators, grabs operands from output * and puts the new tree on output */ void pop_operator(Token* operators, unsigned* operatorsLen, Token* output, unsigned* outputLen){ Token op = pop_token_stack(operators, operatorsLen); assert(op->type == BUILTIN); if(get_arity(op->builtin) == 1){ if(*outputLen < 1){ ERROR("insufficient operands (expected 1)"); } op->left = pop_token_stack(output, outputLen); } else { // all the other infix ops are binary assert(get_arity(op->builtin) == 2); if(*outputLen < 2){ ERROR("insufficient operands (expected 2)"); } // stack, so fill in operands in reverse order op->right = pop_token_stack(output, outputLen); op->left = pop_token_stack(output, outputLen); assert(op->right != op->left); // guard against horrible bug from the before-times } push_token_stack(op, output, outputLen); }
action_result no_confusion_action(hypothesis_idx hidx) { try { state & s = curr_state(); app_builder & b = get_app_builder(); hypothesis const & h = s.get_hypothesis_decl(hidx); expr type = h.get_type(); expr lhs, rhs; if (!is_eq(type, lhs, rhs)) return action_result::failed(); lhs = whnf(lhs); rhs = whnf(rhs); optional<name> c1 = is_constructor_app(env(), lhs); optional<name> c2 = is_constructor_app(env(), rhs); if (!c1 || !c2) return action_result::failed(); expr A = whnf(infer_type(lhs)); expr I = get_app_fn(A); if (!is_constant(I) || !inductive::is_inductive_decl(env(), const_name(I))) return action_result::failed(); name nct_name(const_name(I), "no_confusion_type"); if (!env().find(nct_name)) return action_result::failed(); expr target = s.get_target(); expr nct = whnf(b.mk_app(nct_name, target, lhs, rhs)); if (c1 == c2) { if (!is_pi(nct)) return action_result::failed(); if (s.has_target_forward_deps(hidx)) { // TODO(Leo): we currently do not handle this case. // To avoid non-termination we remove the given hypothesis, if there // forward dependencies, we would also have to remove them. // Remark: this is a low priority refinement since it will not happen // very often in practice. return action_result::failed(); } unsigned num_params = *inductive::get_num_params(env(), const_name(I)); unsigned cnstr_arity = get_arity(env().get(*c1).get_type()); lean_assert(cnstr_arity >= num_params); unsigned num_new_eqs = cnstr_arity - num_params; s.push_proof_step(new no_confusion_proof_step_cell(const_name(I), target, h.get_self(), num_new_eqs)); s.set_target(binding_domain(nct)); s.del_hypothesis(hidx); trace_action("no_confusion"); return action_result::new_branch(); } else { name nc_name(const_name(I), "no_confusion"); expr pr = b.mk_app(nc_name, {target, lhs, rhs, h.get_self()}); trace_action("no_confusion"); return action_result::solved(pr); } } catch (app_builder_exception &) { return action_result::failed(); } }
/* For a callnode call1 returns a Prolog list of callnode on which call1 immediately depends. */ int immediate_inedges_list(CTXTdeclc callnodeptr call1){ VariantSF subgoal; TIFptr tif; int j, count = 0,arity; Psc psc; CPtr oldhreg = NULL; calllistptr cl; reg[4] = makelist(hreg); new_heap_free(hreg); new_heap_free(hreg); if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */ cl= call1->inedges; while(IsNonNULL(cl)){ subgoal = (VariantSF) cl->inedge_node->callnode->goal; if(IsNonNULL(subgoal)){/* fact check */ count++; tif = (TIFptr) subgoal->tif_ptr; psc = TIF_PSC(tif); arity = get_arity(psc); check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args... oldhreg = hreg-2; if(arity>0){ sreg = hreg; follow(oldhreg++) = makecs(hreg); hreg += arity + 1; new_heap_functor(sreg, psc); for (j = 1; j <= arity; j++) { new_heap_free(sreg); cell_array1[arity-j] = cell(sreg-1); } build_subgoal_args(subgoal); }else{ follow(oldhreg++) = makestring(get_name(psc)); } follow(oldhreg) = makelist(hreg); new_heap_free(hreg); new_heap_free(hreg); } cl=cl->next; } if (count>0) follow(oldhreg) = makenil; else reg[4] = makenil; }else{ xsb_warn("Called with non-incremental predicate\n"); reg[4] = makenil; } return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4)); }
void dfs_outedges_check_non_completed(CTXTdeclc callnodeptr call1) { char bufferb[MAXTERMBUFSIZE]; if(IsNonNULL(call1->goal) && !subg_is_completed((VariantSF)call1->goal)){ deallocate_call_list(affected_gl); sprint_subgoal(CTXTc forest_log_buffer_1,0,(VariantSF)call1->goal); sprintf(bufferb,"Incremental tabling is trying to invalidate an incomplete table \n %s\n", forest_log_buffer_1->fl_buffer); xsb_new_table_error(CTXTc "incremental_tabling",bufferb, get_name(TIF_PSC(subg_tif_ptr(call1->goal))), get_arity(TIF_PSC(subg_tif_ptr(call1->goal)))); } }
Pair build_call(CTXTdeclc Psc psc) { register Cell arg; register Pair callstr; register int i; callstr = (Pair)hreg; /* save addr of new structure rec */ new_heap_functor(hreg, psc); /* set str psc ptr */ for (i=1; i <= (int)get_arity(psc); i++) { arg = cell(reg+i); nbldval(arg); } return callstr; }
/* * Returns a pointer to the PSC-PAIR structure which points to the * PSC record of the desired symbol. */ static Pair search(int arity, char *name, Pair *search_ptr) { Psc psc_ptr; while (*search_ptr) { psc_ptr = (*search_ptr)->psc_ptr; if (strcmp(name, get_name(psc_ptr)) == 0 && arity == get_arity(psc_ptr) ) return (*search_ptr); else search_ptr = &((*search_ptr)->next); } return NULL; } /* search */
Pair link_sym(Psc psc, Psc mod_psc) { Pair *search_ptr, found_pair; char *name; byte arity, global_flag, type; SYS_MUTEX_LOCK_NOERROR( MUTEX_SYMBOL ) ; name = get_name(psc); arity = get_arity(psc); if ( (global_flag = is_globalmod(mod_psc)) ) { search_ptr = (Pair *)symbol_table.table + hash(name, arity, symbol_table.size); } else search_ptr = (Pair *)&get_data(mod_psc); if ((found_pair = search(arity, name, search_ptr))) { if (pair_psc(found_pair) != psc) { /* * Invalidate the old name!! It is no longer accessible * through the global chain. */ type = get_type(pair_psc(found_pair)); if ( type != T_ORDI ) { char message[220], modmsg[200]; if (type == T_DYNA || type == T_PRED) { Psc mod_psc; mod_psc = (Psc) get_data(pair_psc(found_pair)); if (mod_psc == 0) snprintf(modmsg,200,"%s","usermod"); else if (isstring(mod_psc)) snprintf(modmsg,200,"usermod from file: %s",string_val(mod_psc)); else snprintf(modmsg,200,"module: %s",get_name(mod_psc)); snprintf(message,220, "%s/%d (type %d) had been defined in %s", name, arity, type, modmsg); } else snprintf(message,220, "%s/%d (type %d) had been defined in another module!", name, arity, type); xsb_warn(message); } pair_psc(found_pair) = psc; } } else { found_pair = make_psc_pair(psc, search_ptr); if (global_flag) symbol_table_increment_and_check_for_overflow; } SYS_MUTEX_UNLOCK_NOERROR( MUTEX_SYMBOL ) ; return found_pair; } /* link_sym */
/* If ret != 0 (= CANNOT_UPDATE) then we'll use the old table, and we wont lazily update at all. */ int dfs_inedges(CTXTdeclc callnodeptr call1, calllistptr * lazy_affected, int flag ){ calllistptr inedge_list; VariantSF subgoal; int ret = 0; if(IsNonNULL(call1->goal)) { if (!subg_is_completed((VariantSF)call1->goal)){ deallocate_call_list(*lazy_affected); xsb_new_table_error(CTXTc "incremental_tabling", "Incremental tabling is trying to invalidate an incomplete table", get_name(TIF_PSC(subg_tif_ptr(call1->goal))), get_arity(TIF_PSC(subg_tif_ptr(call1->goal)))); } if (subg_visitors(call1->goal)) { #ifdef ISO_INCR_TABLING find_the_visitors(CTXTc call1->goal); #else dfs_inedges_warning(CTXTc call1,lazy_affected); return CANNOT_UPDATE; #endif } } // TLS: handles dags&cycles -- no need to traverse more than once. if (call1 -> recomputable == COMPUTE_DEPENDENCIES_FIRST) call1 -> recomputable = COMPUTE_DIRECTLY; else { // printf("found directly computable call \n"); return 0; } // printf(" dfs_i affected "); print_subgoal(stddbg,call1->goal);printf("\n"); inedge_list= call1-> inedges; while(IsNonNULL(inedge_list) && !ret){ subgoal = (VariantSF) inedge_list->inedge_node->callnode->goal; if(IsNonNULL(subgoal)){ /* fact check */ // count++; if (inedge_list->inedge_node->callnode->falsecount > 0) { ret = ret | dfs_inedges(CTXTc inedge_list->inedge_node->callnode, lazy_affected,flag); } else { ; // printf(" dfs_i non_affected "); print_subgoal(stddbg,subgoal);printf("\n"); } } inedge_list = inedge_list->next; } if(IsNonNULL(call1->goal) & !ret){ /* fact check */ // printf(" dfs_i adding "); print_subgoal(stddbg,call1->goal);printf("\n"); add_callnode(lazy_affected,call1); } return ret; }
/* term must have been dereferenced */ Integer intern_term_size(CTXTdeclc Cell term) { Integer size = 0 ; recur: switch(cell_tag(term)) { case XSB_FREE: case XSB_REF1: case XSB_INT: case XSB_STRING: case XSB_FLOAT: return size ; case XSB_LIST: { if (isinternstr(term)) {return size;} else { CPtr pfirstel ; pfirstel = clref_val(term) ; term = *pfirstel ; XSB_Deref(term) ; size += 2 + intern_term_size(CTXTc term) ; term = *(pfirstel+1) ; XSB_Deref(term) ; goto recur; } } case XSB_STRUCT: { if (isinternstr(term)) return size; else { int a ; CPtr pfirstel ; pfirstel = (CPtr)cs_val(term) ; a = get_arity((Psc)(*pfirstel)) ; size += a + 1 ; if (a) { while( --a ) { term = *++pfirstel ; XSB_Deref(term) ; size += intern_term_size( CTXTc term ) ; } } term = *++pfirstel ; XSB_Deref(term) ; goto recur; } } case XSB_ATTV: return size; } return FALSE; }
int return_scc_list(CTXTdeclc SCCNode * nodes, int num_nodes){ VariantSF subgoal; TIFptr tif; int cur_node = 0,arity, j; Psc psc; CPtr oldhreg = NULL; reg[4] = makelist(hreg); new_heap_free(hreg); new_heap_free(hreg); do { subgoal = (VariantSF) nodes[cur_node].node; tif = (TIFptr) subgoal->tif_ptr; psc = TIF_PSC(tif); arity = get_arity(psc); // printf("subgoal %p, %s/%d\n",subgoal,get_name(psc),arity); check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args.. oldhreg=hreg-2; // ptr to car if(arity>0){ sreg = hreg; follow(oldhreg++) = makecs(sreg); new_heap_functor(sreg,get_ret_psc(2)); // car pts to ret/2 psc hreg += 3; // hreg pts past ret/2 sreg = hreg; follow(hreg-1) = makeint(nodes[cur_node].component); // arg 2 of ret/2 pts to component follow(hreg-2) = makecs(sreg); new_heap_functor(sreg, psc); // arg 1 of ret/2 pts to goal psc hreg += arity + 1; for (j = 1; j <= arity; j++) { new_heap_free(sreg); cell_array1[arity-j] = cell(sreg-1); } build_subgoal_args(subgoal); } else{ follow(oldhreg++) = makestring(get_name(psc)); } follow(oldhreg) = makelist(hreg); // cdr points to next car new_heap_free(hreg); new_heap_free(hreg); cur_node++; } while (cur_node < num_nodes); follow(oldhreg) = makenil; // cdr points to next car return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4)); }
/* must be called with interned term (isinternstr(term)is true) */ int is_interned_rec(Cell term) { int areaindex, reclen; struct intterm_rec *recptr; CPtr term_rec; UInteger hashindex; if (islist(term)) {areaindex = LIST_INDEX; reclen = 2; } else {areaindex = get_arity(get_str_psc(term)); reclen = areaindex + 1; } if (!hc_block[areaindex].base) return FALSE; term_rec = (CPtr)cs_val(term); hashindex = it_hash(hc_block[areaindex].hashtab_size,reclen,term_rec); recptr = hc_block[areaindex].hashtab[hashindex]; while (recptr) { if (term_rec == &(recptr->intterm_psc)) {return TRUE;} recptr = recptr->next; } return FALSE; }
int sprintTrieSymbol(char * buffer, Cell symbol) { int ctr; if ( symbol == ESCAPE_NODE_SYMBOL ) return sprintf(buffer, "%lu [ESCAPE_NODE_SYMBOL]", ESCAPE_NODE_SYMBOL); else { switch(TrieSymbolType(symbol)) { case XSB_INT: return sprintf(buffer, IntegerFormatString, int_val(symbol)); break; case XSB_FLOAT: return sprintf(buffer, "%f", float_val(symbol)); break; case XSB_STRING: return sprintf(buffer, "%s", string_val(symbol)); break; case XSB_TrieVar: return sprintf(buffer, "_V" IntegerFormatString, DecodeTrieVar(symbol)); break; case XSB_STRUCT: { Psc psc; if (isboxedfloat(symbol)) { return sprintf(buffer, "%lf", boxedfloat_val(symbol)); break; } psc = DecodeTrieFunctor(symbol); ctr = sprint_quotedname(buffer, 0, get_name(psc)); return sprintf(buffer+ctr, "/%d", get_arity(psc)); } break; case XSB_LIST: return sprintf(buffer, "LIST"); break; default: return sprintf(buffer, "Unknown symbol (tag = %" Intfmt")", cell_tag(symbol)); break; } } }
/* * Returns a pointer to the PSC-PAIR structure which points to the * PSC record of the desired symbol. */ static Pair search(int arity, char *name, Pair *search_ptr) { Psc psc_ptr; /* Pair *init_search_ptr = search_ptr; */ /* Pair found_pair; */ while (*search_ptr) { psc_ptr = (*search_ptr)->psc_ptr; if (strcmp(name, get_name(psc_ptr)) == 0 && arity == get_arity(psc_ptr) ) { if (strcmp(name, "query") == 0) { printf("%s %d\n", name, arity); } return (*search_ptr); } else search_ptr = &((*search_ptr)->next); } return NULL; } /* search */
xsbBool are_identical_terms(Cell term1, Cell term2) { begin_are_identical_terms: XSB_Deref(term1); XSB_Deref(term2); if ( term1 == term2 ) return TRUE; if ( cell_tag(term1) != cell_tag(term2) ) return FALSE; if ( cell_tag(term1) == XSB_STRUCT ) { CPtr cptr1 = clref_val(term1); CPtr cptr2 = clref_val(term2); Psc psc1 = (Psc)*cptr1; int i; if ( psc1 != (Psc)*cptr2 ) return FALSE; for ( cptr1++, cptr2++, i = 0; i < (int)get_arity(psc1)-1; cptr1++, cptr2++, i++ ) if ( ! are_identical_terms(*cptr1,*cptr2) ) return FALSE; term1 = *cptr1; term2 = *cptr2; goto begin_are_identical_terms; } else if ( cell_tag(term1) == XSB_LIST ) { CPtr cptr1 = clref_val(term1); CPtr cptr2 = clref_val(term2); if ( are_identical_terms(*cptr1, *cptr2) ) { term1 = *(cptr1 + 1); term2 = *(cptr2 + 1); goto begin_are_identical_terms; } else return FALSE; } else return FALSE; }
/* should be passed a term which is dereffed for which isinternstr is true! */ int isinternstr_really(prolog_term term) { int areaindex, reclen, i; CPtr termrec; CPtr hc_term; struct intterm_rec *recptr; Integer hashindex; int found; XSB_Deref(term); if (isconstr(term)) { areaindex = get_arity(get_str_psc(term)); reclen = areaindex + 1; } else if (islist(term)) { areaindex = LIST_INDEX; reclen = 2; } else return FALSE; if (!hc_block[areaindex].hashtab) return FALSE; termrec = (CPtr)dec_addr(term); hashindex = it_hash(hc_block[areaindex].hashtab_size,reclen,termrec); recptr = hc_block[areaindex].hashtab[hashindex]; while (recptr) { found = 1; hc_term = &(recptr->intterm_psc); for (i=0; i<reclen; i++) { if (cell(hc_term+i) != cell(termrec+i)) { found = 0; break; } } // if (found && (hc_term == termrec)) printf("found interned term\n"); if (found) return (hc_term == termrec); recptr = recptr->next; } return FALSE; }
Status parse(const Token *tokens, Stack **operands, Stack **operators, Stack **functions) { Status status = OK; const Token *token, *previous, *next; for (token = tokens, previous = &NO_TOKEN, next = token + 1; token->type != TOKEN_NONE; previous = token, token = next++) { switch (token->type) { case TOKEN_OPEN_PARENTHESIS: { // Implicit multiplication: "(2)(2)". if (previous->type == TOKEN_CLOSE_PARENTHESIS) { status = push_multiplication(operands, operators); } stack_push(operators, get_operator('(', OPERATOR_OTHER)); break; } case TOKEN_CLOSE_PARENTHESIS: { // Apply operators until the previous open parenthesis is found. bool found_parenthesis = false; while (*operators && status == OK && !found_parenthesis) { const Operator *operator = stack_pop(operators); if (operator->symbol == '(') { found_parenthesis = true; } else { status = apply_operator(operator, operands); } } if (!found_parenthesis) { status = ERROR_CLOSE_PARENTHESIS; } else if (*functions) { status = apply_function(stack_pop(functions), operands); } break; } case TOKEN_OPERATOR: { status = push_operator( get_operator(*token->value, get_arity(*token->value, previous)), operands, operators); break; } case TOKEN_NUMBER: { if (previous->type == TOKEN_CLOSE_PARENTHESIS || previous->type == TOKEN_NUMBER || previous->type == TOKEN_IDENTIFIER) { status = ERROR_SYNTAX; } else { status = push_number(token->value, operands); // Implicit multiplication: "2(2)" or "2a". if (next->type == TOKEN_OPEN_PARENTHESIS || next->type == TOKEN_IDENTIFIER) { status = push_multiplication(operands, operators); } } break; } case TOKEN_IDENTIFIER: { // The identifier could be either a constant or function. status = push_constant(token->value, operands); if (status == ERROR_UNDEFINED_CONSTANT && next->type == TOKEN_OPEN_PARENTHESIS) { stack_push(functions, token->value); status = OK; } else if (next->type == TOKEN_OPEN_PARENTHESIS || next->type == TOKEN_IDENTIFIER) { // Implicit multiplication: "a(2)" or "a b". status = push_multiplication(operands, operators); } break; } default: { status = ERROR_UNRECOGNIZED; } } if (status != OK) { return status; } } // Apply all remaining operators. while (*operators && status == OK) { const Operator *operator = stack_pop(operators); if (operator->symbol == '(') { status = ERROR_OPEN_PARENTHESIS; } else { status = apply_operator(operator, operands); } } return status; }
static DE intern_delay_element(Cell delay_elem) { DE de; CPtr cptr = (CPtr) cs_val(delay_elem); /* * All the following information about delay_elem is set in * delay_negatively() or delay_positively(). Note that cell(cptr) is * the delay_psc ('DL'). */ VariantSF subgoal; NODEptr ans_subst; CPtr ret_n = 0; int arity; Cell tmp_cell; tmp_cell = cell(cptr + 1); subgoal = (VariantSF) addr_val(tmp_cell); tmp_cell = cell(cptr + 2); ans_subst = (NODEptr) addr_val(tmp_cell); tmp_cell = cell(cptr + 3); /* * cell(cptr + 3) can be one of the following: * 1. integer 0 (NEG_DELAY), for a negative DE; * 2. string "ret", for a positive DE with arity 0; * 3. constr ret/n, for a positive DE with arity >=1. */ if (isinteger(tmp_cell) || isstring(tmp_cell)) arity = 0; else { ret_n = (CPtr) cs_val(tmp_cell); arity = get_arity((Psc) get_str_psc(cell(cptr + 3))); } #ifdef DEBUG_DELAYVAR xsb_dbgmsg((LOG_DEBUG,">>>> ")); dbg_print_delay_list(LOG_DEBUG,stddbg, delayreg); xsb_dbgmsg((LOG_DEBUG, "\n")); xsb_dbgmsg((LOG_DEBUG, ">>>> (Intern ONE de) arity of answer subsf = %d\n", arity)); #endif if (!was_simplifiable(subgoal, ans_subst)) { new_entry(de, released_des, next_free_de, current_de_block, current_de_block_top, de_next, DE, de_block_size, "Not enough memory to expand DE space"); de_subgoal(de) = subgoal; de_ans_subst(de) = ans_subst; /* Leaf of the answer (substitution) trie */ #ifdef DEBUG_DELAYVAR de_subs_fact(de) = NULL; #ifndef IGNORE_DELAYVAR if (arity != 0) { de_subs_fact_leaf(de) = delay_chk_insert(arity, ret_n + 1, (CPtr *) &de_subs_fact(de)); } #endif /* IGNORE_DELAYVAR */ #else #ifndef IGNORE_DELAYVAR if (arity != 0) { CPtr hook = NULL; de_subs_fact_leaf(de) = delay_chk_insert(arity, ret_n + 1, &hook); } #endif /* IGNORE_DELAYVAR */ #endif return de; } else return NULL; }
int create_lazy_call_list(CTXTdeclc callnodeptr call1){ VariantSF subgoal; TIFptr tif; int j,count=0,arity; Psc psc; CPtr oldhreg=NULL; // print_call_list(lazy_affected); reg[6] = reg[5] = makelist(hreg); // reg 5 first not-used, use regs in case of stack expanson new_heap_free(hreg); // make heap consistent new_heap_free(hreg); while((call1 = delete_calllist_elt(&lazy_affected)) != EMPTY){ subgoal = (VariantSF) call1->goal; // fprintf(stddbg," considering ");print_subgoal(stdout,subgoal);printf("\n"); if(IsNULL(subgoal)){ /* fact predicates */ call1->deleted = 0; continue; } if (subg_visitors(subgoal)) { sprint_subgoal(CTXTc forest_log_buffer_1,0,subgoal); #ifdef ISO_INCR_TABLING find_the_visitors(CTXTc subgoal); #else #ifdef WARN_ON_UNSAFE_UPDATE xsb_warn("%d Choice point(s) exist to the table for %s -- cannot incrementally update (create_lazy_call_list)\n", subg_visitors(subgoal),forest_log_buffer_1->fl_buffer); #else xsb_abort("%d Choice point(s) exist to the table for %s -- cannot incrementally update (create_lazy_call_list)\n", subg_visitors(subgoal),forest_log_buffer_1->fl_buffer); #endif #endif continue; } // fprintf(stddbg,"adding dependency for ");print_subgoal(stdout,subgoal);printf("\n"); count++; tif = (TIFptr) subgoal->tif_ptr; // if (!(psc = TIF_PSC(tif))) // xsb_table_error(CTXTc "Cannot access dynamic incremental table\n"); psc = TIF_PSC(tif); arity = get_arity(psc); check_glstack_overflow(6,pcreg,2+arity*200); // don't know how much for build_subgoal_args... oldhreg = clref_val(reg[6]); // maybe updated by re-alloc if(arity>0){ sreg = hreg; follow(oldhreg++) = makecs(sreg); hreg += arity + 1; // had 10, why 10? why not 3? 2 for list, 1 for functor (dsw) new_heap_functor(sreg, psc); for (j = 1; j <= arity; j++) { new_heap_free(sreg); cell_array1[arity-j] = cell(sreg-1); } build_subgoal_args(subgoal); } else { follow(oldhreg++) = makestring(get_name(psc)); } reg[6] = follow(oldhreg) = makelist(hreg); new_heap_free(hreg); new_heap_free(hreg); } if(count > 0) { follow(oldhreg) = makenil; hreg -= 2; /* take back the extra words allocated... */ } else reg[5] = makenil; return unify(CTXTc reg_term(CTXTc 4),reg_term(CTXTc 5)); /*int i; for(i=0;i<callqptr;i++){ if(IsNonNULL(callq[i]) && (callq[i]->deleted==1)){ sfPrintGoal(stdout,(VariantSF)callq[i]->goal,NO); printf(" %d %d\n",callq[i]->falsecount,callq[i]->deleted); } } printf("-----------------------------\n"); */ }
/* caller must ensure enough heap space (term_size(term)*sizeof(Cell)) */ prolog_term intern_term(CTXTdeclc prolog_term term) { Integer ti = 0; Cell arg, newterm, interned_term, orig_term; unsigned int subterm_index; XSB_Deref(term); if (!(islist(term) || isconstr(term))) {return term;} if (isinternstr(term)) {return term;} if (is_cyclic(CTXTc term)) {xsb_abort("Cannot intern a cyclic term\n");} // if (!ground(term)) {return term;} orig_term = term; // printf("iti: ");printterm(stdout,orig_term,100);printf("\n"); if (!ts_array) { ts_array = mem_alloc(init_ts_array_len*sizeof(*ts_array),OTHER_SPACE); if (!ts_array) xsb_abort("No space for interning term\n"); ts_array_len = init_ts_array_len; } ts_array[0].term = term; if (islist(term)) { ts_array[0].subterm_index = 0; ts_array[0].newterm = makelist(hreg); hreg += 2; } else { // if (isboxedinteger(term)) printf("interning boxed int\n"); // else if (isboxedfloat(term)) printf("interning boxed float %f\n",boxedfloat_val(term)); ts_array[0].subterm_index = 1; ts_array[0].newterm = makecs(hreg); new_heap_functor(hreg, get_str_psc(term)); hreg += get_arity(get_str_psc(term)); } ts_array[ti].ground = 1; while (ti >= 0) { term = ts_array[ti].term; newterm = ts_array[ti].newterm; subterm_index = ts_array[ti].subterm_index; if ((islist(term) && subterm_index >= 2) || (isconstr(term) && subterm_index > get_arity(get_str_psc(term)))) { if (ts_array[ti].ground) { interned_term = intern_rec(CTXTc newterm); if (!interned_term) xsb_abort("error term should have been interned\n"); hreg = clref_val(newterm); // reclaim used stack space if (!ti) { if (compare(CTXTc (void*)orig_term,(void*)interned_term) != 0) printf("NOT SAME\n"); //printf("itg: ");printterm(stdout,interned_term,100);printf("\n"); return interned_term; } ti--; get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = interned_term; } else { //printf("hreg = %p, ti=%d\n",hreg,ti); if (!ti) { if (compare(CTXTc (void*)orig_term,(void*)newterm) != 0) printf("NOT SAME\n"); //printf("ito: ");printterm(stdout,newterm,100);printf("\n"); return newterm; } ti--; get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = newterm; ts_array[ti].ground = 0; } } else { arg = get_str_arg(term, (ts_array[ti].subterm_index)++); XSB_Deref(arg); switch (cell_tag(arg)) { case XSB_FREE: case XSB_REF1: case XSB_ATTV: ts_array[ti].ground = 0; get_str_arg(newterm,subterm_index) = arg; break; case XSB_STRING: if (string_find_safe(string_val(arg)) != string_val(arg)) printf("uninterned string?\n"); case XSB_INT: case XSB_FLOAT: get_str_arg(newterm,subterm_index) = arg; break; case XSB_LIST: if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg; else { ti++; check_ts_array_overflow; ts_array[ti].term = arg; ts_array[ti].subterm_index = 0; ts_array[ti].ground = 1; ts_array[ti].newterm = makelist(hreg); hreg += 2; } break; case XSB_STRUCT: if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg; else { // if (isboxedinteger(arg)) printf("interning boxed int\n"); // else if (isboxedfloat(arg)) printf("interning boxed float %f\n",boxedfloat_val(arg)); ti++; check_ts_array_overflow; ts_array[ti].term = arg; ts_array[ti].subterm_index = 1; ts_array[ti].ground = 1; ts_array[ti].newterm = makecs(hreg); new_heap_functor(hreg,get_str_psc(arg)); hreg += get_arity(get_str_psc(arg)); } } } } printf("intern_term: shouldn't happen\n"); return 0; }
int immediate_outedges_list(CTXTdeclc callnodeptr call1){ VariantSF subgoal; TIFptr tif; int j, count = 0,arity; Psc psc; CPtr oldhreg = NULL; struct hashtable *h; struct hashtable_itr *itr; callnodeptr cn; reg[4] = makelist(hreg); new_heap_free(hreg); new_heap_free(hreg); if(IsNonNULL(call1)){ /* This can be called from some non incremental predicate */ h=call1->outedges->hasht; itr = hashtable1_iterator(h); if (hashtable1_count(h) > 0){ do { cn = hashtable1_iterator_value(itr); if(IsNonNULL(cn->goal)){ count++; subgoal = (VariantSF) cn->goal; tif = (TIFptr) subgoal->tif_ptr; psc = TIF_PSC(tif); arity = get_arity(psc); check_glstack_overflow(4,pcreg,2+arity*200); // don't know how much for build_subgoal_args... oldhreg=hreg-2; if(arity>0){ sreg = hreg; follow(oldhreg++) = makecs(sreg); hreg += arity + 1; new_heap_functor(sreg, psc); for (j = 1; j <= arity; j++) { new_heap_free(sreg); cell_array1[arity-j] = cell(sreg-1); } build_subgoal_args(subgoal); }else{ follow(oldhreg++) = makestring(get_name(psc)); } follow(oldhreg) = makelist(hreg); new_heap_free(hreg); new_heap_free(hreg); } } while (hashtable1_iterator_advance(itr)); } if (count>0) follow(oldhreg) = makenil; else reg[4] = makenil; }else{ xsb_warn("Called with non-incremental predicate\n"); reg[4] = makenil; } // printterm(stdout,call_list,100); return unify(CTXTc reg_term(CTXTc 3),reg_term(CTXTc 4)); }
int compare(CTXTdeclc const void * v1, const void * v2) { int comp; CPtr cptr1, cptr2; Cell val1 = (Cell) v1 ; Cell val2 = (Cell) v2 ; XSB_Deref(val2); /* val2 is not in register! */ XSB_Deref(val1); /* val1 is not in register! */ if (val1 == val2) return 0; switch(cell_tag(val1)) { case XSB_FREE: case XSB_REF1: if (isattv(val2)) return vptr(val1) - (CPtr)dec_addr(val2); else if (isnonvar(val2)) return -1; else { /* in case there exist local stack variables in the */ /* comparison, globalize them to guarantee that their */ /* order is retained as long as nobody "touches" them */ /* in the future -- without copying garbage collection */ if ((top_of_localstk <= vptr(val1)) && (vptr(val1) <= (CPtr)glstack.high-1)) { bld_free(hreg); bind_ref(vptr(val1), hreg); hreg++; val1 = follow(val1); /* deref again */ } if ((top_of_localstk <= vptr(val2)) && (vptr(val2) <= (CPtr)glstack.high-1)) { bld_free(hreg); bind_ref(vptr(val2), hreg); hreg++; val2 = follow(val2); /* deref again */ } return vptr(val1) - vptr(val2); } case XSB_FLOAT: if (isref(val2) || isattv(val2)) return 1; else if (isofloat(val2)) return sign(float_val(val1) - ofloat_val(val2)); else return -1; case XSB_INT: if (isref(val2) || isofloat(val2) || isattv(val2)) return 1; else if (isinteger(val2)) return int_val(val1) - int_val(val2); else if (isboxedinteger(val2)) return int_val(val1) - boxedint_val(val2); else return -1; case XSB_STRING: if (isref(val2) || isofloat(val2) || isinteger(val2) || isattv(val2)) return 1; else if (isstring(val2)) { return strcmp(string_val(val1), string_val(val2)); } else return -1; case XSB_STRUCT: // below, first 2 if-checks test to see if this struct is actually a number representation, // (boxed float or boxed int) and if so, does what the number case would do, only with boxed_val // macros. if (isboxedinteger(val1)) { if (isref(val2) || isofloat(val2) || isattv(val2)) return 1; else if (isinteger(val2)) return boxedint_val(val1) - int_val(val2); else if (isboxedinteger(val2)) return boxedint_val(val1) - boxedint_val(val2); else return -1; } else if (isboxedfloat(val1)) { if (isref(val2) || isattv(val2)) return 1; else if (isofloat(val2)) return sign(boxedfloat_val(val1) - ofloat_val(val2)); else return -1; } else if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1; else { int arity1, arity2; Psc ptr1 = get_str_psc(val1); Psc ptr2 = get_str_psc(val2); arity1 = get_arity(ptr1); if (islist(val2)) arity2 = 2; else arity2 = get_arity(ptr2); if (arity1 != arity2) return arity1-arity2; if (islist(val2)) comp = strcmp(get_name(ptr1), "."); else comp = strcmp(get_name(ptr1), get_name(ptr2)); if (comp || (arity1 == 0)) return comp; cptr1 = clref_val(val1); cptr2 = clref_val(val2); for (arity2 = 1; arity2 <= arity1; arity2++) { if (islist(val2)) comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2-1)); else comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2)); if (comp) break; } return comp; } break; case XSB_LIST: if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1; else if (isconstr(val2)) return -(compare(CTXTc (void*)val2, (void*)val1)); else { /* Here we are comparing two list structures. */ cptr1 = clref_val(val1); cptr2 = clref_val(val2); comp = compare(CTXTc (void*)cell(cptr1), (void*)cell(cptr2)); if (comp) return comp; return compare(CTXTc (void*)cell(cptr1+1), (void*)cell(cptr2+1)); } break; case XSB_ATTV: if (isattv(val2)) return (CPtr)dec_addr(val1) - (CPtr)dec_addr(val2); else if (isref(val2)) return (CPtr)dec_addr(val1) - vptr(val2); else return -1; default: xsb_abort("Compare (unknown tag %ld); returning 0", cell_tag(val1)); return 0; } }