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 */
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 */
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 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);*/
}
/*
* Get the PSC for intern/1, a generic functor for storing in the roots
* of interned tries.
*/
Psc get_intern_psc() {
Pair intern_handle;
int new_indicator;
intern_handle = insert("intern", 1, global_mod, &new_indicator);
return (pair_psc(intern_handle));
}
/*
* Create a PSC-PAIR record, set it to point to a PSC record, and place
* it at the head of a PSC-PAIR record chain.
*/
static Pair make_psc_pair(Psc psc_ptr, Pair *link_ptr) {
Pair new_pair;
new_pair = (Pair)mem_alloc(sizeof(struct psc_pair));
pair_psc(new_pair) = psc_ptr; /* set 1st to point to psc_rec */
pair_next(new_pair) = *link_ptr; /* set 2nd to old head */
*link_ptr = new_pair; /* new symbol is in the head! */
return new_pair;
}
/*
* Get the PSC for ret/n. If it already exists, just return it. Or
* create one and save it in ret_psc[n].
*/
Psc get_ret_psc(int n)
{
Pair temp;
int new_indicator;
if (!ret_psc[n]) {
temp = (Pair) insert("ret", (byte) n, global_mod, &new_indicator);
ret_psc[n] = pair_psc(temp);
}
return ret_psc[n];
}
/*
* Create a PSC-PAIR record, set it to point to a PSC record, and place
* it at the head of a PSC-PAIR record chain.
*/
static Pair make_psc_pair(Psc psc_ptr, Pair *link_ptr) {
Pair new_pair;
new_pair = (Pair)mem_alloc(sizeof(struct psc_pair),ATOM_SPACE);
// printf("new_psc_pair %d, prev %d\n",(int)new_pair, (int)*link_ptr);
pair_psc(new_pair) = psc_ptr; /* set 1st to point to psc_rec */
pair_next(new_pair) = *link_ptr; /* set 2nd to old head */
*link_ptr = new_pair; /* new symbol is in the head! */
return new_pair;
}