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;
}
}
