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;
}
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;
}
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;
}
/* 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;
}
/* 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;
}
/* 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;
}
}
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;
}
/*-----------------------------------------------------------------------------*/
void SetBindVal()
{
RETCODE rc;
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
int j = ptoc_int(3);
Cell BindVal = ptoc_tag(4);
if (!((j >= 0) && (j < cur->NumBindVars)))
xsb_exit("Abnormal argument in SetBindVal!");
/* if we're reusing an opened cursor w/ the statement number*/
/* reallocate BindVar if type has changed (May not be such a good idea?)*/
if (cur->Status == 2) {
if (isinteger(BindVal)) {
if (cur->BindTypes[j] != 0) {
if (cur->BindTypes[j] != 2) free((void *)cur->BindList[j]);
cur->BindList[j] = (UCHAR *)malloc(sizeof(int));
cur->BindTypes[j] = 0;
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT,
SQL_C_SLONG, SQL_INTEGER,
0, 0, (int *)(cur->BindList[j]), 0, NULL);
if (rc != SQL_SUCCESS) {
ctop_int(5,PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
}
*((int *)cur->BindList[j]) = oint_val(BindVal);
} else if (isfloat(BindVal)) {
if (cur->BindTypes[j] != 1) {
/*printf("ODBC: Changing Type: flt to %d\n",cur->BindTypes[j]);*/
if (cur->BindTypes[j] != 2) free((void *)cur->BindList[j]);
cur->BindList[j] = (UCHAR *)malloc(sizeof(float));
cur->BindTypes[j] = 1;
rc = SQLBindParameter(cur->hstmt, (short)(j+1), SQL_PARAM_INPUT,
SQL_C_FLOAT, SQL_FLOAT,
0, 0, (float *)(cur->BindList[j]), 0, NULL);
if (rc != SQL_SUCCESS) {
ctop_int(5,PrintErrorMsg(cur));
SetCursorClose(cur);
return;
}
}
*((float *)cur->BindList[j]) = (float)float_val(BindVal);
} else if (isstring(BindVal)) {
if (cur->BindTypes[j] != 2) {
/*printf("ODBC: Changing Type: str to %d\n",cur->BindTypes[j]);*/
free((void *)cur->BindList[j]);
cur->BindTypes[j] = 2;
/* SQLBindParameter will be done anyway*/
}
cur->BindList[j] = string_val(BindVal);
} else if (isconstr(BindVal) && get_arity(get_str_psc(BindVal))==1) {
letter_flag = 1;
wcan_disp = 0;
write_canonical_term(p2p_arg(BindVal,1));
if (term_string[j]) free(term_string[j]);
term_string[j] = malloc(wcan_disp+1);
strncpy(term_string[j],wcan_string,wcan_disp);
term_string[j][wcan_disp] = '\0';
cur->BindTypes[j] = 2;
cur->BindList[j] = term_string[j];
} else {
xsb_exit("Unknown bind variable type, %d", cur->BindTypes[j]);
}
ctop_int(5,0);
return;
}
/* otherwise, memory needs to be allocated in this case*/
if (isinteger(BindVal)) {
cur->BindTypes[j] = 0;
cur->BindList[j] = (UCHAR *)malloc(sizeof(int));
if (!cur->BindList[j])
xsb_exit("Not enough memory for an int in SetBindVal!");
*((int *)cur->BindList[j]) = oint_val(BindVal);
} else if (isfloat(BindVal)) {
cur->BindTypes[j] = 1;
cur->BindList[j] = (UCHAR *)malloc(sizeof(float));
if (!cur->BindList[j])
xsb_exit("Not enough memory for a float in SetBindVal!");
*((float *)cur->BindList[j]) = (float)float_val(BindVal);
} else if (isstring(BindVal)) {
cur->BindTypes[j] = 2;
cur->BindList[j] = string_val(BindVal);
} else if (isconstr(BindVal) && get_arity(get_str_psc(BindVal))==1) {
letter_flag = 1;
wcan_disp = 0;
write_canonical_term(p2p_arg(BindVal,1));
if (term_string[j]) free(term_string[j]);
term_string[j] = malloc(wcan_disp+1);
strncpy(term_string[j],wcan_string,wcan_disp);
term_string[j][wcan_disp] = '\0';
cur->BindTypes[j] = 2;
cur->BindList[j] = term_string[j];
} else {
xsb_exit("Unknown bind variable type, %d", cur->BindTypes[j]);
}
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;
}
