/*
Input:
Arg1: +Substr
Arg2: + String
Arg3: +forward/reverse (checks only f/r)
f means the first match from the start of String
r means the first match from the end of String
Output:
Arg4: Beg
Beg is the offset where Substr matches. Must be a variable or an
integer
Arg5: End
End is the offset of the next character after the end of Substr
Must be a variable or an integer.
Both Beg and End can be negative, in which case they represent the offset
from the 2nd character past the end of String.
For instance, -1 means the next character past the end of String,
so End = -1 means that Substr must be a suffix of String..
The meaning of End and of negative offsets is consistent with substring
and string_substitute predicates.
*/
xsbBool str_match(CTXTdecl)
{
static char *subptr, *stringptr, *direction, *matchptr;
static size_t substr_beg, substr_end;
int reverse=TRUE; /* search in reverse */
int beg_bos_offset=TRUE; /* measure beg offset from the beg of string */
int end_bos_offset=TRUE; /* measure end offset from the beg of string */
Integer str_len, sub_len; /* length of string and substring */
Cell beg_offset_term, end_offset_term;
term = ptoc_tag(CTXTc 1);
term2 = ptoc_tag(CTXTc 2);
term3 = ptoc_tag(CTXTc 3);
beg_offset_term = ptoc_tag(CTXTc 4);
end_offset_term = ptoc_tag(CTXTc 5);
if (!isatom(term) || !isatom(term2) || !isatom(term3)) {
xsb_abort("STR_MATCH: Arguments 1,2,3 must be bound to strings");
}
subptr = string_val(term);
stringptr = string_val(term2);
direction = string_val(term3);
if (*direction == 'f')
reverse=FALSE;
else if (*direction != 'r')
xsb_abort("STR_MATCH: Argument 3 must be bound to forward/reverse");
str_len=strlen(stringptr);
sub_len=strlen(subptr);
if (isointeger(beg_offset_term)) {
if (oint_val(beg_offset_term) < 0) {
beg_bos_offset = FALSE;
}
}
if (isointeger(end_offset_term)) {
if (oint_val(end_offset_term) < 0) {
end_bos_offset = FALSE;
}
}
if (reverse)
matchptr = xsb_strrstr(stringptr, subptr);
else
matchptr = strstr(stringptr, subptr);
if (matchptr == NULL) return FALSE;
substr_beg = (beg_bos_offset?
matchptr - stringptr : -(str_len - (matchptr - stringptr))
);
substr_end = (end_bos_offset?
(matchptr - stringptr) + sub_len
: -(str_len + 1 - (matchptr - stringptr) - sub_len)
);
return
(p2p_unify(CTXTc beg_offset_term, makeint(substr_beg))
&& p2p_unify(CTXTc end_offset_term, makeint(substr_end)));
}
/**
* Translates from the XSB-defined value for a socket domains
* specified by xsb_domain to system-specific value for that socket
* domains and stores this system-specific value in socket_domain.
* Returns TRUE if the conversion was successful, FALSE otherwise.
*/
static int translate_domain(int xsb_domain, int *socket_domain) {
if (xsb_domain == 0) {
*socket_domain = AF_INET;
return TRUE;
} else if (xsb_domain == 1) {
*socket_domain = AF_UNIX;
xsb_abort("[SOCKET_REQUEST] domain AF_INET is not implemented");
return TRUE;
} else {
xsb_abort("[SOCKET_REQUEST] Invalid domain (%d). Valid domains are: 0 - AF_INET, 1 - AF_UNIX", xsb_domain);
return FALSE;
}
}
static int xsb_re_match(char *regexp_ptr, char *match_str, int flags,
regmatch_t **match_array, int *paren_number,
char *context)
{
static regmatch_t matches[NMATCH]; /* the array where matches are stored */
regex_t *compiled_re;
int idx, err_code;
char err_msg[ERR_MSG_LEN];
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
*match_array = matches;
idx = hash(regexp_ptr, 1, REGEXP_TBL_SIZE);
/* we employ a very simple heuristic: either regexp is in the cell pointed to
by hash or we replace what's in that cell with the current regexp.
Probability of collision is low and the cost of replacement is low as
well. */
compiled_re = ®exp_tbl[idx].compiled;
if ((regexp_tbl[idx].original == NULL)
|| (0 != strcmp(regexp_ptr, regexp_tbl[idx].original))
|| (regexp_tbl[idx].flags != flags)
) {
/* need to recompile regexp */
regexp_tbl[idx].original = regexp_ptr;
regexp_tbl[idx].flags = flags;
if (0 == (err_code = regcomp(®exp_tbl[idx].compiled,regexp_ptr,flags)))
regexp_tbl[idx].original = regexp_ptr;
else {
regexp_tbl[idx].original = NULL;
regerror(err_code, compiled_re, err_msg, ERR_MSG_LEN);
xsb_abort("[%s] %s", context, err_msg);
}
}
*paren_number = compiled_re->re_nsub;
err_code = regexec(®exp_tbl[idx].compiled, match_str, NMATCH, matches, 0);
/* no match is not an error */
if (err_code == REG_NOMATCH) return FALSE;
if (err_code != 0) {
regerror(err_code, compiled_re, err_msg, ERR_MSG_LEN);
xsb_abort("[%s] %s", context, err_msg);
}
return TRUE;
}
static char *get_host_IP(char *host_name_or_IP) {
struct hostent *host_struct;
struct in_addr *ptr;
char **listptr;
char *error;
/* if host_name_or_IP is an IP addr, then just return; else use
gethostbyname */
if (IS_IP_ADDR(host_name_or_IP))
return(host_name_or_IP);
host_struct = gethostbyname(host_name_or_IP);
if( host_struct == NULL )
{
if( h_errno == HOST_NOT_FOUND )
error = "socket: host not found" ;
else if ( h_errno == NO_ADDRESS || h_errno == NO_DATA )
error = "socket: host doesn't have a valid IP address" ;
else if( h_errno == NO_RECOVERY )
error = "socket: non recoverable error" ;
else if( h_errno == TRY_AGAIN )
error = "socket: temporary error" ;
else
error = "socket: unknown error" ;
xsb_abort( error ) ;
}
listptr = host_struct->h_addr_list;
if ((ptr = (struct in_addr *) *listptr++) != NULL) {
xsb_mesg(" IP address: %s", inet_ntoa(*ptr));
return(inet_ntoa(*ptr));
}
return NULL;
}
/* split STRING at spaces, \t, \n, and put components
in a NULL-terminated array.
Take care of quoted strings and escaped symbols
If you call it twice, the old split is forgotten.
STRING is the string to split
PARAMS is the array of substrings obtained as a result of the split
these params are all sitting in a static variable, buffer.
CALLNAME - the name of the system call. Used in error messages.
*/
static void split_command_arguments(char *string, char *params[], char *callname)
{
size_t buflen = strlen(string);
int idx = 0;
char *buf_ptr, *arg_ptr;
static char buffer[MAX_CMD_LEN];
if (buflen > MAX_CMD_LEN - 1)
xsb_abort("[%s] Command string too long, %s", callname, string);
buf_ptr = buffer;
/* Debugging
fprintf(stderr,"%s\n", string);
*/
do {
arg_ptr = get_next_command_argument(&buf_ptr,&string);
params[idx] = arg_ptr;
/* Debugging
fprintf(stderr,"%s\n", arg_ptr);
*/
idx++;
} while (arg_ptr != NULL && idx <= MAX_SUBPROC_PARAMS);
/* note: params has extra space, so not to worry about <= */
return;
}
void dsExpand(DynamicStack *ds, int num_frames) {
size_t new_size, total_bytes;
char *new_base;
if ( num_frames < 1 )
return;
if ( DynStk_CurSize(*ds) > 0 )
new_size = 2 * DynStk_CurSize(*ds);
else
new_size = DynStk_InitSize(*ds);
if ( new_size < DynStk_CurSize(*ds) + num_frames )
new_size = new_size + num_frames;
xsb_dbgmsg((LOG_TRIE_STACK, "Expanding %s: %d -> %d", DynStk_Name(*ds),
DynStk_CurSize(*ds), new_size));
dbg_dsPrint(LOG_TRIE_STACK, *ds, "Before expansion");
total_bytes = new_size * DynStk_FrameSize(*ds);
new_base = realloc(DynStk_Base(*ds),total_bytes);
if ( IsNULL(new_base) )
xsb_abort("Ran out of memory during expansion of %s", DynStk_Name(*ds));
DynStk_Top(*ds) =
new_base + ((char *)DynStk_Top(*ds) - (char *)DynStk_Base(*ds));
DynStk_Base(*ds) = new_base;
DynStk_Ceiling(*ds) = new_base + total_bytes;
DynStk_CurSize(*ds) = new_size;
dbg_dsPrint(LOG_TRIE_STACK, *ds, "After expansion");
}
void set_xsbinfo_dir () {
struct stat *fileinfo = mem_alloc(1*sizeof(struct stat),LEAK_SPACE);
char old_xinitrc[MAXPATHLEN], new_xinitrc[MAXPATHLEN],
user_config_dir[MAXPATHLEN], user_arch_dir[MAXPATHLEN];
int retcode;
if (!fileinfo) {
xsb_abort("No core memory to allocate stat structure.\n");
}
snprintf(xsbinfo_dir_gl, MAXPATHLEN, "%s%c.xsb", user_home_gl, SLASH);
snprintf(old_xinitrc, MAXPATHLEN, "%s%c.xsbrc", user_home_gl, SLASH);
snprintf(new_xinitrc, MAXPATHLEN, "%s%cxsbrc", xsbinfo_dir_gl, SLASH);
snprintf(user_config_dir, MAXPATHLEN, "%s%cconfig", xsbinfo_dir_gl, SLASH);
snprintf(user_arch_dir, MAXPATHLEN, "%s%c%s", user_config_dir, SLASH, FULL_CONFIG_NAME);
/* Create USER_HOME/.xsb directory, if it doesn't exist. */
check_create_dir(xsbinfo_dir_gl);
check_create_dir(user_config_dir);
check_create_dir(user_arch_dir);
retcode = stat(old_xinitrc, fileinfo);
if ((retcode == 0) && (stat(new_xinitrc, fileinfo) != 0)) {
xsb_warn("It appears that you have an old-style `.xsbrc' file!\n The XSB initialization file is now %s.\n If your `.xinitrc' defines the `library_directory' predicate,\n please consult the XSB manual for the new conventions.", new_xinitrc);
}
mem_dealloc(fileinfo,1*sizeof(struct stat),LEAK_SPACE);
}
/* Check if PATH exists. Create if it doesn't. Bark if it can't create or if
PATH exists, but isn't a directory. */
static void check_create_dir(char *path) {
struct stat *fileinfo = mem_alloc(1*sizeof(struct stat),LEAK_SPACE);
int retcode = stat(path, fileinfo);
if (!fileinfo) {
xsb_abort("No core memory to allocate stat structure.\n");
}
if (retcode == 0 && ! S_ISDIR(fileinfo->st_mode)) {
xsb_warn("File `%s' is not a directory!\n XSB uses this directory to store data.", path);
/* exit(1); */
}
if (retcode != 0)
#ifdef WIN_NT
retcode = mkdir(path);
#else
retcode = mkdir(path, 0755);
#endif
if (retcode != 0) {
xsb_warn("Cannot create directory `%s'!\n XSB uses this directory to store data.", path);
/* exit(1); */
}
mem_dealloc(fileinfo,1*sizeof(struct stat),LEAK_SPACE);
}
STORAGE_HANDLE *storage_builtin(CTXTdeclc int builtin_number, Cell name, prolog_term trie_type)
{
switch (builtin_number) {
case GET_STORAGE_HANDLE:
return get_storage_handle(CTXTc name, trie_type);
case INCREMENT_STORAGE_SNAPSHOT:
return increment_storage_snapshot(CTXTc name);
case MARK_STORAGE_CHANGED:
return mark_storage_changed(CTXTc name);
case DESTROY_STORAGE_HANDLE: {
xsb_dbgmsg((LOG_STORAGE,
"STORAGE_BUILTIN: Destroying storage handle for %s\n",
string_val(name)));
destroy_storage_handle(name);
return NULL;
}
case SHOW_TABLE_STATE: {
show_table_state();
return NULL;
}
default:
xsb_abort("Unknown storage builtin");
return NULL;
}
}
static inline STORAGE_HANDLE *get_storage_handle(CTXTdeclc Cell name, prolog_term trie_type)
{
STORAGE_HANDLE *handle_cell;
handle_cell = find_or_insert_storage_handle(name);
/* new buckets are filled out with 0's by the calloc in hashtable_xsb.c */
if (handle_cell->handle==(Cell)0) {
/* initialize new handle */
xsb_dbgmsg((LOG_STORAGE,
"GET_STORAGE_HANDLE: New trie created for %s\n",
string_val(name)));
if (is_int(trie_type))
handle_cell->handle= newtrie(CTXTc (int)p2c_int(trie_type));
else
xsb_abort("[GET_STORAGE_HANDLE] trie type (3d arg) must be an integer");
/* Note: not necessary to initialize snapshot_number&changed: handle_cell
was calloc()'ed
handle_cell->snapshot_number=0;
handle_cell->changed=FALSE;
*/
}
else
xsb_dbgmsg((LOG_STORAGE,
"GET_STORAGE_HANDLE: Using existing trie for %s\n",
string_val(name)));
return handle_cell;
}
/*----------------------------------------------------------------------------
do_bulk_match__()
The pattern match function which includes loading perl interpreter and
doing the global perl pattern match, and storing the results in the global
array of bulkMatchList.
argument:
input: char* string -- input text
char* pattern -- match pattern
output: int* num_match -- the number of the matches
----------------------------------------------------------------------------*/
int do_bulk_match__( void )
{
AV *match_list; /* AV storage of matches list*/
SV *text; /* storage for the embedded perl cmd */
SV *string_buff; /* storage for the embedded perl cmd */
int num_match; /* the number of the matches */
int i;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* first load the perl interpreter, if unloaded */
if (perlObjectStatus == UNLOADED) load_perl__();
text = newSV(0);
string_buff = newSV(0);
sv_setpv(text, ptoc_string(CTXTc 1)); /*put the string into an SV */
/*------------------------------------------------------------------------
free the old match list space and allocate new space for current match list
-----------------------------------------------------------------------*/
for ( i=0; i<preBulkMatchNumber; i++ )
free(bulkMatchList[i]);
if (bulkMatchList != NULL ) free(bulkMatchList);
bulkMatchList = NULL;
/*------------------------------------------------------------------------
do bulk match
----------------------------------------------------------------------*/
num_match = all_matches(text, ptoc_string(CTXTc 2),&match_list);
/* allocate the space to store the matches */
if ( num_match != 0 ) {
preBulkMatchNumber = num_match; /* reset the pre bulk match number */
bulkMatchList = (char **)malloc(num_match*sizeof(char *));
if ( bulkMatchList == NULL )
xsb_abort("Cannot alocate memory to store the results for bulk match");
}
/*get the matches from the AV */
for ( i=0;i<num_match;i++ ) {
string_buff = av_shift(match_list);
bulkMatchList[i] = (char *)malloc( strlen(SvPV(string_buff,PL_na))+1 );
strcpy((char *)bulkMatchList[i], SvPV(string_buff,PL_na) );
}
SvREFCNT_dec(string_buff); /* release space*/
SvREFCNT_dec(text);
ctop_int(CTXTc 3, num_match); /*return the number of matches*/
return SUCCESS;
}
void set_psc_ep_to_psc(Psc psc_to_set, Psc target_psc) {
if (get_arity(psc_to_set) != get_arity(target_psc)) {
xsb_abort("[IMPORT AS] Cannot import predicate as a predicate with a different arity: %s/%d\n",
get_name(psc_to_set),get_arity(psc_to_set));
} else if (get_ep(psc_to_set) != (byte *)&(psc_to_set->load_inst) &&
get_ep(psc_to_set) != (byte *)&(target_psc->load_inst)) {
xsb_warn("[IMPORT AS] Redefining entry to import-as predicate: %s/%d\n",
get_name(psc_to_set),get_arity(psc_to_set));
set_ep(psc_to_set,(byte *)&(target_psc->load_inst));
} else {
set_ep(psc_to_set,(byte *)&(target_psc->load_inst));
}
}
/* used for abolishes -- its known that outcount is 0 */
void deletecallnode(callnodeptr callnode){
call_node_count_gl--;
if(callnode->outcount==0){
hashtable1_destroy(callnode->outedges->hasht,0);
SM_DeallocateStruct(smOutEdge, callnode->outedges);
SM_DeallocateStruct(smCallNode, callnode);
}else
xsb_abort("outcount is nonzero\n");
return;
}
static xsbBool set_error_code(CTXTdeclc int ErrCode, int ErrCodeArgNumber, char *Where)
{
prolog_term ecode_value_term, ecode_arg_term = p2p_new(CTXT);
ecode_value_term = reg_term(CTXTc ErrCodeArgNumber);
if (!isref(ecode_value_term) &&
!(isointeger(ecode_value_term)))
xsb_abort("[%s] Arg %d (the error code) must be a variable or an integer!",
Where, ErrCodeArgNumber);
c2p_int(CTXTc ErrCode, ecode_arg_term);
return p2p_unify(CTXTc ecode_arg_term, ecode_value_term);
}
static int make_flags(prolog_term flag_term, char *context)
{
int flags = 0;
prolog_term aux_list=flag_term, head_trm;
char *head;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
if (is_var(flag_term))
return REG_EXTENDED;
else if (is_int(flag_term))
return (REG_EXTENDED | REG_ICASE);
if (is_nil(flag_term))
return 0; /* basic, case-sensitive */
if (! is_list(flag_term))
xsb_abort("[%s] Arg 4 (flags) must be a variable, an integer, or a list",
context);
do {
head_trm = p2p_car(aux_list);
aux_list = p2p_cdr(aux_list);
if (!is_string(head_trm))
xsb_abort("[%s] Arg 4: allowed flags are `extended' and `ignorecase'",
context);
head = string_val(head_trm);
if (strcmp(head,"extended")==0)
flags = flags | REG_EXTENDED;
else if (strcmp(head,"ignorecase")==0)
flags = flags | REG_ICASE;
} while (!is_nil(aux_list));
return flags;
}
void get_statistics(CTXTdecl) {
int type;
type = ptoc_int(CTXTc 3);
switch (type) {
// runtime [since start of Prolog,since previous statistics]
// CPU time used while executing, excluding time spent
// garbage collecting, stack shifting, or in system calls.
case RUNTIME: {
double tot_cpu, incr_cpu;
tot_cpu = cpu_time();
incr_cpu = tot_cpu - last_cpu;
last_cpu = tot_cpu;
// tds.time_count = incr_cpu - time_start;
// reset_stat_total(); /* reset 'ttt' struct variable (all 0's) */
ctop_float(CTXTc 4, tot_cpu);
ctop_float(CTXTc 5, incr_cpu);
break;
}
case WALLTIME: {
double tot_wall,this_wall,incr_wall;
this_wall = real_time();
tot_wall = this_wall - realtime_count_gl;
if (!last_wall) last_wall = realtime_count_gl;
incr_wall = this_wall - last_wall;
last_wall = this_wall;
ctop_float(CTXTc 4, tot_wall);
ctop_float(CTXTc 5, incr_wall);
break;
}
case SHARED_TABLESPACE:
{
#ifdef MULTI_THREAD
statistics_inusememory(CTXTc type);
#else
xsb_abort("statistics/2 with parameter shared_tables not supported in this configuration\n");
#endif
break;
}
default: {
statistics_inusememory(CTXTc type);
break;
}
}
}
/*-----------------------------------------------------------------------------*/
void ODBCDisconnect()
{
struct Cursor *cur = FCursor;
struct Cursor *tcur;
struct NumberofCursors *numi = FCurNum, *numj = FCurNum;
HDBC hdbc = (HDBC)ptoc_int(2);
if (!serverConnected) return;
if (hdbc == NULL) { /* close entire connection*/
if (FCursor != NULL)
xsb_abort("Must close all connections before shutting down");
SQLFreeEnv(henv);
serverConnected = 0;
return;
}
/* only free cursors associated with this connection (hdbc)*/
while((numj != NULL) && (numj->hdbc != hdbc)){
if(numj != FCurNum) numi=numi->NCurNum;
numj=numj->NCurNum;
}
if(numj != NULL){
if(numj == FCurNum) FCurNum=numj->NCurNum;
else numi->NCurNum=numj->NCurNum;
free(numj);
}
while (cur != NULL) {
if (cur->hdbc == hdbc) {
tcur = cur->NCursor;
if (cur->Status != 0) SetCursorClose(cur);
SQLFreeStmt(cur->hstmt,SQL_DROP);
if (cur->PCursor) (cur->PCursor)->NCursor = cur->NCursor;
else FCursor = cur->NCursor;
if (cur->NCursor) (cur->NCursor)->PCursor = cur->PCursor;
else LCursor = cur->PCursor;
free(cur);
/* (num->CursorCount)-- */
cur = tcur;
}
else cur = cur->NCursor;
}
SQLDisconnect(hdbc);
SQLFreeConnect(hdbc);
/* SQLFreeEnv(henv);*/
serverConnected = 0;
}
/* get the size of the list input from prolog side */
static int getsize (prolog_term list)
{
int size = 0;
prolog_term head;
while (!isnil(list)) {
head = p2p_car(list);
if(!(isinteger(head)))
xsb_abort("A non-integer socket descriptor encountered in a socket operation");
list = p2p_cdr(list);
size++;
}
return size;
}
void dsInit(DynamicStack *ds, size_t stack_size, size_t frame_size,
char *name) {
size_t total_bytes;
xsb_dbgmsg((LOG_TRIE_STACK, "Initializing %s", name));
total_bytes = stack_size * frame_size;
DynStk_Base(*ds) = malloc(total_bytes);
if ( IsNULL(DynStk_Base(*ds)) )
xsb_abort("Ran out of memory in allocation of %s", DynStk_Name(*ds));
DynStk_Top(*ds) = DynStk_Base(*ds);
DynStk_Ceiling(*ds) = (char *)DynStk_Base(*ds) + total_bytes;
DynStk_FrameSize(*ds) = frame_size;
DynStk_InitSize(*ds) = DynStk_CurSize(*ds) = stack_size;
DynStk_Name(*ds) = name;
}
void smAllocateBlock(Structure_Manager *pSM) {
void *pNewBlock;
dbg_smPrint(LOG_STRUCT_MANAGER, *pSM,"before block allocation");
pNewBlock = malloc(SM_NewBlockSize(*pSM));
if ( IsNULL(pNewBlock) )
xsb_abort("[smAllocateBlock] Out of memory in allocation of %s block\n",
SM_StructName(*pSM));
SMBlk_NextBlock(pNewBlock) = SM_CurBlock(*pSM);
SM_CurBlock(*pSM) = pNewBlock;
SM_NextStruct(*pSM) = SMBlk_FirstStruct(pNewBlock);
SM_LastStruct(*pSM) = SMBlk_LastStruct(pNewBlock,
SM_StructSize(*pSM),
SM_StructsPerBlock(*pSM));
dbg_smPrint(LOG_STRUCT_MANAGER, *pSM,"after block allocation");
}
/* TLS: 2/02 removed "inline static" modifiers so that this function
can be called from interprolog_callback.c */
void keyint_proc(int sig)
{
#ifdef MULTI_THREAD
th_context *th = find_context(xsb_thread_self());
if (th->cond_var_ptr != NULL)
pthread_cond_broadcast( th->cond_var_ptr ) ;
#endif
#ifndef LINUX
init_interrupt(); /* reset interrupt, if using signal */
#endif
if (asynint_val & KEYINT_MARK) {
xsb_abort("unhandled keyboard interrupt");
} else {
asynint_val |= KEYINT_MARK;
asynint_code = 0;
}
}
/* utility function to destroy a select call */
static void select_destroy(CTXTdeclc char *connection_name)
{
int i;
int connectname_found = FALSE;
SYS_MUTEX_LOCK(MUTEX_SOCKETS);
for (i=0; i < MAXCONNECT; i++) {
if(connections[i].empty_flag==FALSE) {
/* find the matching connection_name to destroy */
if (strcmp(connection_name, connections[i].connection_name) == 0) {
connectname_found = TRUE;
/* destroy the corresponding structure */
FD_ZERO(&connections[i].readset);
FD_ZERO(&connections[i].writeset);
FD_ZERO(&connections[i].exceptionset);
connections[i].connection_name = NULL;
connections[i].maximum_fd = 0;
/* free the fds obtained by mem_alloc() */
mem_dealloc(connections[i].read_fds,connections[i].sizer,OTHER_SPACE);
mem_dealloc(connections[i].write_fds,connections[i].sizew,OTHER_SPACE);
mem_dealloc(connections[i].exception_fds,connections[i].sizee,OTHER_SPACE);
connections[i].sizer = 0;
connections[i].sizew = 0 ;
connections[i].sizee = 0 ;
connections[i].empty_flag = TRUE; /* set the destroyed slot to empty */
break;
}
}
}
SYS_MUTEX_UNLOCK(MUTEX_SOCKETS);
/* if no matching connection_name */
if (!connectname_found)
xsb_abort("[SOCKET_SELECT_DESTROY] connection `%s' doesn't exist",
connection_name);
SQUASH_LINUX_COMPILER_WARN(connectname_found) ;
}
void dsShrink(DynamicStack *ds) {
size_t total_bytes;
char *new_base;
if ( DynStk_CurSize(*ds) <= DynStk_InitSize(*ds) )
return;
total_bytes = DynStk_InitSize(*ds) * DynStk_FrameSize(*ds);
new_base = realloc(DynStk_Base(*ds),total_bytes);
xsb_dbgmsg((LOG_TRIE_STACK, "Shrinking %s: %d -> %d", DynStk_Name(*ds),
DynStk_CurSize(*ds), DynStk_InitSize(*ds)));
if ( IsNULL(new_base) )
xsb_abort("Ran out of memory during expansion of %s", DynStk_Name(*ds));
DynStk_Top(*ds) =
new_base + ((char *)DynStk_Top(*ds) - (char *)DynStk_Base(*ds));
DynStk_Base(*ds) = new_base;
DynStk_Ceiling(*ds) = new_base + total_bytes;
DynStk_CurSize(*ds) = DynStk_InitSize(*ds);
}
PRIVATE void rdf_delete_userData(void *userdata)
{
prolog_term parsed_result, status_term;
USERDATA *me = (USERDATA *)userdata;
HTRequest *request = me->request;
if (request) {
parsed_result =
((REQUEST_CONTEXT *)HTRequest_context(request))->request_result;
status_term =
((REQUEST_CONTEXT *)HTRequest_context(request))->status_term;
}
else return;
#ifdef LIBWWW_DEBUG
xsb_dbgmsg((LOG_DEBUG,"***In rdf_delete_userData(%s)", RequestID(request)));
#endif
#ifdef LIBWWW_DEBUG_VERBOSE
print_prolog_term(me->parsed_term, "Current parse value");
#endif
/* terminate the parsed prolog terms list */
extern_c2p_nil(me->parsed_term_tail);
/* pass the result to the outside world */
if (is_var(me->parsed_term))
extern_p2p_unify(parsed_result, me->parsed_term);
else
xsb_abort("[LIBWWW_REQUEST] Request %s: Arg 4 (Result) must be unbound variable",
RequestID(request));
HT_FREE(me);
#ifdef LIBWWW_DEBUG
xsb_dbgmsg((LOG_DEBUG,"***Request %s: freed the USERDATA object", RequestID(request)));
#endif
return;
}
PRIVATE USERDATA *rdf_create_userData(HTRDF *parser,
HTRequest *request,
HTStream *target_stream)
{
USERDATA *me = NULL;
#ifdef LIBWWW_DEBUG
xsb_dbgmsg((LOG_DEBUG,"***Start rdf_create_userData: Request %s", RequestID(request)));
#endif
if (parser) {
/* make sure that MIME type is appropriate for RDF */
if (!verifyMIMEformat(request, RDFPARSE)) {
/*
HTStream * input = HTRequest_inputStream(request);
(*input->isa->abort)(input, NULL);
HTRequest_setInputStream(request,NULL);
HTRequest_kill(request);
return NULL;
*/
xsb_abort("[LIBWWW_REQUEST] Bug: Request type/MIME type mismatch");
}
if ((me = (USERDATA *) HT_CALLOC(1, sizeof(USERDATA))) == NULL)
HT_OUTOFMEM("libwww_parse_rdf");
me->delete_method = rdf_delete_userData;
me->parser = parser;
me->request = request;
me->target = target_stream;
me->parsed_term = extern_p2p_new();
extern_c2p_list(me->parsed_term);
me->parsed_term_tail = me->parsed_term;
}
#ifdef LIBWWW_DEBUG
xsb_dbgmsg((LOG_DEBUG,"***End rdf_create_userData: Request %s", RequestID(request)));
#endif
/* Hook up userdata to the request context */
((REQUEST_CONTEXT *)HTRequest_context(request))->userdata = (void *)me;
return me;
}
Psc synint_proc(CTXTdeclc Psc psc, int intcode)
{
if (pflags[intcode+INT_HANDLERS_FLAGS_START]==(Cell)0) {
/* default hard handler */
default_inthandler(CTXTc intcode);
psc = 0;
} else { /* call Prolog handler */
switch (intcode) {
case MYSIG_UNDEF: /* 0 */
SYS_MUTEX_LOCK( MUTEX_LOAD_UNDEF ) ;
case MYSIG_KEYB: /* 1 */
case MYSIG_SPY: /* 3 */
case MYSIG_TRACE: /* 4 */
case THREADSIG_CANCEL: /* f */
case MYSIG_CLAUSE: /* 16 */
if (psc) bld_cs(reg+1, build_call(CTXTc psc));
psc = (Psc)pflags[intcode+INT_HANDLERS_FLAGS_START];
bld_int(reg+2, asynint_code);
pcreg = get_ep(psc);
break;
case MYSIG_ATTV: /* 8 */
/* the old call must be built first */
if (psc)
bld_cs(reg+2, build_call(CTXTc psc));
psc = (Psc)pflags[intcode+INT_HANDLERS_FLAGS_START];
/*
* Pass the interrupt chain to reg 1. The interrupt chain
* will be reset to 0 in build_interrupt_chain()).
*/
bld_copy(reg + 1, build_interrupt_chain(CTXT));
/* bld_int(reg + 3, intcode); */ /* Not really needed */
pcreg = get_ep(psc);
break;
default:
xsb_abort("Unknown intcode in synint_proc()");
} /* switch */
}
return psc;
}
void deallocate_previous_call(callnodeptr callnode){
calllistptr tmpin,in;
KEY *ownkey;
/* callnodeptr inedge_node; */
struct hashtable* hasht;
SM_AllocateStruct(smKey, ownkey);
ownkey->goal=callnode->id;
in = callnode->inedges;
call_node_count_gl--;
while(IsNonNULL(in)){
tmpin = in->next;
hasht = in->inedge_node->hasht;
if (remove_some(hasht,ownkey) == NULL) {
/*
prevnode=in->prevnode->callnode;
if(IsNonNULL(prevnode->goal)){
sfPrintGoal(stdout,(VariantSF)prevnode->goal,NO); printf("(%d)",prevnode->id);
}
if(IsNonNULL(callnode->goal)){
sfPrintGoal(stdout,(VariantSF)callnode->goal,NO); printf("(%d)",callnode->id);
}
*/
xsb_abort("BUG: key not found for removal\n");
}
in->inedge_node->callnode->outcount--;
call_edge_count_gl--;
SM_DeallocateStruct(smCallList, in);
in = tmpin;
}
SM_DeallocateStruct(smCallNode, callnode);
SM_DeallocateStruct(smKey, ownkey);
}
void deleteinedges(callnodeptr callnode){
calllistptr tmpin,in;
KEY *ownkey;
struct hashtable* hasht;
SM_AllocateStruct(smKey, ownkey);
ownkey->goal=callnode->id;
in = callnode->inedges;
while(IsNonNULL(in)){
tmpin = in->next;
hasht = in->inedge_node->hasht;
// printf("remove some callnode %x / ownkey %d\n",callnode,ownkey);
if (remove_some(hasht,ownkey) == NULL) {
xsb_abort("BUG: key not found for removal\n");
}
call_edge_count_gl--;
SM_DeallocateStruct(smCallList, in);
in = tmpin;
}
SM_DeallocateStruct(smKey, ownkey);
return;
}
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"); */
}
/* XSB string substitution entry point
In:
Arg1: string
Arg2: beginning offset
Arg3: ending offset. < 0 means end of string
Out:
Arg4: new (output) string
Always succeeds, unless error.
*/
int do_regsubstring__(void)
{
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term input_term, output_term;
prolog_term beg_offset_term, end_offset_term;
char *input_string=NULL; /* string where matches are to be found */
int beg_offset, end_offset, input_len, substring_len;
int conversion_required=FALSE;
XSB_StrSet(&output_buffer,"");
input_term = reg_term(CTXTc 1); /* Arg1: string to find matches in */
if (is_string(input_term)) /* check it */
input_string = string_val(input_term);
else if (is_list(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"RE_SUBSTRING", "input string");
conversion_required = TRUE;
} else
xsb_abort("[RE_SUBSTRING] Arg 1 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
/* arg 2: beginning offset */
beg_offset_term = reg_term(CTXTc 2);
if (! is_int(beg_offset_term))
xsb_abort("[RE_SUBSTRING] Arg 2 (the beginning offset) must be an integer");
beg_offset = int_val(beg_offset_term);
if (beg_offset < 0 || beg_offset > input_len)
xsb_abort("[RE_SUBSTRING] Arg 2 (=%d) must be between 0 and %d",
beg_offset, input_len);
/* arg 3: ending offset */
end_offset_term = reg_term(CTXTc 3);
if (! is_int(end_offset_term))
xsb_abort("[RE_SUBSTRING] Arg 3 (the ending offset) must be an integer");
end_offset = int_val(end_offset_term);
if (end_offset < 0)
end_offset = input_len;
else if (end_offset > input_len || end_offset < beg_offset)
xsb_abort("[RE_SUBSTRING] Arg 3 (=%d) must be < 0 or between %d and %d",
end_offset, beg_offset, input_len);
output_term = reg_term(CTXTc 4);
if (! is_var(output_term))
xsb_abort("[RE_SUBSTRING] Arg 4 (the output string) must be an unbound variable");
/* do the actual replacement */
substring_len = end_offset-beg_offset;
XSB_StrAppendBlk(&output_buffer, input_string+beg_offset, substring_len);
XSB_StrNullTerminate(&output_buffer);
/* get result out */
if (conversion_required)
c_string_to_p_charlist(CTXTc output_buffer.string, output_term, 4,
"RE_SUBSTITUTE", "Arg 4");
else
/* DO NOT intern. When atom table garbage collection is in place, then
replace the instruction with this:
c2p_string(output_buffer, output_term);
The reason for not interning is that in Web page
manipulation it is often necessary to process the same string many
times. This can cause atom table overflow. Not interning allws us to
circumvent the problem. */
ctop_string(CTXTc 4, output_buffer.string);
return(TRUE);
}
