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 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; }
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); }
/* file_stat(+FileName, +FuncNumber, -Result) */ xsbBool file_stat(CTXTdeclc int callno, char *file) { struct stat stat_buff; int retcode; #ifdef WIN_NT size_t filenamelen; // windows doesn't allow trailing slash, others do filenamelen = strlen(file); if (file[filenamelen-1] == '/' || file[filenamelen-1] == '\\') { char ss = file[filenamelen-1]; file[filenamelen-1] = '\0'; retcode = stat(file, &stat_buff); file[filenamelen-1] = ss; // reset } else #endif retcode = stat(file, &stat_buff); switch (callno) { case IS_PLAIN_FILE: { if (retcode == 0 && S_ISREG(stat_buff.st_mode)) return TRUE; else return FALSE; } case IS_DIRECTORY: { if (retcode == 0 && S_ISDIR(stat_buff.st_mode)) return TRUE; else return FALSE; } case STAT_FILE_TIME: { /* This is DSW's hack to get 32 bit time values. The idea is to call this builtin as file_time(File,time(T1,T2)) where T1 represents the most significant 8 bits and T2 represents the least significant 24. ***This probably breaks 64 bit systems, so David will look into it! */ int functor_arg3 = isconstr(reg_term(CTXTc 3)); if (!retcode && functor_arg3) { /* file exists & arg3 is a term, return 2 words*/ c2p_int(CTXTc (prolog_int)(stat_buff.st_mtime >> 24),p2p_arg(reg_term(CTXTc 3),1)); c2p_int(CTXTc 0xFFFFFF & stat_buff.st_mtime,p2p_arg(reg_term(CTXTc 3),2)); } else if (!retcode) { /* file exists, arg3 non-functor: issue an error */ ctop_int(CTXTc 3, (prolog_int)stat_buff.st_mtime); } else if (functor_arg3) { /* no file, and arg3 is functor: return two 0's */ c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),2)); c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),1)); } else { /* no file, no functor: return 0 */ ctop_int(CTXTc 3, 0); } 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; }
/* file_stat(+FileName, +FuncNumber, -Result) */ xsbBool file_stat(CTXTdeclc int callno, char *file) { struct stat stat_buff; int retcode = stat(file, &stat_buff); switch (callno) { case IS_PLAIN_FILE: { if (retcode == 0 && S_ISREG(stat_buff.st_mode)) return TRUE; else return FALSE; } case IS_DIRECTORY: { if (retcode == 0 && S_ISDIR(stat_buff.st_mode)) return TRUE; else return FALSE; } case STAT_FILE_TIME: { /* This is DSW's hack to get 32 bit time values. The idea is to call this builtin as file_time(File,time(T1,T2)) where T1 represents the most significant 8 bits and T2 represents the least significant 24. ***This probably breaks 64 bit systems, so David will look into it! */ int functor_arg3 = isconstr(reg_term(CTXTc 3)); if (!retcode && functor_arg3) { /* file exists & arg3 is a term, return 2 words*/ c2p_int(CTXTc stat_buff.st_mtime >> 24,p2p_arg(reg_term(CTXTc 3),1)); c2p_int(CTXTc 0xFFFFFF & stat_buff.st_mtime,p2p_arg(reg_term(CTXTc 3),2)); } else if (!retcode) { /* file exists, arg3 non-functor: issue an error */ xsb_warn("Arg 3 (the time argument) must be of the form time(X,Y)"); ctop_int(CTXTc 3, (0x7FFFFFF & stat_buff.st_mtime)); } else if (functor_arg3) { /* no file, and arg3 is functor: return two 0's */ c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),2)); c2p_int(CTXTc 0, p2p_arg(reg_term(CTXTc 3),1)); } else { /* no file, no functor: return 0 */ xsb_warn("Arg 3 (the time argument) must be of the form time(X,Y)"); ctop_int(CTXTc 3, 0); } return TRUE; }
/* 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; }
/* TLS: making a conservative guess at which system calls need to be mutexed. I'm doing it whenever I see the process table altered or affected, so this is the data structure that its protecting. At some point, the SET_FILEPTRs should be protected against other threads closing that stream. Perhaps for such things a thread-specific stream table should be used. */ xsbBool sys_system(CTXTdeclc int callno) { // int pid; Integer pid; switch (callno) { case PLAIN_SYSTEM_CALL: /* dumb system call: no communication with XSB */ /* this call is superseded by shell and isn't used */ ctop_int(CTXTc 3, system(ptoc_string(CTXTc 2))); return TRUE; case SLEEP_FOR_SECS: #ifdef WIN_NT Sleep((int)iso_ptoc_int_arg(CTXTc 2,"sleep/1",1) * 1000); #else sleep(iso_ptoc_int_arg(CTXTc 2,"sleep/1",1)); #endif return TRUE; case GET_TMP_FILENAME: ctop_string(CTXTc 2,tempnam(NULL,NULL)); return TRUE; case IS_PLAIN_FILE: case IS_DIRECTORY: case STAT_FILE_TIME: case STAT_FILE_SIZE: return file_stat(CTXTc callno, ptoc_longstring(CTXTc 2)); case EXEC: { #ifdef HAVE_EXECVP /* execs a new process in place of XSB */ char *params[MAX_SUBPROC_PARAMS+2]; prolog_term cmdspec_term; int index = 0; cmdspec_term = reg_term(CTXTc 2); if (islist(cmdspec_term)) { prolog_term temp, head; char *string_head=NULL; if (isnil(cmdspec_term)) xsb_abort("[exec] Arg 1 must not be an empty list."); temp = cmdspec_term; do { head = p2p_car(temp); temp = p2p_cdr(temp); if (isstring(head)) string_head = string_val(head); else xsb_abort("[exec] non-string argument passed in list."); params[index++] = string_head; if (index > MAX_SUBPROC_PARAMS) xsb_abort("[exec] Too many arguments."); } while (!isnil(temp)); params[index] = NULL; } else if (isstring(cmdspec_term)) { char *string = string_val(cmdspec_term); split_command_arguments(string, params, "exec"); } else xsb_abort("[exec] 1st argument should be term or list of strings."); if (execvp(params[0], params)) xsb_abort("[exec] Exec call failed."); #else xsb_abort("[exec] builtin not supported in this architecture."); #endif } case SHELL: /* smart system call: like SPAWN_PROCESS, but returns error code instead of PID. Uses system() rather than execvp. Advantage: can pass arbitrary shell command. */ case SPAWN_PROCESS: { /* spawn new process, reroute stdin/out/err to XSB */ /* +CallNo=2, +ProcAndArgsList, -StreamToProc, -StreamFromProc, -StreamFromProcStderr, -Pid */ static int pipe_to_proc[2], pipe_from_proc[2], pipe_from_stderr[2]; int toproc_stream=-1, fromproc_stream=-1, fromproc_stderr_stream=-1; int pid_or_status; FILE *toprocess_fptr=NULL, *fromprocess_fptr=NULL, *fromproc_stderr_fptr=NULL; char *params[MAX_SUBPROC_PARAMS+2]; /* one for progname--0th member, one for NULL termination*/ prolog_term cmdspec_term, cmdlist_temp_term; prolog_term cmd_or_arg_term; xsbBool toproc_needed=FALSE, fromproc_needed=FALSE, fromstderr_needed=FALSE; char *cmd_or_arg=NULL, *shell_cmd=NULL; int idx = 0, tbl_pos; char *callname=NULL; xsbBool params_are_in_a_list=FALSE; SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM ); init_process_table(); if (callno == SPAWN_PROCESS) callname = "spawn_process/5"; else callname = "shell/[1,2,5]"; cmdspec_term = reg_term(CTXTc 2); if (islist(cmdspec_term)) params_are_in_a_list = TRUE; else if (isstring(cmdspec_term)) shell_cmd = string_val(cmdspec_term); else if (isref(cmdspec_term)) xsb_instantiation_error(CTXTc callname,1); else xsb_type_error(CTXTc "atom or list e.g. [command, arg, ...]",cmdspec_term,callname,1); // xsb_abort("[%s] Arg 1 must be an atom or a list [command, arg, ...]", // callname); /* the user can indicate that he doesn't want either of the streams created by putting an atom in the corresponding argument position */ if (isref(reg_term(CTXTc 3))) toproc_needed = TRUE; if (isref(reg_term(CTXTc 4))) fromproc_needed = TRUE; if (isref(reg_term(CTXTc 5))) fromstderr_needed = TRUE; /* if any of the arg streams is already used by XSB, then don't create pipes --- use these streams instead. */ if (isointeger(reg_term(CTXTc 3))) { SET_FILEPTR(toprocess_fptr, oint_val(reg_term(CTXTc 3))); } if (isointeger(reg_term(CTXTc 4))) { SET_FILEPTR(fromprocess_fptr, oint_val(reg_term(CTXTc 4))); } if (isointeger(reg_term(CTXTc 5))) { SET_FILEPTR(fromproc_stderr_fptr, oint_val(reg_term(CTXTc 5))); } if (!isref(reg_term(CTXTc 6))) xsb_type_error(CTXTc "variable (to return process id)",reg_term(CTXTc 6),callname,5); // xsb_abort("[%s] Arg 5 (process id) must be a variable", callname); if (params_are_in_a_list) { /* fill in the params[] array */ if (isnil(cmdspec_term)) xsb_abort("[%s] Arg 1 must not be an empty list", callname); cmdlist_temp_term = cmdspec_term; do { cmd_or_arg_term = p2p_car(cmdlist_temp_term); cmdlist_temp_term = p2p_cdr(cmdlist_temp_term); if (isstring(cmd_or_arg_term)) { cmd_or_arg = string_val(cmd_or_arg_term); } else xsb_abort("[%s] Non string list member in the Arg", callname); params[idx++] = cmd_or_arg; if (idx > MAX_SUBPROC_PARAMS) xsb_abort("[%s] Too many arguments passed to subprocess", callname); } while (!isnil(cmdlist_temp_term)); params[idx] = NULL; /* null termination */ } else { /* params are in a string */ if (callno == SPAWN_PROCESS) split_command_arguments(shell_cmd, params, callname); else { /* if callno==SHELL => call system() => don't split shell_cmd */ params[0] = shell_cmd; params[1] = NULL; } } /* -1 means: no space left */ if ((tbl_pos = get_free_process_cell()) < 0) { xsb_warn(CTXTc "Can't create subprocess because XSB process table is full"); SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return FALSE; } /* params[0] is the progname */ pid_or_status = xsb_spawn(CTXTc params[0], params, callno, (toproc_needed ? pipe_to_proc : NULL), (fromproc_needed ? pipe_from_proc : NULL), (fromstderr_needed ? pipe_from_stderr : NULL), toprocess_fptr, fromprocess_fptr, fromproc_stderr_fptr); if (pid_or_status < 0) { xsb_warn(CTXTc "[%s] Subprocess creation failed, Error: %d, errno: %d, Cmd: %s", callname,pid_or_status,errno,params[0]); SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return FALSE; } if (toproc_needed) { toprocess_fptr = fdopen(pipe_to_proc[1], "w"); toproc_stream = xsb_intern_fileptr(CTXTc toprocess_fptr,callname,"pipe","w",CURRENT_CHARSET); ctop_int(CTXTc 3, toproc_stream); } if (fromproc_needed) { fromprocess_fptr = fdopen(pipe_from_proc[0], "r"); fromproc_stream = xsb_intern_fileptr(CTXTc fromprocess_fptr,callname,"pipe","r",CURRENT_CHARSET); ctop_int(CTXTc 4, fromproc_stream); } if (fromstderr_needed) { fromproc_stderr_fptr = fdopen(pipe_from_stderr[0], "r"); fromproc_stderr_stream = xsb_intern_fileptr(CTXTc fromproc_stderr_fptr,callname,"pipe","r",CURRENT_CHARSET); ctop_int(CTXTc 5, fromproc_stderr_stream); } ctop_int(CTXTc 6, pid_or_status); xsb_process_table.process[tbl_pos].pid = pid_or_status; xsb_process_table.process[tbl_pos].to_stream = toproc_stream; xsb_process_table.process[tbl_pos].from_stream = fromproc_stream; xsb_process_table.process[tbl_pos].stderr_stream = fromproc_stderr_stream; concat_array(CTXTc params, " ", xsb_process_table.process[tbl_pos].cmdline,MAX_CMD_LEN); SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return TRUE; } case GET_PROCESS_TABLE: { /* sys_system(3, X). X is bound to the list of the form [process(Pid,To,From,Stderr,Cmdline), ...] */ int i; prolog_term table_term_tail, listHead; prolog_term table_term=reg_term(CTXTc 2); SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM ); init_process_table(); if (!isref(table_term)) xsb_abort("[GET_PROCESS_TABLE] Arg 1 must be a variable"); table_term_tail = table_term; for (i=0; i<MAX_SUBPROC_NUMBER; i++) { if (!FREE_PROC_TABLE_CELL(xsb_process_table.process[i].pid)) { c2p_list(CTXTc table_term_tail); /* make it into a list */ listHead = p2p_car(table_term_tail); c2p_functor(CTXTc "process", 5, listHead); c2p_int(CTXTc xsb_process_table.process[i].pid, p2p_arg(listHead,1)); c2p_int(CTXTc xsb_process_table.process[i].to_stream, p2p_arg(listHead,2)); c2p_int(CTXTc xsb_process_table.process[i].from_stream, p2p_arg(listHead,3)); c2p_int(CTXTc xsb_process_table.process[i].stderr_stream, p2p_arg(listHead,4)); c2p_string(CTXTc xsb_process_table.process[i].cmdline, p2p_arg(listHead,5)); table_term_tail = p2p_cdr(table_term_tail); } } c2p_nil(CTXTc table_term_tail); /* bind tail to nil */ SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return p2p_unify(CTXTc table_term, reg_term(CTXTc 2)); } case PROCESS_STATUS: { prolog_term pid_term=reg_term(CTXTc 2), status_term=reg_term(CTXTc 3); SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM ); init_process_table(); if (!(isointeger(pid_term))) xsb_abort("[PROCESS_STATUS] Arg 1 (process id) must be an integer"); pid = (int)oint_val(pid_term); if (!isref(status_term)) xsb_abort("[PROCESS_STATUS] Arg 2 (process status) must be a variable"); switch (process_status(pid)) { case RUNNING: c2p_string(CTXTc "running", status_term); break; case STOPPED: c2p_string(CTXTc "stopped", status_term); break; case EXITED_NORMALLY: c2p_string(CTXTc "exited_normally", status_term); break; case EXITED_ABNORMALLY: c2p_string(CTXTc "exited_abnormally", status_term); break; case ABORTED: c2p_string(CTXTc "aborted", status_term); break; case INVALID: c2p_string(CTXTc "invalid", status_term); break; default: c2p_string(CTXTc "unknown", status_term); } SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return TRUE; } case PROCESS_CONTROL: { /* sys_system(PROCESS_CONTROL, +Pid, +Signal). Signal: wait, kill */ int status; prolog_term pid_term=reg_term(CTXTc 2), signal_term=reg_term(CTXTc 3); SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM ); init_process_table(); if (!(isointeger(pid_term))) xsb_abort("[PROCESS_CONTROL] Arg 1 (process id) must be an integer"); pid = (int)oint_val(pid_term); if (isstring(signal_term) && strcmp(string_val(signal_term), "kill")==0) { if (KILL_FAILED(pid)) { SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return FALSE; } #ifdef WIN_NT CloseHandle((HANDLE) pid); #endif SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return TRUE; } if (isconstr(signal_term) && strcmp(p2c_functor(signal_term),"wait") == 0 && p2c_arity(signal_term)==1) { int exit_status; if (WAIT(pid, status) < 0) { SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return FALSE; } #ifdef WIN_NT exit_status = status; #else if (WIFEXITED(status)) exit_status = WEXITSTATUS(status); else exit_status = -1; #endif p2p_unify(CTXTc p2p_arg(signal_term,1), makeint(exit_status)); SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM ); return TRUE; } xsb_warn(CTXTc "[PROCESS_CONTROL] Arg 2: Invalid signal specification. Must be `kill' or `wait(Var)'"); return FALSE; } case LIST_DIRECTORY: { /* assume all type- and mode-checking is done in Prolog */ prolog_term handle = reg_term(CTXTc 2); /* ref for handle */ char *dir_name = ptoc_longstring(CTXTc 3); /* +directory name */ prolog_term filename = reg_term(CTXTc 4); /* reference for name of file */ if (is_var(handle)) return xsb_find_first_file(CTXTc handle,dir_name,filename); else return xsb_find_next_file(CTXTc handle,dir_name,filename); } default: xsb_abort("[SYS_SYSTEM] Wrong call number (an XSB bug)"); } /* end case */ return TRUE; }
/* 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 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; }