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