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 key_compare(CTXTdeclc const void * t1, const void * t2) { Cell term1 = (Cell) t1 ; Cell term2 = (Cell) t2 ; XSB_Deref(term1); /* term1 is not in register! */ XSB_Deref(term2); /* term2 is not in register! */ return compare(CTXTc (void*)cell(clref_val(term1)+1), (void*)cell(clref_val(term2)+1)); }
/* 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 in_reg2_list(CTXTdeclc Psc psc) { Cell list,term; list = reg[2]; XSB_Deref(list); if (isnil(list)) return TRUE; /* if filter is empty, return all */ while (!isnil(list)) { term = get_list_head(list); XSB_Deref(term); if (isconstr(term)) { if (psc == get_str_psc(term)) return TRUE; } else if (isstring(term)) { if (get_name(psc) == string_val(term)) return TRUE; } list = get_list_tail(list); } return FALSE; }
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; }
int get_incr_sccs(CTXTdeclc Cell listterm) { Cell orig_listterm, intterm, node; long int node_num=0; int i = 0, dfn, component = 1; int * dfn_stack; int dfn_top = 0, ret; SCCNode * nodes; struct hashtable_itr *itr; struct hashtable* hasht; XSB_Deref(listterm); hasht = create_hashtable1(HASH_TABLE_SIZE, hashid, equalkeys); orig_listterm = listterm; intterm = get_list_head(listterm); XSB_Deref(intterm); // printf("listptr %p @%p\n",listptr,(CPtr) int_val(*listptr)); insert_some(hasht,(void *) oint_val(intterm),(void *) node_num); node_num++; listterm = get_list_tail(listterm); XSB_Deref(listterm); while (!isnil(listterm)) { intterm = get_list_head(listterm); XSB_Deref(intterm); node = oint_val(intterm); if (NULL == search_some(hasht, (void *)node)) { insert_some(hasht,(void *)node,(void *)node_num); node_num++; } listterm = get_list_tail(listterm); XSB_Deref(listterm); } nodes = (SCCNode *) mem_calloc(node_num, sizeof(SCCNode),OTHER_SPACE); dfn_stack = (int *) mem_alloc(node_num*sizeof(int),OTHER_SPACE); listterm = orig_listterm;; //printf("listptr %p @%p\n",listptr,(void *)int_val(*(listptr))); intterm = get_list_head(listterm); XSB_Deref(intterm); nodes[0].node = (CPtr) oint_val(intterm); listterm = get_list_tail(listterm); XSB_Deref(listterm); i = 1; while (!isnil(listterm)) { intterm = get_list_head(listterm); XSB_Deref(intterm); node = oint_val(intterm); nodes[i].node = (CPtr) node; listterm = get_list_tail(listterm); XSB_Deref(listterm); i++; } itr = hashtable1_iterator(hasht); SQUASH_LINUX_COMPILER_WARN(itr); // do { // printf("k %p val %p\n",hashtable1_iterator_key(itr),hashtable1_iterator_value(itr)); // } while (hashtable1_iterator_advance(itr)); listterm = orig_listterm; // printf("2: k %p v %p\n",(void *) int_val(*listptr), // search_some(hasht,(void *) int_val(*listptr))); // while (!isnil(*listptr)) { now all wrong... // listptr = listptr + 1; // node = int_val(*clref_val(listptr)); // printf("2: k %p v %p\n",(CPtr) node,search_some(hasht,(void *) node)); // listptr = listptr + 1; // } dfn = 1; for (i = 0; i < node_num; i++) { if (nodes[i].dfn == 0) xsb_compute_scc(nodes,dfn_stack,i,&dfn_top,hasht,&dfn,&component); // printf("++component for node %d is %d (high %d)\n",i,nodes[i].component,component); } ret = return_scc_list(CTXTc nodes, node_num); hashtable1_destroy(hasht,0); mem_dealloc(nodes,node_num*sizeof(SCCNode),OTHER_SPACE); mem_dealloc(dfn_stack,node_num*sizeof(int),OTHER_SPACE); return ret; }
/* 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; } }
/*-----------------------------------------------------------------------------*/ void ODBCDataSources() { static SQLCHAR DSN[SQL_MAX_DSN_LENGTH+1]; static SQLCHAR Description[SQL_MAX_DSN_LENGTH+1]; RETCODE rc; int seq; SWORD dsn_size, descr_size; Cell op2 = ptoc_tag(3); Cell op3 = ptoc_tag(4); if (!henv) { /* allocate environment handler*/ rc = SQLAllocEnv(&henv); if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) { xsb_error("Environment allocation failed"); ctop_int(5,1); return; } LCursor = FCursor = NULL; FCurNum = NULL; nullStrAtom = makestring(string_find("NULL",1)); } seq = ptoc_int(2); if (seq == 1) { rc = SQLDataSources(henv,SQL_FETCH_FIRST,DSN, SQL_MAX_DSN_LENGTH,&dsn_size, Description,SQL_MAX_DSN_LENGTH, &descr_size); if (rc == SQL_NO_DATA_FOUND) { ctop_int(5,2); return; } if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) { xsb_error("Environment allocation failed"); ctop_int(5,1); return; } } else { rc = SQLDataSources(henv,SQL_FETCH_NEXT,DSN, SQL_MAX_DSN_LENGTH,&dsn_size, Description,SQL_MAX_DSN_LENGTH, &descr_size); if (rc == SQL_NO_DATA_FOUND) { ctop_int(5,2); return; } if (rc != SQL_SUCCESS && rc != SQL_SUCCESS_WITH_INFO) { xsb_error("Environment allocation failed"); ctop_int(5,1); return; } } XSB_Deref(op2); if (isref(op2)) unify(op2, makestring(string_find(DSN,1))); else { xsb_error("[ODBCDataSources] Param 2 should be a free variable."); ctop_int(5,1); return; } XSB_Deref(op3); if (isref(op3)) unify(op3, makestring(string_find(Description,1))); else { xsb_error("[ODBCDataSources] Param 3 should be a free variable."); ctop_int(5,1); return; } ctop_int(5,0); return; }
/*-----------------------------------------------------------------------------*/ int GetColumn() { struct Cursor *cur = (struct Cursor *)ptoc_int(2); int ColCurNum = ptoc_int(3); Cell op1; Cell op = ptoc_tag(4); UDWORD len; if (ColCurNum < 0 || ColCurNum >= cur->NumCols) { /* no more columns in the result row*/ ctop_int(5,1); return TRUE; } ctop_int(5,0); /* get the data*/ if (cur->OutLen[ColCurNum] == SQL_NULL_DATA) { /* column value is NULL*/ return unify(op,nullStrAtom); } /* convert the string to either integer, float or string*/ /* according to the column type and pass it back to XSB*/ switch (ODBCToXSBType(cur->ColTypes[ColCurNum])) { case SQL_C_CHAR: /* convert the column string to a C string */ len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])? cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]); *(cur->Data[ColCurNum]+len) = '\0'; /* compare strings here, so don't intern strings unnecessarily*/ XSB_Deref(op); if (isref(op)) return unify(op, makestring(string_find(cur->Data[ColCurNum],1))); if (isconstr(op) && get_arity(get_str_psc(op)) == 1) { STRFILE strfile; op1 = cell(clref_val(op)+1); XSB_Deref(op1); strfile.strcnt = strlen(cur->Data[ColCurNum]); strfile.strptr = strfile.strbase = cur->Data[ColCurNum]; read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */ return TRUE; } if (!isstring(op)) return FALSE; if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE; return TRUE; case SQL_C_BINARY: /* convert the column string to a C string */ len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])? cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]); *(cur->Data[ColCurNum]+len) = '\0'; /* compare strings here, so don't intern strings unnecessarily*/ XSB_Deref(op); if (isref(op)) return unify(op, makestring(string_find(cur->Data[ColCurNum],1))); if (isconstr(op) && get_arity(get_str_psc(op)) == 1) { STRFILE strfile; op1 = cell(clref_val(op)+1); XSB_Deref(op1); strfile.strcnt = strlen(cur->Data[ColCurNum]); strfile.strptr = strfile.strbase = cur->Data[ColCurNum]; read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */ return TRUE; } if (!isstring(op)) return FALSE; if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE; return TRUE; case SQL_C_SLONG: return unify(op,makeint(*(long *)(cur->Data[ColCurNum]))); case SQL_C_FLOAT: return unify(op,makefloat(*(float *)(cur->Data[ColCurNum]))); } return FALSE; }