/* File: builtin.c
** Author(s): Xu, Warren, Sagonas, Swift, Freire, Johnson
** Contact: xsb-contact@cs.sunysb.edu
**
** Copyright (C) The Research Foundation of SUNY, 1986, 1993-1999
** Copyright (C) ECRC, Germany, 1990
**
** XSB is free software; you can redistribute it and/or modify it under the
** terms of the GNU Library General Public License as published by the Free
** Software Foundation; either version 2 of the License, or (at your option)
** any later version.
**
** XSB is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
** FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for
** more details.
**
** You should have received a copy of the GNU Library General Public License
** along with XSB; if not, write to the Free Software Foundation,
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
**
** $Id: builtin.c,v 1.161 2003/06/18 16:51:15 lfcastro Exp $
**
*/
#include "xsb_config.h"
#include "xsb_debug.h"
/* Private debugs */
#include "debugs/debug_delay.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <errno.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <signal.h>
#include <math.h>
#ifdef WIN_NT
#include <windows.h>
#include <direct.h>
#include <io.h>
#include <process.h>
#include <stdarg.h>
#include <winsock.h>
#include "wsipx.h"
#include <tchar.h>
#else /* Unix */
#include <unistd.h>
#include <sys/socket.h>
#include <sys/uio.h>
#include <netdb.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#endif
#include <fcntl.h>
#include "auxlry.h"
#include "cell_xsb.h"
#include "error_xsb.h"
#include "psc_xsb.h"
#include "hash_xsb.h"
#include "tries.h"
#include "choice.h"
#include "deref.h"
#include "memory_xsb.h"
#include "heap_xsb.h"
#include "register.h"
#include "flags_xsb.h"
#include "loader_xsb.h"
#include "binding.h"
#include "macro_xsb.h"
#include "builtin.h"
#include "sig_xsb.h"
#include "subp.h"
#include "tr_utils.h"
#include "trassert.h"
#include "dynload.h"
#include "cinterf.h"
#include "residual.h"
#include "tables.h"
#include "trie_internals.h"
#include "table_status_defs.h"
#ifdef ORACLE
#include "oracle_xsb.h"
#endif
#ifdef XSB_ODBC
#include "odbc_xsb.h"
#endif
#ifdef XSB_INTERPROLOG
#include "interprolog_xsb.h"
#endif
#ifdef PROFILE
#include "inst_xsb.h"
#include "subinst.h"
#endif
#include "io_builtins_xsb.h"
#include "storage_xsb.h"
/* wind2unix.h must be included after sys/stat.h */
#include "wind2unix.h"
#include "system_xsb.h"
#include "random_xsb.h"
#ifdef DEMAND
#include "demand.h"
#endif
#include "debug_xsb.h"
/*======================================================================*/
extern int sys_syscall(int);
extern xsbBool sys_system(int);
extern xsbBool formatted_io(void), read_canonical(void);
extern xsbBool private_builtin(void);
extern void xsb_segfault_quitter(int err);
#ifdef WIN_NT
extern xsbBool startInterruptThread(SOCKET intSocket);
#endif
extern xsbBool assert_code_to_buff(void), assert_buff_to_clref(void);
extern xsbBool gen_retract_all(void), db_retract0(void), db_get_clause(void);
extern xsbBool db_build_prref(void), db_remove_prref(void), db_reclaim0(void);
extern char *dirname_canonic(char *);
extern xsbBool almost_search_module(char *);
extern char *expand_filename(char *filename);
extern char *existing_file_extension(char *);
extern char *tilde_expand_filename(char *filename);
extern xsbBool is_absolute_filename(char *filename);
extern void parse_filename(char *filenam, char **dir, char **base, char **ext);
extern xsbBool xsb_socket_request(void);
extern int findall_init(void), findall_add(void), findall_get_solutions(void);
extern int copy_term(void);
extern xsbBool substring(void);
extern xsbBool string_substitute(void);
extern xsbBool str_cat(void);
extern xsbBool str_sub(void);
extern xsbBool str_match(void);
extern void force_answer_true(BTNptr);
extern void force_answer_false(BTNptr);
extern int set_scope_marker();
extern int unwind_stack();
extern int clean_up_block();
extern double realtime_count; /* from subp.c */
/* ------- variables also used in other parts of the system ----------- */
Cell flags[64]; /* System flags + user flags */
/* ------- utility routines ------------------------------------------- */
#include "ptoc_tag_xsb_i.h"
DllExport prolog_int call_conv ptoc_int(int regnum)
{
/* reg is global array in register.h */
register Cell addr = cell(reg+regnum);
/* XSB_Deref and then check the type */
XSB_Deref(addr);
switch (cell_tag(addr)) {
case XSB_STRUCT:
if (isboxedinteger(addr)) return(boxedint_val(addr));
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
case XSB_LIST:
case XSB_FLOAT: xsb_abort("[PTOC_INT] Integer argument expected");
case XSB_STRING: return (prolog_int)string_val(addr); /* dsw */
case XSB_INT: return int_val(addr);
default: xsb_abort("[PTOC_INT] Argument of unknown type");
}
return FALSE;
}
DllExport prolog_float call_conv ptoc_float(int regnum)
{
/* reg is global array in register.h */
register Cell addr = cell(reg+regnum);
/* XSB_Deref and then check the type */
XSB_Deref( addr );
switch (cell_tag(addr)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
case XSB_STRUCT:
case XSB_LIST:
case XSB_INT:
case XSB_STRING:
xsb_abort("[PTOC_FLOAT] Float argument expected");
case XSB_FLOAT: return (prolog_float)float_val(addr);
default:
xsb_abort("[PTOC_FLOAT] Argument of unknown type");
}
return 0.0;
}
DllExport char* call_conv ptoc_string(int regnum)
{
/* reg is global array in register.h */
register Cell addr = cell(reg+regnum);
/* XSB_Deref and then check the type */
XSB_Deref(addr);
switch (cell_tag(addr)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
case XSB_LIST:
case XSB_FLOAT:
xsb_abort("[PTOC_STRING] String (atom) argument expected");
case XSB_STRUCT: /* tentative approach to fix boxed ints --lfcastro */
if (isboxedinteger(addr))
return (char *)boxedint_val(addr);
else
xsb_abort("[PTOC_STRING] String (atom) argument expected");
case XSB_INT: return (char *)int_val(addr);
case XSB_STRING: return string_val(addr);
default:
xsb_abort("[PTOC_STRING] Argument of unknown type");
}
return "";
}
/* Used to pass integer or float values to math functions
that do the conversion. */
DllExport prolog_float call_conv ptoc_number(int regnum)
{
/* reg is global array in register.h */
register Cell addr = cell(reg+regnum);
/* XSB_Deref and then check the type */
XSB_Deref(addr);
switch (cell_tag(addr)) {
case XSB_STRUCT:
if (isboxedinteger(addr)) return(boxedint_val(addr));
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
case XSB_LIST: xsb_abort("[PTOC_INT] Float-convertable argument expected");
case XSB_FLOAT: return (prolog_float)float_val(addr);
case XSB_STRING: return (prolog_int)string_val(addr); /* dsw */
case XSB_INT: return int_val(addr);
default: xsb_abort("[PTOC_INT] Argument of unknown type");
}
return 0.0;
}
#define MAXSBUFFS 30
static VarString *LSBuff[MAXSBUFFS] = {NULL};
/*
VarString **LSBuff;
int LSBuffInitted = 0;
*/
/*static XSB_StrDefine(lsbuff);*/
/* construct a long string from prolog... concatenates atoms,
flattening lists and comma-lists, and treating small ints as ascii
codes. Puts result in a fixed buffer (if nec.) automatically extended */
void constructString(Cell addr, int ivstr)
{
int val;
static char charstr[2] = "x";
constructStringBegin:
XSB_Deref(addr);
switch (cell_tag(addr)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
case XSB_FLOAT:
xsb_abort("[PTOC_LONGSTRING] Argument of unknown type");
case XSB_STRUCT:
if (get_str_psc(addr) == comma_psc) {
constructString(cell(clref_val(addr)+1),ivstr);
addr = cell(clref_val(addr)+2); /* tail recursion opt */
goto constructStringBegin;
} else xsb_abort("[PTOC_LONGSTRING] Argument of unknown type");
case XSB_LIST:
constructString(cell(clref_val(addr)),ivstr);
addr = cell(clref_val(addr)+1); /* tail recursion opt */
goto constructStringBegin;
case XSB_INT:
val = int_val(addr);
if (val < 256 && val >= 0) {
charstr[0] = val;
XSB_StrAppend(LSBuff[ivstr],charstr);
return;
} else xsb_abort("[PTOC_LONGSTRING] Argument of unknown type");
case XSB_STRING:
if (isnil(addr)) return;
XSB_StrAppend(LSBuff[ivstr],string_val(addr));
return;
default:
xsb_abort("[PTOC_LONGSTRING] Argument of unknown type");
}
}
DllExport char* call_conv ptoc_longstring(int regnum)
{
/* reg is global array in register.h */
register Cell addr = cell(reg+regnum);
XSB_Deref(addr);
if (isstring(addr)) return string_val(addr);
/*
if (!LSBuffInitted)
LSBuff = calloc(MAXSBUFFS,4);
if (!LSBuff[regnum]) {
LSBuff[regnum] = (VarString *) malloc(sizeof(VarString));
LSBuff[regnum]->size = 0;
LSBuff[regnum]->increment = 0;
LSBuff[regnum]->length = 0;
LSBuff[regnum]->string = NULL;
LSBuff[regnum]->op = &VarStrOps;
}
XSB_StrShrink(LSBuff[regnum],100);
*/
if (LSBuff[regnum]==NULL) {
XSB_StrCreate(&LSBuff[regnum]);
}
XSB_StrSet(LSBuff[regnum],"");
constructString(addr,regnum);
return(LSBuff[regnum]->string);
}
/*
* For decoding object pointers, like PSC, PSC-PAIR and Subgoal frames.
*/
#define ptoc_addr(regnum) (void *)ptoc_int(regnum)
#define is_encoded_addr(term) isinteger(term)
#define decode_addr(term) (void *)oint_val(term)
/*
* Deref's the variable of register `regnum', trails the binding,
* creates an INT Cell containing `value', and binds the variable to it.
*/
DllExport void call_conv ctop_int(int regnum, prolog_int value)
{
register Cell addr = cell(reg+regnum);
XSB_Deref(addr);
if (isref(addr)) {
bind_oint(vptr(addr),value);
}
else
xsb_abort("[CTOP_INT] Wrong type of argument %lx (Reg = %d)", addr, regnum);
}
/* from float value form an int node */
DllExport void call_conv ctop_float(int regnum, prolog_float value)
{
/* reg is global array in register.h */
register Cell addr = cell(reg+regnum);
XSB_Deref(addr);
if (isref(addr)) {
bind_float(vptr(addr), value);
}
else xsb_abort("[CTOP_FLOAT] Wrong type of argument: %lux", addr);
}
/* take a C string, form a string node */
DllExport void call_conv ctop_string(int regnum, char *value)
{
/* reg is global array in register.h */
register Cell addr = cell(reg+regnum);
XSB_Deref(addr);
if (isref(addr)) {
bind_string(vptr(addr), value);
}
else
xsb_abort("[CTOP_STRING] Wrong type of argument: %lux", addr);
}
inline static void ctop_constr(int regnum, Pair psc_pair)
{ /* from psc_pair ptr form an constr node */
register Cell addr = cell(reg+regnum);
XSB_Deref(addr);
if (isref(addr)) {
bind_cs(vptr(addr), psc_pair);
}
else xsb_abort("[CTOP_CONSTR] Wrong type of argument: %lux", addr);
}
/*
* Bind the variable pointed to by the "regnum"th argument register to the
* term at address "term". Make an entry in the trail for this binding.
*/
inline static void ctop_tag(int regnum, Cell term)
{
register Cell addr = cell(reg+regnum);
XSB_Deref(addr);
if (isref(addr)) {
bind_copy(vptr(addr), term);
}
else
xsb_abort("[CTOP_TAG] Wrong type of argument: %lux", addr);
}
/*
* For encoding object pointer, like PSC, PSC-PAIR and Subgoal frames.
*/
#define ctop_addr(regnum, val) ctop_int(regnum, (prolog_int)val)
/* -------------------------------------------------------------------- */
Cell val_to_hash(Cell term)
{
Cell value;
switch(cell_tag(term)) {
case XSB_INT:
case XSB_FLOAT: /* Yes, use int_val to avoid conversion problem */
value = (Cell)int_val(term);
break;
case XSB_LIST:
value = (Cell)(list_str);
break;
case XSB_STRUCT:
value = (Cell)get_str_psc(term);
break;
case XSB_STRING: /* The following test is a necessary nuisance caused */
/* by the strange (dynamic) compilation of []/0 in an */
/* index position which should be fixed one fine day! */
value = (Cell)(isnil(term) ? 0 : string_val(term));
break;
default: xsb_exit("Indexing on illegal argument");
value = 0;
break;
}
return value;
}
/* -------------------------------------------------------------------- */
static int ground(CPtr temp)
{
int j, arity;
groundBegin:
XSB_CptrDeref(temp);
switch(cell_tag(temp)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
return FALSE;
case XSB_STRING:
case XSB_INT:
case XSB_FLOAT:
return TRUE;
case XSB_LIST:
if (!ground(clref_val(temp)))
return FALSE;
temp = clref_val(temp)+1;
goto groundBegin;
case XSB_STRUCT:
arity = (int) get_arity(get_str_psc(temp));
if (arity == 0) return TRUE;
for (j=1; j < arity ; j++)
if (!ground(clref_val(temp)+j))
return FALSE;
temp = clref_val(temp)+arity;
goto groundBegin;
default:
xsb_abort("[ground/1] Term with unknown tag (%d)",
(int)cell_tag(temp));
return -1; /* so that g++ does not complain */
}
}
/* -------------------------------------------------------------------- */
inline static int is_proper_list(Cell term) /* for standard preds */
{
register Cell addr;
addr = term;
XSB_Deref(addr);
while (islist(addr)) {
addr = cell(clref_val(addr)+1);
XSB_Deref(addr);
}
return isnil(addr);
}
/* -------------------------------------------------------------------- */
static CPtr mini_trail[MAX_ARITY];
static CPtr *mini_trail_top;
#define mini_undo_bindings \
while (mini_trail_top >= mini_trail) { \
untrail(*mini_trail_top); \
mini_trail_top--; \
}
#define mini_bind_variable(addr) \
follow(addr) = makenil; \
*(++mini_trail_top) = (CPtr)addr;
static int is_most_general_term(Cell term)
{
XSB_Deref(term);
switch (cell_tag(term)) {
case XSB_STRING:
return TRUE;
case XSB_STRUCT:
{
Psc psc;
CPtr taddr;
int i, arity;
register Cell addr;
mini_trail_top = (CPtr *)(& mini_trail[0]) - 1;
psc = get_str_psc(term);
taddr = clref_val(term);
arity = (int) get_arity(psc);
for (i = 1; i <= arity ; ++i) {
addr = cell(taddr+i);
XSB_Deref(addr);
if (isnonvar(addr)) {
mini_undo_bindings;
return FALSE;
} else {
mini_bind_variable(addr);
}
}
mini_undo_bindings;
return TRUE;
}
case XSB_LIST:
{
register Cell addr;
mini_trail_top = (CPtr *) (& mini_trail[0]) -1;
while (islist(term)) {
addr = cell(clref_val(term));
XSB_Deref(addr);
if (isnonvar(addr)) {
mini_undo_bindings;
return FALSE;
} else {
mini_bind_variable(addr);
term = cell(clref_val(term)+1);
XSB_Deref(term);
}
}
mini_undo_bindings;
return isnil(term);
}
default:
return FALSE;
}
}
/* -------------------------------------------------------------------- */
#include "term_psc_xsb_i.h"
#include "conget_xsb_i.h"
/* -------------------------------------------------------------------- */
inline static void xsb_fprint_variable(FILE *fptr, CPtr var)
{
if (var >= (CPtr)glstack.low && var <= top_of_heap)
fprintf(fptr, "_h%ld", ((Cell)var-(Cell)glstack.low+1)/sizeof(CPtr));
else {
if (var >= top_of_localstk && var <= (CPtr)glstack.high)
fprintf(fptr, "_l%ld", ((Cell)glstack.high-(Cell)var+1)/sizeof(CPtr));
else fprintf(fptr, "_%p", var); /* Should never happen */
}
}
void xsb_sprint_variable(char *sptr, CPtr var)
{
if (var >= (CPtr)glstack.low && var <= top_of_heap)
sprintf(sptr, "_h%ld", ((Cell)var-(Cell)glstack.low+1)/sizeof(CPtr));
else {
if (var >= top_of_localstk && var <= (CPtr)glstack.high)
sprintf(sptr, "_l%ld", ((Cell)glstack.high-(Cell)var+1)/sizeof(CPtr));
else sprintf(sptr, "_%p", var); /* Should never happen */
}
}
/* -------------------------------------------------------------------- */
STRFILE *iostrs[MAXIOSTRS] = {NULL,NULL,NULL,NULL,NULL};
/* -------------------------------------------------------------------- */
Cell builtin_table[BUILTIN_TBL_SZ][2];
#define BuiltinName(Code) ( (char *)builtin_table[Code][0] )
#define set_builtin_table(Code,String) \
builtin_table[Code][0] = (Cell)(String);
void init_builtin_table(void)
{
int i;
for (i = 0; i < BUILTIN_TBL_SZ; i++) builtin_table[i][1] = 0;
set_builtin_table(PSC_NAME, "psc_name");
set_builtin_table(PSC_ARITY, "psc_arity");
set_builtin_table(PSC_TYPE, "psc_type");
set_builtin_table(PSC_PROP, "psc_prop");
set_builtin_table(PSC_SET_TYPE, "psc_set_type");
set_builtin_table(PSC_SET_PROP, "psc_set_prop");
set_builtin_table(CONGET_TERM, "conget");
set_builtin_table(CONSET_TERM, "conset");
set_builtin_table(PSC_SET_SPY, "psc_set_spy");
set_builtin_table(PSC_EP, "psc_ep");
set_builtin_table(PSC_SET_EP, "psc_set_ep");
set_builtin_table(TERM_PSC, "term_psc");
set_builtin_table(TERM_TYPE, "term_type");
set_builtin_table(TERM_COMPARE, "term_compare");
set_builtin_table(TERM_NEW, "term_new");
set_builtin_table(TERM_ARG, "term_arg");
set_builtin_table(TERM_SET_ARG, "term_set_arg");
set_builtin_table(STAT_FLAG, "stat_flag");
set_builtin_table(STAT_SET_FLAG, "stat_set_flag");
set_builtin_table(BUFF_ALLOC, "buff_alloc");
set_builtin_table(BUFF_WORD, "buff_word");
set_builtin_table(BUFF_SET_WORD, "buff_set_word");
set_builtin_table(BUFF_BYTE, "buff_byte");
set_builtin_table(BUFF_SET_BYTE, "buff_set_byte");
set_builtin_table(CODE_CALL, "code_call");
set_builtin_table(STR_LEN, "str_len");
set_builtin_table(SUBSTRING, "substring");
set_builtin_table(STR_CAT, "str_cat");
set_builtin_table(STR_CMP, "str_cmp");
set_builtin_table(STRING_SUBSTITUTE, "string_substitute");
set_builtin_table(CALL0, "call0");
set_builtin_table(STAT_STA, "stat_sta");
set_builtin_table(STAT_CPUTIME, "stat_cputime");
set_builtin_table(CODE_LOAD, "code_load");
set_builtin_table(BUFF_SET_VAR, "buff_set_var");
set_builtin_table(BUFF_DEALLOC, "buff_dealloc");
set_builtin_table(BUFF_CELL, "buff_cell");
set_builtin_table(BUFF_SET_CELL, "buff_set_cell");
set_builtin_table(COPY_TERM,"copy_term");
set_builtin_table(STR_MATCH, "str_match");
set_builtin_table(DIRNAME_CANONIC, "dirname_canonic");
set_builtin_table(PSC_INSERT, "psc_insert");
set_builtin_table(PSC_IMPORT, "psc_import");
set_builtin_table(PSC_INSERTMOD, "psc_insertmod");
set_builtin_table(FILE_GETTOKEN, "file_gettoken");
set_builtin_table(FILE_PUTTOKEN, "file_puttoken");
set_builtin_table(TERM_HASH, "term_hash");
set_builtin_table(UNLOAD_SEG, "unload_seg");
set_builtin_table(LOAD_OBJ, "load_obj");
set_builtin_table(GETENV, "getenv");
set_builtin_table(SYS_SYSCALL, "sys_syscall");
set_builtin_table(SYS_SYSTEM, "sys_system");
set_builtin_table(SYS_GETHOST, "sys_gethost");
set_builtin_table(SYS_ERRNO, "sys_errno");
set_builtin_table(FILE_WRITEQUOTED, "file_writequoted");
set_builtin_table(GROUND, "ground");
set_builtin_table(INTERN_STRING, "intern_string");
set_builtin_table(EXPAND_FILENAME, "expand_filename");
set_builtin_table(TILDE_EXPAND_FILENAME, "tilde_expand_filename");
set_builtin_table(IS_ABSOLUTE_FILENAME, "is_absolute_filename");
set_builtin_table(PARSE_FILENAME, "parse_filename");
set_builtin_table(ALMOST_SEARCH_MODULE, "almost_search_module");
set_builtin_table(EXISTING_FILE_EXTENSION, "existing_file_extension");
set_builtin_table(DO_ONCE, "do_once");
set_builtin_table(GET_DATE, "get_date");
set_builtin_table(STAT_WALLTIME, "stat_walltime");
set_builtin_table(PSC_ENV, "psc_env");
set_builtin_table(PSC_SPY, "psc_spy");
set_builtin_table(PSC_TABLED, "psc_tabled");
set_builtin_table(IS_INCOMPLETE, "is_incomplete");
set_builtin_table(GET_PTCP, "get_ptcp");
set_builtin_table(GET_PRODUCER_CALL, "get_producer_call");
set_builtin_table(DEREFERENCE_THE_BUCKET, "dereference_the_bucket");
set_builtin_table(PAIR_PSC, "pair_psc");
set_builtin_table(PAIR_NEXT, "pair_next");
set_builtin_table(NEXT_BUCKET, "next_bucket");
set_builtin_table(SLG_NOT, "slg_not");
set_builtin_table(IS_XWAMMODE, "is_xwammode");
set_builtin_table(CLOSE_OPEN_TABLES, "close_open_tables");
set_builtin_table(FILE_FUNCTION, "file_function");
set_builtin_table(SLASH_BUILTIN, "slash");
set_builtin_table(ABOLISH_TABLE_INFO, "abolish_table_info");
set_builtin_table(ABOLISH_MODULE_TABLES, "abolish_module_tables");
set_builtin_table(ZERO_OUT_PROFILE, "zero_out_profile");
set_builtin_table(WRITE_OUT_PROFILE, "write_out_profile");
set_builtin_table(ASSERT_CODE_TO_BUFF, "assert_code_to_buff");
set_builtin_table(ASSERT_BUFF_TO_CLREF, "assert_buff_to_clref");
set_builtin_table(FILE_READ_CANONICAL, "file_read_canonical");
set_builtin_table(GEN_RETRACT_ALL, "gen_retract_all");
set_builtin_table(DB_RETRACT0, "db_retract0");
set_builtin_table(DB_GET_CLAUSE, "db_get_clause");
set_builtin_table(DB_BUILD_PRREF, "db_build_prref");
set_builtin_table(DB_REMOVE_PRREF, "db_remove_prref");
set_builtin_table(DB_RECLAIM0, "db_reclaim0");
set_builtin_table(FORMATTED_IO, "formatted_io");
set_builtin_table(TABLE_STATUS, "table_status");
set_builtin_table(GET_DELAY_LISTS, "get_delay_lists");
set_builtin_table(ABOLISH_TABLE_PREDICATE, "abolish_table_pred");
set_builtin_table(ABOLISH_TABLE_CALL, "abolish_table_call");
set_builtin_table(TRIE_ASSERT, "trie_assert");
set_builtin_table(TRIE_RETRACT, "trie_retract");
set_builtin_table(TRIE_RETRACT_SAFE, "trie_retract_safe");
set_builtin_table(TRIE_DELETE_RETURN, "trie_delete_return");
set_builtin_table(TRIE_GET_RETURN, "trie_get_return");
/* Note: TRIE_GET_CALL previously used for get_calls/1, before get_call/3
was made a builtin itself. */
set_builtin_table(TRIE_UNIFY_CALL, "get_calls");
set_builtin_table(GET_LASTNODE_CS_RETSKEL, "get_lastnode_cs_retskel");
set_builtin_table(TRIE_GET_CALL, "get_call");
set_builtin_table(BREG_RETSKEL,"breg_retskel");
set_builtin_table(TRIMCORE, "trimcore");
set_builtin_table(NEWTRIE, "newtrie");
set_builtin_table(TRIE_INTERN, "trie_intern");
set_builtin_table(TRIE_INTERNED, "trie_interned");
set_builtin_table(TRIE_DISPOSE, "trie_dispose");
set_builtin_table(BOTTOM_UP_UNIFY, "bottom_up_unify");
set_builtin_table(DELETE_TRIE, "delete_trie");
set_builtin_table(TRIE_DISPOSE_NR, "trie_dispose_nr");
set_builtin_table(TRIE_UNDISPOSE, "trie_undispose");
set_builtin_table(RECLAIM_UNINTERNED_NR, "reclaim_uninterned_nr");
set_builtin_table(SET_TABLED_EVAL, "set_tabled_eval_method");
set_builtin_table(PUT_ATTRIBUTES, "put_attributes");
set_builtin_table(GET_ATTRIBUTES, "get_attributes");
set_builtin_table(DELETE_ATTRIBUTES, "delete_attributes");
set_builtin_table(ATTV_UNIFY, "attv_unify");
set_builtin_table(PRIVATE_BUILTIN, "private_builtin");
set_builtin_table(SEGFAULT_HANDLER, "segfault_handler");
set_builtin_table(IS_ATTV, "is_attv");
set_builtin_table(VAR, "var");
set_builtin_table(NONVAR, "nonvar");
set_builtin_table(ATOM, "atom");
set_builtin_table(INTEGER, "integer");
set_builtin_table(REAL, "real");
set_builtin_table(NUMBER, "number");
set_builtin_table(ATOMIC, "atomic");
set_builtin_table(COMPOUND, "compound");
set_builtin_table(CALLABLE, "callable");
set_builtin_table(IS_LIST, "is_list");
set_builtin_table(FUNCTOR, "functor");
set_builtin_table(ARG, "arg");
set_builtin_table(UNIV, "univ");
set_builtin_table(IS_MOST_GENERAL_TERM, "is_most_general_term");
set_builtin_table(HiLog_ARG, "hilog_arg");
set_builtin_table(HiLog_UNIV, "hilog_univ");
set_builtin_table(ATOM_CODES, "atom_codes");
set_builtin_table(ATOM_CHARS, "atom_chars");
set_builtin_table(NUMBER_CHARS, "number_chars");
set_builtin_table(NUMBER_CODES, "number_codes");
set_builtin_table(IS_CHARLIST, "is_charlist");
set_builtin_table(NUMBER_DIGITS, "number_digits");
set_builtin_table(PUT, "put");
set_builtin_table(TAB, "tab");
set_builtin_table(SORT, "sort");
set_builtin_table(KEYSORT, "keysort");
set_builtin_table(ORACLE_QUERY, "oracle_query");
set_builtin_table(ODBC_EXEC_QUERY, "odbc_exec_query");
set_builtin_table(SET_SCOPE_MARKER, "set_scope_marker");
set_builtin_table(UNWIND_STACK, "unwind_stack");
set_builtin_table(CLEAN_UP_BLOCK, "clean_up_block");
set_builtin_table(XSB_POW, "xsb_pow");
set_builtin_table(PRINT_LS, "print_ls");
set_builtin_table(PRINT_TR, "print_tr");
set_builtin_table(PRINT_HEAP, "print_heap");
set_builtin_table(PRINT_CP, "print_cp");
set_builtin_table(PRINT_REGS, "print_regs");
set_builtin_table(PRINT_ALL_STACKS, "print_all_stacks");
set_builtin_table(MARK_HEAP, "mark_heap");
set_builtin_table(GC_HEAP, "gc_heap");
set_builtin_table(FINDALL_INIT, "$$findall_init");
set_builtin_table(FINDALL_ADD, "$$findall_add");
set_builtin_table(FINDALL_GET_SOLS, "$$findall_get_solutions");
#ifdef HAVE_SOCKET
set_builtin_table(SOCKET_REQUEST, "socket_request");
#endif
set_builtin_table(JAVA_INTERRUPT, "setupJavaInterrupt");
set_builtin_table(FORCE_TRUTH_VALUE, "force_truth_value");
set_builtin_table(INTERPROLOG_CALLBACK, "interprolog_callback");
}
/*----------------------------------------------------------------------*/
inline static xsbBool is_completed_table(TIFptr tif) {
VariantSF sf;
for ( sf = TIF_Subgoals(tif); IsNonNULL(sf);
sf = (VariantSF)subg_next_subgoal(sf) )
if ( ! is_completed(sf) )
return FALSE;
return TRUE;
}
/*----------------------------------------------------------------------*/
inline static int abolish_table_predicate(Psc psc)
{
TIFptr tif;
tif = get_tip(psc);
if ( IsNULL(tif) )
xsb_abort("[abolish_table] Attempt to delete untabled predicate (%s/%d)\n",
get_name(psc), get_arity(psc));
if ( ! is_completed_table(tif) )
return 0;
delete_predicate_table(tif);
return 1;
}
inline static void abolish_table_info(void)
{
CPtr csf;
TIFptr pTIF;
for ( csf = top_of_complstk; csf != COMPLSTACKBOTTOM;
csf = csf + COMPLFRAMESIZE )
if ( ! is_completed(compl_subgoal_ptr(csf)) )
xsb_abort("Illegal table operation"
"\n\t Cannot abolish incomplete tables");
for ( pTIF = tif_list.first; IsNonNULL(pTIF); pTIF = TIF_NextTIF(pTIF) ) {
TIF_CallTrie(pTIF) = NULL;
TIF_Subgoals(pTIF) = NULL;
}
reset_freeze_registers;
openreg = COMPLSTACKBOTTOM;
release_all_tabling_resources();
abolish_wfs_space();
}
void abolish_if_tabled(Psc psc)
{
CPtr ep;
ep = (CPtr) get_ep(psc);
switch (*(pb)ep) {
case tabletry:
case tabletrysingle:
abolish_table_predicate(psc);
break;
case test_heap:
if (*(pb)(ep+2) == tabletry || *(pb)(ep+2) == tabletrysingle)
abolish_table_predicate(psc);
break;
case switchon3bound:
case switchonbound:
case switchonterm:
if (*(pb)(ep+3) == tabletry || *(pb)(ep+3) == tabletrysingle)
abolish_table_predicate(psc);
break;
}
}
int abolish_usermod_tables(void)
{
int i;
Pair pair;
Psc psc;
for (i=0; i<symbol_table.size; i++) {
if ((pair = (Pair) *(symbol_table.table + i))) {
byte type;
psc = pair_psc(pair);
type = get_type(psc);
if (type == T_DYNA || type == T_PRED)
if (!strcmp(get_name(get_data(psc)),"usermod") ||
!strcmp(get_name(get_data(psc)),"global"))
abolish_if_tabled(psc);
}
}
return TRUE;
}
int abolish_module_tables(const char *module_name)
{
Pair modpair, pair;
byte type;
Psc psc, module;
modpair = (Pair) flags[MOD_LIST];
while (modpair &&
strcmp(module_name,get_name(pair_psc(modpair))))
modpair = pair_next(modpair);
if (!modpair) {
xsb_warn("[abolish_module_tables] Module %s not found.\n",
module_name);
return FALSE;
}
module = pair_psc(modpair);
pair = (Pair) get_data(module);
while (pair) {
psc = pair_psc(pair);
type = get_type(psc);
if (type == T_DYNA || type == T_PRED)
abolish_if_tabled(psc);
pair = pair_next(pair);
}
return TRUE;
}
/* -------------------------------------------------------------------- */
#ifdef PROFILE
static void write_out_profile(void)
{
unsigned long i, isum, ssum, tot;
double rat1, rat2;
isum = ssum = tot = 0;
for (i = 0; i < BUILTIN_TBL_SZ; i++) {
if (inst_table[i][0] != 0) isum = isum + inst_table[i][5];
}
for (i = 0; i < BUILTIN_TBL_SZ; i++) {
if (subinst_table[i][0] != 0) ssum = ssum + subinst_table[i][1];
}
tot = isum + ssum;
if (tot!=0) {
fprintf(stdout,
"max subgoals %u max completed %u max consumers in ascc %u max compl_susps in ascc %u\n",
max_subgoals,max_completed,max_consumers_in_ascc,
max_compl_susps_in_ascc);
rat1 = isum / tot;
rat2 = ssum / tot;
fprintf(stdout,
"trapped Prolog choice point memory (%d bytes).\n",trapped_prolog_cps);
fprintf(stdout,
"summary(total(%d),inst(%d),pct(%f),subinst(%d),pct(%f)).\n",
tot,isum,rat1,ssum,rat2);
for (i = 0; i < BUILTIN_TBL_SZ; i++) {
if (inst_table[i][5] != 0)
fprintf(stdout,"instruction(%s,%x,%d,%.3f).\n",
(char *) inst_table[i][0],i,
inst_table[i][5],(((float)inst_table[i][5])/(float)tot));
}
/* fprintf(stdout,"_______________subinsts_______________\n"); */
for (i = 0; i < BUILTIN_TBL_SZ; i++) {
if (subinst_table[i][0] != 0) {
ssum = subinst_table[i][1];
rat1 = ssum/tot;
fprintf(stdout,"subinst(%s,%x,%d,%g).\n",
(char *) subinst_table[i][0],i,
subinst_table[i][1],rat1);
}
}
/* fprintf(stdout,"_______________builtins_______________\n"); */
for (i = 0; i < BUILTIN_TBL_SZ; i++)
if (builtin_table[i][1] > 0 && builtin_table[i][0] != 0)
fprintf(stdout,"builtin(%s,%d,%d).\n",
BuiltinName(i), i, builtin_table[i][1]);
fprintf(stdout,"switch_envs(%d).\n",
num_switch_envs);
fprintf(stdout,"switch_envs_iter(%d).\n",
num_switch_envs_iter);
}
else
fprintf(stdout,"Instruction profiling not turned On\n");
}
#endif
/*----------------------------------------------------------------------*/
/* inlined definition of file_function */
#include "io_builtins_xsb_i.h"
/* inlined functions for prolog standard builtins */
#include "std_pred_xsb_i.h"
#include "call_xsb_i.h"
/* --- built in predicates -------------------------------------------- */
int builtin_call(byte number)
{
switch (number) {
case PSC_NAME: { /* R1: +PSC; R2: -String */
Psc psc = (Psc)ptoc_addr(1);
ctop_string(2, get_name(psc));
break;
}
case PSC_ARITY: { /* R1: +PSC; R2: -int */
Psc psc = (Psc)ptoc_addr(1);
ctop_int(2, (Integer)get_arity(psc));
break;
}
case PSC_TYPE: { /* R1: +PSC; R2: -int */
/* type: see psc_xsb.h, `entry_type' field defs */
Psc psc = (Psc)ptoc_addr(1);
ctop_int(2, (Integer)get_type(psc));
break;
}
case PSC_SET_TYPE: { /* R1: +PSC; R2: +type (int): see psc_xsb.h */
Psc psc = (Psc)ptoc_addr(1);
set_type(psc, ptoc_int(2));
break;
}
case PSC_PROP: { /* R1: +PSC; R2: -term */
/* prop: as a buffer pointer */
Psc psc = (Psc)ptoc_addr(1);
if (get_type(psc) == T_PRED || get_type(psc) == T_DYNA)
xsb_abort("[psc_prop/2] Cannot get property of predicate.\n");
ctop_int(2, (Integer)get_data(psc));
break;
}
case PSC_SET_PROP: { /* R1: +PSC; R2: +int */
Psc psc = (Psc)ptoc_addr(1);
if (get_type(psc) == T_PRED)
xsb_abort("[psc_set_prop/2] Cannot set property of predicate.\n");
set_data(psc, (Psc)ptoc_int(2));
break;
}
case CONGET_TERM: {
Integer res = conget((Cell)ptoc_tag(1));
prolog_term arg2 = reg_term(2);
if (isref(arg2)) {
c2p_int(res,arg2);
return TRUE;
} else {
return (int_val(arg2) == res);
}
}
case CONSET_TERM: {
return conset((Cell)ptoc_tag(1), (Integer)ptoc_int(2));
}
case PSC_EP: { /* R1: +PSC; R2: -term */
/* prop: as a buffer pointer */
Psc psc = (Psc)ptoc_addr(1);
ctop_int(2, (Integer)get_ep(psc));
break;
}
case PSC_SET_EP: { /* R1: +PSC; R2: +int */
Psc psc = (Psc)ptoc_addr(1);
pb ep = (pb)ptoc_int(2);
set_ep(psc, (ep==NULL?((byte *)(&(psc->load_inst))):ep));
break;
}
case PSC_SET_SPY: { /* R1: +PSC; R2: +int */
Psc psc = (Psc)ptoc_addr(1);
set_spy(psc, ptoc_int(2));
break;
}
case FILE_FUNCTION: /* file_open/close/put/get/truncate/seek/pos */
return file_function();
case TERM_PSC: /* R1: +term; R2: -PSC */
/* Assumes that `term' is a XSB_STRUCT-tagged Cell. */
/* ctop_addr(2, get_str_psc(ptoc_tag(1))); */
ctop_addr(2, term_psc((Cell)(ptoc_tag(1))));
break;
case TERM_TYPE: { /* R1: +term; R2: tag (-int) */
/* <0 - var, 1 - cs, 2 - int, 3 - list, 7 - ATTV> */
Cell term = ptoc_tag(1);
if (isref(term)) ctop_int(2, 0);
else ctop_int(2, cell_tag(term));
break;
}
case TERM_COMPARE: /* R1, R2: +term; R3: res (-int) */
ctop_int(3, compare((void *)ptoc_tag(1), (void *)ptoc_tag(2)));
break;
case TERM_NEW: { /* R1: +PSC, R2: -term */
int disp;
Psc psc = (Psc)ptoc_addr(1);
sreg = hreg;
hreg += get_arity(psc) + 1;
ctop_constr(2, (Pair)sreg);
new_heap_functor(sreg, psc);
for (disp=0; disp < (int)get_arity(psc); sreg++,disp++) {
bld_free(sreg);
}
break;
}
case TERM_ARG: { /* R1: +term; R2: index (+int); R3: arg (-term) */
int disp = ptoc_int(2);
Cell term = ptoc_tag(1);
ctop_tag(3, cell(clref_val(term)+disp));
break;
}
case TERM_SET_ARG: { /* R1: +term; R2: index (+int) */
/* R3: newarg (+term); R4: +perm(not used) */
/* used in file_read.P, array.P, array1.P */
int disp = ptoc_int(2);
Cell term = ptoc_tag(1);
if (!ptoc_int(4)) { pushtrail(clref_val(term)+disp,cell(reg+3));}
bld_copy(clref_val(term)+disp, cell(reg+3));
break;
}
case STAT_FLAG: /* R1: flagname(+int); R2: value(-int) */
ctop_int(2, flags[ptoc_int(1)]);
break;
case STAT_SET_FLAG: /* R1: flagname(+int); R2: value(+int); */
flags[ptoc_int(1)] = ptoc_int(2);
if (flags[DEBUG_ON]||flags[TRACE_STA]||flags[HITRACE]||flags[CLAUSE_INT])
asynint_val |= MSGINT_MARK;
else asynint_val &= ~MSGINT_MARK;
break;
case BUFF_ALLOC: { /* R1: size (+integer); R2: -buffer; */
/* the length of the buffer is also stored at position 0 */
char *addr;
int value = ((ptoc_int(1)+7)>>3)<<3;
value *= ZOOM_FACTOR ;
addr = (char *)mem_alloc(value);
value /= ZOOM_FACTOR ;
*(Integer *)addr = value; /* store buffer size at buf[0] */
ctop_int(2, (Integer)addr); /* use "integer" type now! */
break;
}
case BUFF_DEALLOC: { /* R1: +buffer; R2: +oldsize; R3: +newsize; */
int value;
char *addr = (char *) ptoc_int(1);
int disp = ((ptoc_int(2)+7)>>3)<<3;
disp *= ZOOM_FACTOR ;
value = ((ptoc_int(3)+7)>>3)<<3; /* alignment */
value *= ZOOM_FACTOR ;
if (value > disp) {
xsb_warn("[BUFF_DEALLOC] New Buffer Size (%d) Cannot exceed the old one (%d)!!",
value, disp);
break;
}
mem_dealloc((byte *)(addr+value), disp-value);
break;
}
case BUFF_WORD: { /* R1: +buffer; r2: displacement(+integer); */
/* R3: value (-integer) */
char *addr = (char *) ptoc_int(1);
int disp = ptoc_int(2);
disp *= ZOOM_FACTOR ;
ctop_int(3, *(Integer *)(addr+disp));
break;
}
case BUFF_SET_WORD: { /* R1: +buffer; r2: displacement(+integer); */
/* R3: value (+integer) */
char *addr = (char *) ptoc_int(1);
int disp = ptoc_int(2);
disp *= ZOOM_FACTOR ;
*(CPtr)(addr+disp) = ptoc_int(3);
break;
}
case BUFF_BYTE: { /* R1: +buffer; r2: displacement(+integer); */
/* R3: value (-integer) */
char *addr = (char *) ptoc_int(1);
int disp = ptoc_int(2);
ctop_int(3, (Integer)(*(byte *)(addr+disp)));
break;
}
case BUFF_SET_BYTE: { /* R1: +buffer; R2: displacement(+integer); */
/* R3: value (+integer) */
char *addr = (char *) ptoc_int(1);
int disp = ptoc_int(2);
*(pb)(addr+disp) = ptoc_int(3);
break;
}
case BUFF_CELL: { /* R1: +buffer; R2: displacement(+integer); */
/* R3: -Cell at that location */
char *addr = (char *) ptoc_int(1);
int disp = ptoc_int(2);
disp *= ZOOM_FACTOR ;
ctop_tag(3, (Cell)(addr+disp));
break;
}
case BUFF_SET_CELL: { /* R1: +buffer; R2: displacement(+integer);*/
/* R3: type (+integer); R4: +term */
/* When disp<0, set the type of the buff itself */
/* The last function is not implemented */
int value;
char *addr = (char *) ptoc_int(1);
int disp = ptoc_int(2);
disp *= ZOOM_FACTOR ;
value = ptoc_int(3);
switch (value) {
case XSB_REF:
case XSB_REF1:
bld_ref(vptr(addr+disp), (CPtr)ptoc_int(4)); break;
case XSB_INT: {
int tmpval = ptoc_int(4);
bld_int(vptr(addr+disp), tmpval); break;
}
case XSB_FLOAT:
bld_float(vptr(addr+disp), ptoc_float(4)); break;
case XSB_STRUCT:
bld_cs(vptr(addr+disp), (Pair)ptoc_int(4)); break;
case XSB_STRING:
bld_string(vptr(addr+disp), (char *)ptoc_int(4)); break;
case XSB_LIST:
bld_list(vptr(addr+disp), (CPtr)ptoc_int(4)); break;
default:
xsb_warn("[BUFF_SET_CELL] Type %d is not implemented", value);
}
break;
}
case BUFF_SET_VAR: {
int disp;
Cell term;
char *addr;
/* This procedure is used to make an external variable pointing to the
buffer. The linkage inside the buffer will not be trailed so remains
after backtracking. */
/* R1: +buffer; R2: +disp; */
/* R3: +buffer length; R4: External var */
addr = (char *) ptoc_int(1);
disp = ptoc_int(2);
disp *= ZOOM_FACTOR;
term = ptoc_tag(4);
bld_free(vptr(addr+disp));
if ((Cell)term < (Cell)addr ||
(Cell)term > (Cell)addr+ptoc_int(3)) { /* var not in buffer, trail */
bind_ref(vptr(term), (CPtr)(addr+disp));
} else { /* already in buffer */
bld_ref(vptr(term), (CPtr)(addr+disp));
}
break;
}
case COPY_TERM: /* R1: +term to copy; R2: -variant */
return copy_term();
case CALL0: { /* R1: +Term, the call to be made */
/* Note: this procedure does not save cpreg, hence is more like */
/* an "execute" instruction, and must be used as the last goal!!!*/
Cell term = ptoc_tag(1);
/* in call_xsb_i.h */
return prolog_call0(term);
}
case CODE_CALL: { /* R1: +Code (addr), the code address */
/* R2: +Term, the call to be made */
/* R3: +Type, code type (same as psc->type) */
/* may need to resume interrupt testing here */
/* Note: this procedure does not save cpreg, hence is more like */
/* an "execute" instruction, and must be used as the last goal!!!*/
Cell term = ptoc_tag(2);
int value = ptoc_int(3); /* Cannot be delayed! R3 may be reused */
pcreg = (byte *)ptoc_int(1);
/* in call_xsb_i.h */
return prolog_code_call(term,value);
}
case SUBSTRING: /* R1: +String; R2,R3: +begin/end offset; R4: -OutSubstr */
return substring();
case STRING_SUBSTITUTE: /* R1: +Str, R2: [s(a1,b1),s(a2,b2),...],
R3: [str1,str2,...], R4: -OutStr */
return string_substitute();
case STR_LEN: { /* R1: +String; R2: -Length */
Cell term = ptoc_tag(1);
if (isstring(term)) {
char *addr = string_val(term);
return int_unify(makeint(strlen(addr)), ptoc_tag(2));
} else return FALSE;
}
case STR_CAT: /* R1: +Str1; R2: +Str2: R3: -Str3 */
return str_cat();
case STR_CMP: /* R1: +Str1; R2: +Str2: R3: -Res */
ctop_int(3, strcmp(ptoc_string(1), ptoc_string(2)));
break;
case STR_MATCH:
return str_match();
case INTERN_STRING: /* R1: +String1; R2: -String2 ; Intern string */
ctop_string(2, string_find(ptoc_string(1), 1));
break;
case STAT_STA: { /* R1: +Amount */
int value = ptoc_int(1);
print_statistics(value);
break;
}
case STAT_CPUTIME: { /* R1: -cputime, in miliseconds */
int value = (int)(cpu_time() * 1000);
ctop_int(1, value);
break;
}
case GET_DATE: {
int year=0, month=0, day=0, hour=0, minute=0, second=0;
get_date(&year,&month,&day,&hour,&minute,&second);
ctop_int(1,year);
ctop_int(2,month);
ctop_int(3,day);
ctop_int(4,hour);
ctop_int(5,minute);
ctop_int(6,second);
break;
}
case STAT_WALLTIME: {
int value;
value = (int) ((real_time() - realtime_count) * 1000);
ctop_int(1, value);
break;
}
case CODE_LOAD: /* R1: +FileName, bytecode file to be loaded */
/* R2: -int, addr of 1st instruction; */
/* 0 indicates an error */
/* R3 = 1 if exports to be exported, 0 otw */
ctop_int(2, (Integer)loader(ptoc_string(1), ptoc_int(3)));
break;
case PSC_INSERT: { /* R1: +String, symbol name
R2: +Arity
R3: -PSC, the new PSC
R4: +String, module to be inserted */
/* inserts or finds a symbol in a given module. */
/* When the given module is 0 (null string), current module is used. */
Psc psc;
Pair sym;
int value;
char *addr = ptoc_string(4);
if (addr)
psc = pair_psc(insert_module(0, addr));
else
psc = (Psc)flags[CURRENT_MODULE];
sym = insert(ptoc_string(1), (char)ptoc_int(2), psc, &value);
ctop_addr(3, pair_psc(sym));
break;
}
case PSC_IMPORT: { /* R1: +String, functor name to be imported
R2: +Arity
R3: +String, Module name where functor lives */
/*
* Creates a PSC record for a predicate and its module (if they
* don't already exist) and links the predicate into usermod.
*/
int value;
Psc psc = pair_psc(insert_module(0, ptoc_string(3)));
Pair sym = insert(ptoc_string(1), (char)ptoc_int(2), psc, &value);
if (value) /* if predicate is new */
set_data(pair_psc(sym), (psc));
env_type_set(pair_psc(sym), T_IMPORTED, T_ORDI, (xsbBool)value);
link_sym(pair_psc(sym), (Psc)flags[CURRENT_MODULE]);
break;
}
case FILE_GETTOKEN: { /* R1: +File, R2: +PrevCh, R3: -Type; */
/* R4: -Value, R5: -NextCh */
int tmpval = ptoc_int(1);
if ((tmpval < 0) && (tmpval >= -MAXIOSTRS))
token = GetToken(NULL,strfileptr(tmpval), ptoc_int(2));
else {
FILE* fptr;
SET_FILEPTR(fptr, tmpval);
token = GetToken(fptr, NULL, ptoc_int(2));
}
if (token->type == TK_ERROR) {
pcreg = (pb)&fail_inst;
}
else {
ctop_int(3, token->type);
ctop_int(5, token->nextch);
switch (token->type) {
case TK_ATOM : case TK_FUNC : case TK_STR : case TK_LIST :
case TK_VAR : case TK_VVAR : case TK_VARFUNC : case TK_VVARFUNC :
ctop_string(4, token->value);
break;
case TK_INT : case TK_INTFUNC :
ctop_int(4, *(long *)(token->value));
break;
case TK_REAL : case TK_REALFUNC :
{Float float_temp = (float)(*(double *)(token->value));
ctop_float(4, float_temp);
}
break;
case TK_PUNC : case TK_HPUNC :
ctop_int(4, *(token->value)); break;
case TK_EOC : case TK_EOF :
ctop_int(4, 0); break;
}
}
break;
}
case FILE_PUTTOKEN: { /* R1: +File, R2: +Type, R3: +Value; */
FILE* fptr;
int tmpval = ptoc_int(1);
SET_FILEPTR(fptr,tmpval);
switch (ptoc_int(2)) {
case XSB_FREE : {
CPtr var = (CPtr)ptoc_tag(3);
xsb_fprint_variable(fptr, var);
break;
}
case XSB_ATTV : {
CPtr var = (CPtr)dec_addr(ptoc_tag(3));
xsb_fprint_variable(fptr, var);
break;
}
case XSB_INT : fprintf(fptr, "%ld", (long)ptoc_int(3)); break;
case XSB_STRING : fprintf(fptr, "%s", ptoc_string(3)); break;
case XSB_FLOAT : fprintf(fptr, "%2.4f", ptoc_float(3)); break;
case TK_INT_0 : {
int tmp = (int) ptoc_int(3);
fix_bb4((byte *)&tmp);
fwrite(&tmp, 4, 1, fptr); break;
}
case TK_FLOAT_0: {
float ftmp = (float)ptoc_float(3);
fix_bb4((byte *)&ftmp);
fwrite(&ftmp, 4, 1, fptr); break;
}
case TK_PREOP : print_op(fptr, ptoc_string(3), 1); break;
case TK_INOP : print_op(fptr, ptoc_string(3), 2); break;
case TK_POSTOP : print_op(fptr, ptoc_string(3), 3); break;
case TK_QATOM : print_qatom(fptr, ptoc_string(3)); break;
case TK_QSTR : fprintf(fptr, "\"%s\"", ptoc_string(3)); break;
case TK_TERML : print_term_canonical(fptr, ptoc_tag(3), 1); break;
case TK_TERM : print_term_canonical(fptr, ptoc_tag(3), 0); break;
default : printf("flg: %d\n",ptoc_int(2));
xsb_abort("[FILE_PUTTOKEN] Unknown token type %d");
}
break;
}
case PSC_INSERTMOD: { /* R1: +String, Module name */
/* R2: +Def (4 - is a definition; 0 -not) */
/* R3: -PSC of the Module entry */
Pair sym = insert_module(ptoc_int(2), ptoc_string(1));
ctop_addr(3, pair_psc(sym));
break;
}
case TERM_HASH: /* R1: +Term */
/* R2: +Size (of hash table) */
/* R3: -HashVal */
ctop_int(3, ihash(val_to_hash(ptoc_tag(1)),ptoc_int(2)));
break;
case UNLOAD_SEG: /* R1: -Code buffer */
unload_seg((pseg)ptoc_int(1));
break;
case LOAD_OBJ: /* R1: +FileName, R2: +Module (Psc) */
/* R3: +ld option, R4: -InitAddr */
#ifdef FOREIGN
ctop_int(4, (Integer)load_obj(ptoc_string(1),(Psc)ptoc_addr(2),
ptoc_string(3)));
#else
xsb_abort("Loading foreign object files is not implemented for this configuration");
#endif
break;
case WH_RANDOM: /* R1: +Type of operation */
switch (ptoc_int(1)) {
case RET_RANDOM: /* return a random float in [0.0, 1.0) */
return ret_random();
break;
case GET_RAND: /* getrand */
return getrand();
break;
case SET_RAND: /* setrand */
setrand();
break;
}
break;
case EXPAND_FILENAME: /* R1: +FileName, R2: -ExpandedFileName */
ctop_string(2, string_find(expand_filename(ptoc_longstring(1)), 1));
break;
case TILDE_EXPAND_FILENAME: /* R1: +FileN, R2: -TildeExpanded FN */
ctop_string(2, string_find(tilde_expand_filename(ptoc_string(1)), 1));
break;
case IS_ABSOLUTE_FILENAME: /* R1: +FN. Ret 1 if name is absolute, 0 else */
return is_absolute_filename(ptoc_string(1));
case PARSE_FILENAME: { /* R1: +FN, R2: -Dir, R3: -Basename, R4: -Ext */
char *dir, *basename, *extension;
parse_filename(ptoc_string(1), &dir, &basename, &extension);
ctop_string(2, string_find(dir, 1));
ctop_string(3, string_find(basename, 1));
ctop_string(4, string_find(extension, 1));
break;
}
case ALMOST_SEARCH_MODULE: /* R1: +FileName, R2: -Dir, R3: -Mod,
R4: -Ext, R5: -BaseName */
return almost_search_module(ptoc_string(1));
case EXISTING_FILE_EXTENSION: { /* R1: +FileN, R2: ?Ext */
char *extension = existing_file_extension(ptoc_string(1));
if (extension == NULL) return FALSE;
else {
extension = string_find(extension,1);
return atom_unify(makestring(extension), ptoc_tag(2));
}
}
case DO_ONCE: { /* R1: +Breg */
#ifdef DEMAND
perform_once();
#else
xsb_abort("This executable was not compiled with support for demand.\n");
#endif
break;
}
case GETENV: { /* R1: +environment variable */
/* R2: -value of that environment variable */
char *env = getenv(ptoc_string(1));
if (env == NULL)
/* otherwise, string_find dumps core */
return FALSE;
else
ctop_string(2, string_find(env,1));
break;
}
case SYS_SYSCALL: /* R1: +int (call #, see <syscall.h> */
/* R2: -int, returned value */
/* R3, ...: Arguments */
ctop_int(2, sys_syscall(ptoc_int(1)));
break;
case SYS_SYSTEM: /* R1: call mubler, R2: +String (of command);
R3: -Int (res), or mode: read/write;
R4: undefined or Stream used for output/input
from/to the shell command. */
return sys_system(ptoc_int(1));
case SYS_GETHOST: {
/* +R1: a string indicating the host name */
/* +R2: a buffer (of length 16) for returned structure */
#ifdef HAVE_GETHOSTBYNAME
static struct hostent *hostptr;
hostptr = gethostbyname(ptoc_string(1));
memmove(ptoc_string(2), hostptr->h_addr, hostptr->h_length);
#else
xsb_abort("[SYS_GETHOST] Operation not available for this configuration");
#endif
break;
}
case SYS_ERRNO: /* R1: -Int (errno) */
ctop_int(1, errno);
break;
case FILE_WRITEQUOTED: {
FILE* fptr;
int tmpval = ptoc_int(1);
SET_FILEPTR(fptr, tmpval);
write_quotedname(fptr ,ptoc_string(2));
break;
}
case GROUND:
return ground((CPtr)ptoc_tag(1));
case PSC_ENV: { /* reg 1: +PSC; reg 2: -int */
/* env: 0 = exported, 1 = local, 2 = imported */
Psc psc = (Psc)ptoc_addr(1);
ctop_int(2, (Integer)get_env(psc));
break;
}
case PSC_SPY: { /* reg 1: +PSC; reg 2: -int */
/* env: 0 = non-spied else spied */
Psc psc = (Psc)ptoc_addr(1);
ctop_int(2, (Integer)get_spy(psc));
break;
}
case PSC_TABLED: { /* reg 1: +PSC; reg 2: -int */
Psc psc = (Psc)ptoc_addr(1);
ctop_int(2, (Integer)get_tip(psc));
break;
}
/*----------------------------------------------------------------------*/
#include "bineg_xsb_i.h"
/*----------------------------------------------------------------------*/
case GET_PRODUCER_CALL: {
const int Arity = 3;
const int regCallTerm = 1; /* in: tabled subgoal */
const int regSF = 2; /* out: subgoal frame of producer from
which subgoal can consume */
const int regRetTerm = 3; /* out: answer template in ret/N form */
Cell term;
Psc psc;
TIFptr tif;
void *sf;
Cell retTerm;
term = ptoc_tag(regCallTerm);
if ( isref(term) ) {
err_handle(INSTANTIATION, regCallTerm,
BuiltinName(GET_PRODUCER_CALL), Arity, "", term);
break;
}
psc = term_psc(term);
if ( IsNULL(psc) ) {
err_handle(TYPE, regCallTerm,
BuiltinName(GET_PRODUCER_CALL), Arity,
"Callable term", term);
break;
}
tif = get_tip(psc);
if ( IsNULL(tif) )
xsb_abort("Illegal table operation\n\t Untabled predicate (%s/%d)"
"\n\t In argument %d of %s/%d",
get_name(psc), get_arity(psc), regCallTerm,
BuiltinName(GET_PRODUCER_CALL), Arity);
if ( IsSubsumptivePredicate(tif) )
sf = get_subsumer_sf(term, tif, &retTerm);
else
sf = get_variant_sf(term, tif, &retTerm);
if ( IsNULL(sf) )
return FALSE;
ctop_addr(regSF, sf);
ctop_tag(regRetTerm, retTerm);
break;
}
case DEREFERENCE_THE_BUCKET:
/*
* Given an index into the symbol table, return the first Pair
* in that bucket's chain.
*/
ctop_int(2, (Integer)(symbol_table.table[ptoc_int(1)]));
break;
case PAIR_PSC:
ctop_addr(2, pair_psc((Pair)ptoc_addr(1)));
break;
case PAIR_NEXT:
ctop_addr(2, pair_next((Pair)ptoc_addr(1)));
break;
case NEXT_BUCKET: { /* R1: +Index of Symbol Table Bucket. */
/* R2: -Next Index (0 if end of Hash Table) */
int value = ptoc_int(1);
if ( ((unsigned int)value >= (symbol_table.size - 1)) || (value < 0) )
ctop_int(2, 0);
else
ctop_int(2, (value + 1));
break;
}
case IS_XWAMMODE: /* R1: -int flag for xwammode */
if (xwammode) ctop_int(1,1);
else ctop_int(1,0);
break;
case CLOSE_OPEN_TABLES: /* No registers needed */
remove_open_tables_reset_freezes();
break;
case ABOLISH_TABLE_INFO:
abolish_table_info();
break;
#ifdef PROFILE
case ZERO_OUT_PROFILE:
{
int i;
for (i = 0 ; i <= BUILTIN_TBL_SZ ; i++) {
inst_table[i][5] = 0;
builtin_table[i][1] = 0;
subinst_table[i][1] = 0;
}
num_switch_envs=0;
}
break;
case WRITE_OUT_PROFILE:
write_out_profile();
break;
#endif
case ASSERT_CODE_TO_BUFF:
assert_code_to_buff();
break;
case ASSERT_BUFF_TO_CLREF:
assert_buff_to_clref();
break;
case DIRNAME_CANONIC: /* R1: +Dirname, R2: -Canonicized Dirname:
If file is a directory, add trailing slash and
rectify filename (delete multiple slashes, '..' and
'.'. */
ctop_string(2, string_find(dirname_canonic(ptoc_string(1)), 1));
break;
case SLASH_BUILTIN: { /* R1: -Slash. Tells what kind of slash the OS uses */
static char slash_string[2];
slash_string[0] = SLASH;
slash_string[1] = '\0';
ctop_string(1, string_find(slash_string, 1));
break;
}
case FORMATTED_IO:
return formatted_io();
case FILE_READ_CANONICAL:
return read_canonical();
case GEN_RETRACT_ALL:
return gen_retract_all();
case DB_RETRACT0:
db_retract0();
break;
case DB_GET_CLAUSE:
db_get_clause();
break;
case DB_BUILD_PRREF:
db_build_prref();
break;
case DB_REMOVE_PRREF:
db_remove_prref();
break;
case DB_RECLAIM0:
db_reclaim0();
break;
/*----------------------------------------------------------------------*/
#include "std_cases_xsb_i.h"
#ifdef ORACLE
#include "oracle_xsb_i.h"
#endif
#ifdef XSB_ODBC
#include "odbc_xsb_i.h"
#else
case ODBC_EXEC_QUERY: {
xsb_exit("XSB not compiled with ODBC support.\nRecompile using the option --with-odbc.\n");
}
#endif
#ifdef XSB_INTERPROLOG
#include "interprolog_xsb_i.h"
#endif
/*----------------------------------------------------------------------*/
case TABLE_STATUS: {
/*
* Given a tabled goal, report on the following attributes:
* 1) Predicate Type: Variant, Subsumptive, or Untabled
* 2) Goal Type: Producer, Properly Subsumed Consumer, Has No
* Call Table Entry, or Undefined
* 3) Answer Set Status: Complete, Incomplete, or Undefined.
*
* Valid combinations reported by this routine:
* When the predicate is an untabled functor, then only one sequence
* is generated: Untabled,Undefined,Undefined
* Otherwise the following combinations are possible:
*
* GoalType AnsSetStatus Meaning
* -------- ------------ -------
* producer complete call exists; it is a completed producer.
* incomplete call exists; it is an incomplete producer.
*
* subsumed complete call exists; it's properly subsumed by a
* completed producer.
* incomplete call exists; it's properly subsumed by an
* incomplete producer.
*
* no_entry undefined is a completely new call, not subsumed by
* any other -> if this were to be called
* right now, it would be a producing call.
* complete there is no entry for this call, but if it
* were to be called right now, it would
* consume from a completed producer.
* (The call is properly subsumed.)
* incomplete same as previous, except the subsuming
* producer is incomplete.
*
* Notice that not only can these combinations describe the
* characteristics of a subgoal in the table, but they are also
* equipped to predict how a new goal would have been treated had it
* really been called.
*/
const int Arity = 4;
const int regGoalHandle = 1; /* in: either a term or a SF ptr */
const int regPredType = 2; /* out: status (as INT) */
const int regGoalType = 3; /* out: status (as INT) */
const int regAnsSetStatus = 4; /* out: status (as INT) */
int pred_type, goal_type, answer_set_status;
VariantSF goalSF, subsumerSF;
Cell goalTerm;
goalTerm = ptoc_tag(regGoalHandle);
if ( isref(goalTerm) ) {
err_handle(INSTANTIATION, regGoalHandle, BuiltinName(TABLE_STATUS),
Arity, "", goalTerm);
break;
}
if ( is_encoded_addr(goalTerm) ) {
goalSF = (VariantSF)decode_addr(goalTerm);
if ( ! smIsValidStructRef(smVarSF,goalSF) &&
! smIsValidStructRef(smProdSF,goalSF) &&
! smIsValidStructRef(smConsSF,goalSF) )
xsb_abort("Invalid Table Entry Handle\n\t Argument %d of %s/%d",
regGoalHandle, BuiltinName(TABLE_STATUS), Arity);
if ( IsProperlySubsumed(goalSF) )
subsumerSF = (VariantSF)conssf_producer(goalSF);
else
subsumerSF = goalSF;
pred_type = TIF_EvalMethod(subg_tif_ptr(subsumerSF));
}
else {
Psc psc;
TIFptr tif;
psc = term_psc(goalTerm);
if ( IsNULL(psc) ) {
err_handle(TYPE, regGoalHandle, BuiltinName(TABLE_STATUS),
4, "Callable term", goalTerm);
break;
}
tif = get_tip(psc);
if ( IsNULL(tif) ) {
ctop_int(regPredType, UNTABLED_PREDICATE);
ctop_int(regGoalType, UNDEFINED_CALL);
ctop_int(regAnsSetStatus, UNDEFINED_ANSWER_SET);
return TRUE;
}
pred_type = TIF_EvalMethod(tif);
if ( IsVariantPredicate(tif) )
goalSF = subsumerSF = get_variant_sf(goalTerm, tif, NULL);
else {
BTNptr root, leaf;
TriePathType path_type;
root = TIF_CallTrie(tif);
if ( IsNonNULL(root) )
leaf = subsumptive_trie_lookup(root, get_arity(psc),
clref_val(goalTerm) + 1,
&path_type, NULL);
else {
leaf = NULL;
path_type = NO_PATH;
}
if ( path_type == NO_PATH )
goalSF = subsumerSF = NULL;
else if ( path_type == VARIANT_PATH ) {
goalSF = CallTrieLeaf_GetSF(leaf);
if ( IsProperlySubsumed(goalSF) )
subsumerSF = (VariantSF)conssf_producer(goalSF);
else
subsumerSF = goalSF;
}
else {
goalSF = NULL;
subsumerSF = CallTrieLeaf_GetSF(leaf);
if ( IsProperlySubsumed(subsumerSF) )
subsumerSF = (VariantSF)conssf_producer(subsumerSF);
}
}
}
/*
* Now both goalSF and subsumerSF should be set for all cases.
* Determine status values based on these pointers.
*/
if ( IsNonNULL(goalSF) ) {
if ( goalSF == subsumerSF )
goal_type = PRODUCER_CALL;
else
goal_type = SUBSUMED_CALL;
}
else
goal_type = NO_CALL_ENTRY;
if ( IsNonNULL(subsumerSF) ) {
if ( is_completed(subsumerSF) )
answer_set_status = COMPLETED_ANSWER_SET;
else
answer_set_status = INCOMPLETE_ANSWER_SET;
}
else
answer_set_status = UNDEFINED_ANSWER_SET;
ctop_int(regPredType, pred_type);
ctop_int(regGoalType, goal_type);
ctop_int(regAnsSetStatus, answer_set_status);
return TRUE;
}
case ABOLISH_TABLE_PREDICATE: {
const int Arity = 1;
const int regTerm = 1; /* in: tabled predicate as term */
Cell term;
Psc psc;
term = ptoc_tag(regTerm);
if ( isref(term) ) {
err_handle(INSTANTIATION, regTerm,
BuiltinName(ABOLISH_TABLE_PREDICATE), Arity, "", term);
break;
}
psc = term_psc(term);
if ( IsNULL(psc) ) {
err_handle(TYPE, regTerm, BuiltinName(ABOLISH_TABLE_PREDICATE),
Arity, "Predicate specification", term);
break;
}
if (abolish_table_predicate(psc))
return TRUE;
else
xsb_abort("[abolish_table_pred] Cannot abolish incomplete table"
" of predicate %s/%d\n", get_name(psc), get_arity(psc));
}
case ABOLISH_TABLE_CALL: {
VariantSF subgoal;
ComplStackFrame csf;
TIFptr tif;
subgoal = (VariantSF) ptoc_int(1);
csf = (ComplStackFrame) subgoal->compl_stack_ptr;
tif = (TIFptr) subgoal->tif_ptr;
compl_subgoal_ptr(subg_compl_stack_ptr(subgoal)) = NULL;
reclaim_incomplete_table_structs(subgoal);
delete_branch(subgoal->leaf_ptr, &tif->call_trie);
return TRUE;
}
case ABOLISH_MODULE_TABLES: {
char *module_name;
module_name = ptoc_string(1);
if (!strcmp(module_name,"usermod") || !strcmp(module_name,"global"))
return abolish_usermod_tables();
else
return abolish_module_tables(module_name);
break;
}
case TRIE_ASSERT:
if (trie_assert())
return TRUE;
else
xsb_exit("Failure of trie_assert/1");
case TRIE_RETRACT:
if (trie_retract())
return TRUE;
else
xsb_exit("Failure of trie_retract/1");
case TRIE_RETRACT_SAFE:
return trie_retract_safe();
case TRIE_DELETE_RETURN: {
const int Arity = 2;
const int regTableEntry = 1; /* in: subgoal frame ref */
const int regReturnNode = 2; /* in: answer trie node */
VariantSF sf;
BTNptr leaf;
/*
* The primary purpose of this builtin is for the support of HiLog
* aggregation predicates, which are based upon variant tabling.
* So we currently disallow its use on subsumptive predicates.
*/
sf = ptoc_addr(regTableEntry);
if ( smIsValidStructRef(smProdSF,sf) ||
smIsValidStructRef(smConsSF,sf) )
xsb_abort("Invalid Table Entry Handle: Subsumptive table entry"
"\n\t Argument %d of %s/%d\n\t Answers for subsumptive"
" subgoals may not be deleted",
regTableEntry, BuiltinName(TRIE_DELETE_RETURN), Arity);
if ( ! smIsValidStructRef(smVarSF,sf) )
xsb_abort("Invalid Table Entry Handle\n\t Argument %d of %s/%d",
regTableEntry, BuiltinName(TRIE_DELETE_RETURN), Arity);
leaf = ptoc_addr(regReturnNode);
if ( ! smIsValidStructRef(smTableBTN,leaf) )
xsb_abort("Invalid Return Handle\n\t Argument %d of %s/%d",
regReturnNode, BuiltinName(TRIE_DELETE_RETURN), Arity);
if ( (! smIsAllocatedStruct(smTableBTN,leaf)) ||
(subg_ans_root_ptr(sf) != get_trie_root(leaf)) ||
(! IsLeafNode(leaf)) )
return FALSE;
delete_return(leaf,sf);
break;
}
case TRIE_GET_RETURN: {
const int Arity = 2;
const int regTableEntry = 1; /* in: subgoal frame ref */
const int regRetTerm = 2; /* in/out: ret/n term to unify against
answer substitutions */
VariantSF sf;
Cell retTerm;
sf = ptoc_addr(regTableEntry);
if ( ! smIsValidStructRef(smVarSF,sf) &&
! smIsValidStructRef(smProdSF,sf) &&
! smIsValidStructRef(smConsSF,sf) )
xsb_abort("Invalid Table Entry Handle\n\t Argument %d of %s/%d",
regTableEntry, BuiltinName(TRIE_GET_RETURN), Arity);
retTerm = ptoc_tag(regRetTerm);
if ( isref(retTerm) ) {
err_handle(INSTANTIATION, regRetTerm, BuiltinName(TRIE_GET_RETURN),
Arity, "", retTerm);
break;
}
pcreg = trie_get_returns(sf, retTerm);
break;
}
case TRIE_UNIFY_CALL: /* r1: +call_term */
pcreg = trie_get_calls();
break;
case GET_LASTNODE_CS_RETSKEL: {
const int regCallTerm = 1; /* in: call of a tabled predicate */
const int regTrieLeaf = 2; /* out: a unifying trie term handle */
const int regLeafChild = 3; /* out: usually to get subgoal frame */
const int regRetTerm = 4; /* out: term in ret/N form:
Call Trie -> answer template
Other Trie -> variable vector */
ctop_int(regTrieLeaf, (Integer)Last_Nod_Sav);
ctop_int(regLeafChild, (Integer)BTN_Child(Last_Nod_Sav));
ctop_tag(regRetTerm, get_lastnode_cs_retskel(ptoc_tag(regCallTerm)));
return TRUE;
}
case TRIE_GET_CALL: {
const int regCallTerm = 1; /* in: tabled call to look for */
const int regSF = 2; /* out: corresponding subgoal frame */
const int regRetTerm = 3; /* out: answer template in ret/N form */
Cell ret;
VariantSF sf;
sf = get_call(ptoc_tag(regCallTerm), &ret);
if ( IsNonNULL(sf) ) {
ctop_int(regSF, (Integer)sf);
ctop_tag(regRetTerm, ret);
return TRUE;
}
else
return FALSE;
}
case BREG_RETSKEL:
breg_retskel();
break;
case TRIMCORE:
/*
* In each case, check whether the initial size of the data area is
* large enough to contain the currently used portion of the data area.
*/
if (tcpstack.size != tcpstack.init_size)
if ( (unsigned int)((tcpstack.high - (byte *)top_of_cpstack) +
((byte *)top_of_trail - tcpstack.low))
< tcpstack.init_size * K - OVERFLOW_MARGIN )
tcpstack_realloc(tcpstack.init_size);
if (complstack.size != complstack.init_size)
if ( (unsigned int)(complstack.high - (byte *)openreg)
< complstack.init_size * K - OVERFLOW_MARGIN )
complstack_realloc(complstack.init_size);
if (glstack.size != glstack.init_size)
if ( (unsigned int)((glstack.high - (byte *)top_of_localstk) +
((byte *)hreg - glstack.low))
< glstack.init_size * K - OVERFLOW_MARGIN )
glstack_realloc(glstack.init_size,0);
tstShrinkDynStacks();
break;
case NEWTRIE:
ctop_int(1,newtrie());
break;
case TRIE_INTERN:
trie_intern();
break;
case TRIE_INTERNED:
return(trie_interned());
case TRIE_DISPOSE:
trie_dispose();
break;
case TRIE_DISPOSE_NR:
trie_dispose_nr();
break;
case TRIE_UNDISPOSE:
trie_undispose(ptoc_int(1), (BTNptr) ptoc_int(2));
break;
case RECLAIM_UNINTERNED_NR:
reclaim_uninterned_nr(ptoc_int(1));
break;
case STORAGE_BUILTIN: {
STORAGE_HANDLE *storage_handle =
storage_builtin(ptoc_int(1),(Cell)ptoc_tag(2));
if (storage_handle != NULL) {
ctop_int(3, (Integer)storage_handle->handle);
ctop_int(4, (Integer)storage_handle->snapshot_number);
ctop_int(5, (Integer)storage_handle->changed);
}
break;
}
case BOTTOM_UP_UNIFY:
return ( bottom_up_unify() );
case DELETE_TRIE:
if (strcmp(ptoc_string(2),"intern") == 0){
int tmpval = ptoc_int(1);
delete_interned_trie(tmpval);
}
else {
xsb_abort("[DELETE_TRIE] Invalid use of this operation");
}
break;
case SET_TABLED_EVAL: {
const int Arity = 2;
const int regTerm = 1; /* in: tabled predicate as term */
const int regTEM = 2; /* in: table eval method to use for pred */
Cell term;
Psc psc;
TIFptr tif;
term = ptoc_tag(regTerm);
if ( isref(term) ) {
err_handle(INSTANTIATION, regTerm, BuiltinName(SET_TABLED_EVAL),
Arity, "", term);
break;
}
psc = term_psc(term);
if ( IsNULL(psc) ) {
err_handle(TYPE, regTerm, BuiltinName(SET_TABLED_EVAL),
Arity, "Predicate specification", term);
break;
}
tif = get_tip(psc);
if ( IsNULL(tif) ) {
xsb_warn("Predicate %s/%d is not tabled", get_name(psc), get_arity(psc));
return FALSE;
}
if ( IsNonNULL(TIF_CallTrie(tif)) ) {
xsb_warn("Cannot change tabling method for tabled predicate %s/%d\n"
"\t Calls to %s/%d have already been issued\n",
get_name(psc), get_arity(psc), get_name(psc), get_arity(psc));
return FALSE;
}
TIF_EvalMethod(tif) = (TabledEvalMethod)ptoc_int(regTEM);
return TRUE;
}
/* TLS: useful for CLPQR -- see eval.P */
case XSB_POW:
ctop_float(3,pow(ptoc_number(1),ptoc_number(2)));
return TRUE ;
case PRINT_LS: print_ls(1) ; return TRUE ;
case PRINT_TR: print_tr(1) ; return TRUE ;
case PRINT_HEAP: print_heap(0,2000,1) ; return TRUE ;
case PRINT_CP: print_cp(1) ; return TRUE ;
case PRINT_REGS: print_regs(10,1) ; return TRUE ;
case PRINT_ALL_STACKS: print_all_stacks(10) ; return TRUE ;
case EXP_HEAP: glstack_realloc(glstack.size + 1,0) ; return TRUE ;
case MARK_HEAP: {
int tmpval;
mark_heap(ptoc_int(1),&tmpval);
return TRUE;
}
case GC_HEAP: return(gc_heap(0)) ;
/* This is the builtin where people should put their private, experimental
builtin code. SEE THE EXAMPLE IN private_builtin.c to UNDERSTAND HOW TO
DO IT. Note: even though this is a single builtin, YOU CAN SIMULATE ANY
NUMBER OF BUILTINS WITH IT. */
case PRIVATE_BUILTIN: return private_builtin();
case SEGFAULT_HANDLER: { /* Set the desired segfault handler:
+Arg1: none - don't catch segfaults;
warn - warn and exit;
catch - try to recover */
char *type = ptoc_string(1);
switch (*type) {
case 'w': /* warn: Warn and wuit */
xsb_default_segfault_handler = xsb_segfault_quitter;
break;
case 'n': /* none: Don't handle segfaults */
xsb_default_segfault_handler = SIG_DFL;
break;
case 'c': /* catch: Try to recover from all segfaults */
xsb_default_segfault_handler = xsb_segfault_catcher;
break;
default:
xsb_warn("Request for unsupported type of segfault handling, %s", type);
return TRUE;
}
#ifdef SIGBUS
signal(SIGBUS, xsb_default_segfault_handler);
#endif
signal(SIGSEGV, xsb_default_segfault_handler);
return TRUE;
}
case IS_CHARLIST: {
prolog_term size_var;
int size;
xsbBool retcode;
size_var = reg_term(2);
if (! isref(size_var)) {
xsb_abort("[IS_CHARLIST] Arg 2 must be a variable");
}
retcode = is_charlist(reg_term(1), &size);
c2p_int(size,size_var);
return retcode;
}
case FINDALL_INIT: return(findall_init()) ;
case FINDALL_ADD: return(findall_add()) ;
case FINDALL_GET_SOLS: return(findall_get_solutions()) ;
#ifdef HAVE_SOCKET
case SOCKET_REQUEST:
return xsb_socket_request();
#endif /* HAVE_SOCKET */
#ifdef WIN_NT
case JAVA_INTERRUPT:
return( startInterruptThread( (SOCKET)ptoc_int(1) ) );
#endif
case FORCE_TRUTH_VALUE: { /* +R1: AnsLeafPtr; +R2: TruthValue */
BTNptr as_leaf = (BTNptr)ptoc_addr(1);
char *tmpstr = ptoc_string(2);
if (!strcmp(tmpstr, "true"))
force_answer_true(as_leaf);
else if (!strcmp(tmpstr, "false"))
force_answer_false(as_leaf);
else xsb_abort("[FORCE_TRUTH_VALUE] Argument 2 has unknown truth value");
break;
}
case PUT_ATTRIBUTES: { /* R1: -Var; R2: +Atts */
Cell attv = ptoc_tag(1);
Cell atts = ptoc_tag(2);
if (isref(attv)) { /* attv is a free var */
if (!isnil(atts)) {
bind_attv((CPtr)attv, hreg);
bld_free(hreg); hreg++;
bld_copy(hreg, atts); hreg++;
}
}
else if (isattv(attv)) { /* attv is already an attv */
if (isnil(atts)) { /* change it back to normal var */
bind_ref((CPtr)dec_addr(attv), hreg);
bld_free(hreg); hreg++;
}
else { /* update the atts (another copy) */
bind_attv((CPtr)dec_addr(attv), hreg);
bld_free(hreg); hreg++;
bld_copy(hreg, atts); hreg++;
}
}
else xsb_abort("[PUT_ATTRIBUTES] Argument 1 is nonvar");
break;
}
case GET_ATTRIBUTES: { /* R1: +Var; R2: -Vector; R3: -OldMask */
Cell attv = ptoc_tag(1);
if (isref(attv)) { /* a free var */
/* ctop_tag(2, makenil); */ /* keep it as a free var */
ctop_tag(3, makeint(0));
}
else if (isattv(attv)) {
CPtr vector;
vector = (CPtr)dec_addr(attv) + 1;
ctop_tag(2, cell(vector));
ctop_tag(3, cell(clref_val(cell(vector)) + 1));
}
else xsb_abort("[GET_ATTRIBUTES] Argument 1 is not an attributed variable");
break;
}
case DELETE_ATTRIBUTES: { /* R1: -Var */
Cell attv = ptoc_tag(1);
if (isattv(attv)) {
bind_ref((CPtr)dec_addr(attv), hreg);
bld_free(hreg); hreg++;
}
break;
}
/*
* attv_unify/1 is an internal builtin for binding an attv to a value
* (it could be another attv or a nonvar term). The users can call
* this builtin in verify_attributes/2 to bind an attributed var
* without triggering attv interrupt.
*/
case ATTV_UNIFY: { /* R1: +Var; R2: +Value */
Cell attv = ptoc_tag(1);
if (isattv(attv)) {
bind_copy((CPtr)dec_addr(attv), ptoc_tag(2));
} else {
return FALSE;
}
break;
}
case SET_SCOPE_MARKER: {
if (set_scope_marker()) return TRUE; else return FALSE;
break;
}
case UNWIND_STACK: {
if (unwind_stack()) return TRUE; else return FALSE;
break;
}
case CLEAN_UP_BLOCK: {
if (clean_up_block()) return TRUE; else return FALSE;
break;
}
default:
xsb_exit("Builtin #%d is not implemented", number);
break;
} /* switch */
return TRUE; /* catch for every break from switch */
}
/*------------------------- end of builtin.c -----------------------------*/
syntax highlighted by Code2HTML, v. 0.9.1