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;
}
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));
}
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 add_interrupt(CTXTdeclc Cell op1, Cell op2) {
Cell head, tail, temp;
CPtr addr_head, addr_tail;
addr_head = (CPtr)glstack.low;
head = cell(addr_head); // addr of interrupt list
addr_tail = (CPtr)glstack.low+1;
tail = cell(addr_tail); // addr of last cons cell of interrupt list
// Build the new list cons pair and the new op-pair cons
// This record is 4 words long and so INT_REC_SIZE=4
bld_list(&temp,hreg); // temp -> new cons pair 1
bld_list(hreg,hreg+2); // 1.car -> 2nd new cons pair 2
hreg++;
bld_free(hreg); // 1.cdr is free var
hreg++;
bld_copy(hreg,op1); // 2.car is op1
hreg++;
bld_copy(hreg,op2); // 2.cdr is op2
hreg++;
if (isnonvar(head)) { // nonempty
CPtr addr_cdr;
addr_cdr = clref_val(tail)+1;
bind_copy(addr_cdr,temp);
push_pre_image_trail(addr_tail,temp);
bld_copy(addr_tail,temp);
} else { // first
bind_copy(addr_head,temp);
bind_copy(addr_tail,temp);
}
}
static DL intern_delay_list(CPtr dlist) /* assumes that dlist != NULL */
{
DE head = NULL, de;
DL dl = NULL;
while (islist(dlist)) {
dlist = clref_val(dlist);
if ((de = intern_delay_element(cell(dlist))) != NULL) {
de_next(de) = head;
head = de;
}
dlist = (CPtr) cell(dlist+1);
}
if (head) {
new_entry(dl,
released_dls,
next_free_dl,
current_dl_block,
current_dl_block_top,
dl_next,
DL,
dl_block_size,
"Not enough memory to expand DL space");
dl_de_list(dl) = head;
dl_asl(dl) = NULL;
return dl;
}
else return NULL;
}
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;
}
Cell build_interrupt_chain(CTXTdecl) {
Cell head, tail;
CPtr addr_head, addr_tail;
addr_tail = (CPtr)glstack.low+1;
tail = cell(addr_tail); // addr of last cons cell of interrupt list
bind_nil(clref_val(tail)+1); // close the tail
addr_head = (CPtr)glstack.low;
head = cell(addr_head);
// set intlist back to empty;
push_pre_image_trail(addr_head,addr_head);
bld_free(addr_head);
push_pre_image_trail(addr_tail,addr_tail);
bld_free(addr_tail);
return(head); // addr of interrupt list
}
xsbBool answer_is_junk(CPtr dlist) /* assumes that dlist != NULL */
{
CPtr cptr;
VariantSF subgoal;
NODEptr ans_subst;
Cell tmp_cell;
while (islist(dlist)) {
dlist = clref_val(dlist);
cptr = (CPtr) cs_val(cell(dlist));
tmp_cell = cell(cptr + 1);
subgoal = (VariantSF) addr_val(tmp_cell);
tmp_cell = cell(cptr + 2);
ans_subst = (NODEptr) addr_val(tmp_cell);
if (is_failing_delay_element(subgoal,ans_subst)) {
return TRUE;
}
dlist = (CPtr) cell(dlist+1);
}
return FALSE;
}
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"); */
}
xsbBool glstack_realloc(CTXTdeclc size_t new_size, int arity)
{
CPtr new_heap_bot=NULL ; /* bottom of new Global Stack area */
CPtr new_ls_bot ; /* bottom of new Local Stack area */
size_t heap_offset ; /* offsets between the old and new */
size_t local_offset ; /* stack bottoms, measured in Cells */
CPtr *cell_ptr ;
Cell cell_val ;
size_t i, rnum_in_trieinstr_unif_stk = (trieinstr_unif_stkptr-trieinstr_unif_stk)+1;
size_t new_size_in_bytes, new_size_in_cells ; /* what a mess ! */
double expandtime ;
if (new_size <= glstack.size) { // asked to shrink
// new_size is space needed + half of init_size, rounded to K
new_size = (((glstack.high - (byte *)top_of_localstk) +
((byte *)hreg - glstack.low)) + glstack.init_size*K/2 + (K-1)) / K;
// but not smaller than init_size
if (new_size < glstack.init_size) new_size = glstack.init_size;
if (new_size >= glstack.size) return 0; // computed new_size won't shrink
// printf("shrinking glstack from %dK to %dK\n",glstack.size,new_size);
}
// fprintf(stddbg,"Reallocating the Heap and Local Stack data area");
#ifdef DEBUG_VERBOSE
if (LOG_REALLOC <= cur_log_level) {
if (glstack.size == glstack.init_size) {
xsb_dbgmsg((LOG_REALLOC,"\tBottom:\t\t%p\t\tInitial Size: %" Intfmt "K",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tTop:\t\t%p", glstack.high));
}
}
#endif
expandtime = cpu_time();
new_size_in_bytes = new_size*K ;
new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
/* and let's hope K stays divisible by sizeof(Cell) */
stack_boundaries ;
/* Expand the data area and push the Local Stack to the high end. */
if (new_size < glstack.size) { //shrinking
// move local stack down
memmove(glstack.low + new_size_in_bytes-(glstack.high-(byte *)ls_top), // to
ls_top, // from
glstack.high - (byte *)ls_top // size
);
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
heap_offset = new_heap_bot - heap_bot ;
new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
local_offset = new_ls_bot - ls_bot ;
} else { // expanding
if (!USER_MEMORY_LIMIT_EXHAUSTED(new_size))
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
if (new_heap_bot == NULL) {
if (2*glstack.size == new_size) { /* if trying to double, try backing off, may not help */
size_t increment = new_size;
while (new_heap_bot == NULL && increment > 40) {
increment = increment/2;
new_size = glstack.size + increment;
new_size_in_bytes = new_size*K ;
new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
if (!USER_MEMORY_LIMIT_EXHAUSTED(new_size))
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
}
if (new_heap_bot == NULL) {
// xsb_mesg("Not enough core to resize the Heap/Local Stack! (current: %"Intfmt"; resize %"Intfmt")",
// glstack.size*K,new_size_in_bytes);
return 1; /* return an error output -- will be picked up later */
}
} else {
xsb_mesg("Not enough core to resize the Heap and Local Stack! (%" Intfmt ")",new_size_in_bytes);
return 1; /* return an error output -- will be picked up later */
}
}
// printf("realloced heap %d -> %d\n",glstack.size,new_size);
heap_offset = new_heap_bot - heap_bot ;
new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
local_offset = new_ls_bot - ls_bot ;
#if defined(GENERAL_TAGGING)
// printf("glstack expand %p %p\n",(void *)new_heap_bot,(void *)new_ls_bot+1);
extend_enc_dec_as_nec(new_heap_bot,new_ls_bot+1);
#endif
memmove(ls_top + local_offset, /* move to */
ls_top + heap_offset, /* move from */
(ls_bot - ls_top + 1)*sizeof(Cell) ); /* number of bytes */
}
initialize_glstack(heap_top + heap_offset,ls_top+local_offset);
/* TLS: below, the condition should not need to be commented out.
If the heap expands, there should be no pointers from heap into
the local stack, so we shouldnt need to traverse the heap.
However, call subumption code actually copies the substitution
factor from the CPS to heap (I dont know why, but see the comment
after the call to subsumptive_call_search() in slginsts_xsb_i.h),
so that substitution factor pointers may point from the heap to
local stack. Therefore the pointer update causes the heap-ls
pointers to be harmless at glstack expansion.
*/
/* Update the Heap links */
// if (heap_offset != 0) {
for (cell_ptr = (CPtr *)(heap_top + heap_offset);
cell_ptr-- > (CPtr *)new_heap_bot;
)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
// }
/* Update the pointers in the Local Stack */
for (cell_ptr = (CPtr *)(ls_top + local_offset);
cell_ptr <= (CPtr *)new_ls_bot;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the trailed variable pointers */
for (cell_ptr = (CPtr *)top_of_trail - 1;
cell_ptr > (CPtr *)tcpstack.low;
cell_ptr = cell_ptr - 2)
{ /* first the value */
reallocate_heap_or_ls_pointer(cell_ptr);
/* now the address */
cell_ptr-- ;
cell_val = (Cell)*cell_ptr ;
#ifdef PRE_IMAGE_TRAIL
if ((size_t) cell_val & PRE_IMAGE_MARK) {
/* remove tag */
cell_val = (Cell) ((Cell) cell_val & ~PRE_IMAGE_MARK);
/* realloc and tag */
realloc_ref_pre_image(cell_ptr,(CPtr)cell_val) ;
cell_ptr--;
/* realoc pre-image */
reallocate_heap_or_ls_pointer(cell_ptr);
} else
#endif
realloc_ref(cell_ptr,(CPtr)cell_val) ;
}
/* Update the CP Stack pointers */
for (cell_ptr = (CPtr *)top_of_cpstack;
cell_ptr < (CPtr *)tcpstack.high;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the argument registers */
while (arity)
{ cell_ptr = (CPtr *)(reg+arity) ;
reallocate_heap_or_ls_pointer(cell_ptr) ;
arity-- ;
}
i = 0;
while (i < rnum_in_trieinstr_unif_stk) {
cell_ptr = (CPtr *)(trieinstr_unif_stk+i);
// printf(" reallocate trieinstr_unif_stk[%d]=%p\n",i,cell_ptr);
reallocate_heap_or_ls_pointer(cell_ptr) ;
i++;
}
/* Update the system variables */
glstack.low = (byte *)new_heap_bot ;
glstack.high = (byte *)(new_ls_bot + 1) ;
pspace_tot_gl = pspace_tot_gl + (new_size - glstack.size)*K;
glstack.size = new_size ;
hreg = (CPtr)hreg + heap_offset ;
hbreg = (CPtr)hbreg + heap_offset ;
hfreg = (CPtr)hfreg + heap_offset ;
ereg = (CPtr)ereg + local_offset ;
ebreg = (CPtr)ebreg + local_offset ;
efreg = (CPtr)efreg + local_offset ;
if (islist(delayreg))
delayreg = (CPtr)makelist(clref_val(delayreg) + heap_offset);
expandtime = cpu_time() - expandtime;
xsb_dbgmsg((LOG_REALLOC,"\tNew Bottom:\t%p\t\tNew Size: %" Intfmt "K",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tNew Top:\t%p", glstack.high));
xsb_dbgmsg((LOG_REALLOC,
"Heap/Local Stack data area expansion - finished in %lf secs\n",
expandtime));
return 0;
} /* glstack_realloc */
/* 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;
}
xsbBool glstack_realloc(int new_size, int arity)
{
CPtr new_heap_bot ; /* bottom of new Global Stack area */
CPtr new_ls_bot ; /* bottom of new Local Stack area */
long heap_offset ; /* offsets between the old and new */
long local_offset ; /* stack bottoms, measured in Cells */
CPtr *cell_ptr ;
Cell cell_val ;
size_t new_size_in_bytes, new_size_in_cells ; /* what a mess ! */
long expandtime ;
if (new_size <= glstack.size) return 0;
xsb_dbgmsg((LOG_REALLOC,
"Reallocating the Heap and Local Stack data area"));
#ifdef DEBUG_VERBOSE
if (LOG_REALLOC <= cur_log_level) {
if (glstack.size == glstack.init_size) {
xsb_dbgmsg((LOG_REALLOC,"\tBottom:\t\t%p\t\tInitial Size: %ldK",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tTop:\t\t%p", glstack.high));
}
}
#endif
expandtime = (long)(1000*cpu_time()) ;
new_size_in_bytes = new_size*K ;
new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
/* and let's hope K stays divisible by sizeof(Cell) */
stack_boundaries ;
/* Expand the data area and push the Local Stack to the high end. */
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
if (new_heap_bot == NULL) {
xsb_mesg("Not enough core to resize the Heap and Local Stack!");
return 1; /* return an error output -- will be picked up later */
}
heap_offset = new_heap_bot - heap_bot ;
new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
local_offset = new_ls_bot - ls_bot ;
memmove(ls_top + local_offset, /* move to */
ls_top + heap_offset, /* move from */
(ls_bot - ls_top + 1)*sizeof(Cell) ); /* number of bytes */
/* Update the Heap links */
for (cell_ptr = (CPtr *)(heap_top + heap_offset);
cell_ptr-- > (CPtr *)new_heap_bot;
)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the pointers in the Local Stack */
for (cell_ptr = (CPtr *)(ls_top + local_offset);
cell_ptr <= (CPtr *)new_ls_bot;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the trailed variable pointers */
for (cell_ptr = (CPtr *)top_of_trail - 1;
cell_ptr > (CPtr *)tcpstack.low;
cell_ptr = cell_ptr - 2)
{ /* first the value */
reallocate_heap_or_ls_pointer(cell_ptr);
/* now the address */
cell_ptr-- ;
cell_val = (Cell)*cell_ptr ;
realloc_ref(cell_ptr,(CPtr)cell_val) ;
}
/* Update the CP Stack pointers */
for (cell_ptr = (CPtr *)top_of_cpstack;
cell_ptr < (CPtr *)tcpstack.high;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the argument registers */
while (arity)
{ cell_ptr = (CPtr *)(reg+arity) ;
reallocate_heap_or_ls_pointer(cell_ptr) ;
arity-- ;
}
/* Update the system variables */
glstack.low = (byte *)new_heap_bot ;
glstack.high = (byte *)(new_ls_bot + 1) ;
glstack.size = new_size ;
hreg = (CPtr)hreg + heap_offset ;
hbreg = (CPtr)hbreg + heap_offset ;
hfreg = (CPtr)hfreg + heap_offset ;
ereg = (CPtr)ereg + local_offset ;
ebreg = (CPtr)ebreg + local_offset ;
efreg = (CPtr)efreg + local_offset ;
if (islist(delayreg))
delayreg = (CPtr)makelist(clref_val(delayreg) + heap_offset);
expandtime = (long)(1000*cpu_time()) - expandtime;
xsb_dbgmsg((LOG_REALLOC,"\tNew Bottom:\t%p\t\tNew Size: %ldK",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tNew Top:\t%p", glstack.high));
xsb_dbgmsg((LOG_REALLOC,
"Heap/Local Stack data area expansion - finished in %ld msecs\n",
expandtime));
return 0;
} /* glstack_realloc */
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;
}
}
/*-----------------------------------------------------------------------------*/
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;
}