mirror of https://github.com/lianthony/NT4.0
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
655 lines
15 KiB
655 lines
15 KiB
/* PREXTRA.C: Small-Prolog Extensions for PRBLTIN.C */
|
|
|
|
#include "prextra.h"
|
|
|
|
#include "prextern.h"
|
|
|
|
#ifdef REAL
|
|
static int real_from(void);
|
|
static int rleq(void);
|
|
static int rminus(void);
|
|
static int rmult(void);
|
|
static int rabs(void);
|
|
static int rdiv(void);
|
|
#endif
|
|
|
|
static int string_case(int upper);
|
|
static int string_upper(void);
|
|
static int string_lower(void);
|
|
static int check_one_token(char *s);
|
|
static int atom_from(void);
|
|
static int int_from(void);
|
|
|
|
static int idiv(void);
|
|
static int iabs(void);
|
|
static int bitor(void);
|
|
static int bitand(void);
|
|
static int bitxor(void);
|
|
static int bitright(void);
|
|
static int bitleft(void);
|
|
static int bitnot(void);
|
|
static int string_break(void);
|
|
static int scan_tok(int opCheck);
|
|
static int scan_token(void);
|
|
static int scan_tokop(void);
|
|
static int pstring_stdout(void);
|
|
static int nl_stdout(void);
|
|
static int putc_stdout(void);
|
|
static int alloc_percent(void);
|
|
static int abort_query(void);
|
|
static int dref_list ( int narg, char * * strings, char * * strLimit ) ;
|
|
static char * *drlist(struct node *nodeptr,struct subst *substptr,
|
|
char * *strings,char * *strLimit);
|
|
static char *get_output_name(void);
|
|
static int intFromString(char *s,long *result);
|
|
|
|
#define QuikDlogMaxStrings 100
|
|
#define QuikDsubstChar '|'
|
|
|
|
|
|
/* Given a list, dereference all the strings and build a 'C'-style table. */
|
|
|
|
static char * * drlist
|
|
( node_ptr_t nodeptr, subst_ptr_t substptr,
|
|
char * * strings, char * * strLimit )
|
|
{
|
|
node_ptr_t thenode ;
|
|
|
|
dereference( nodeptr, substptr ) ;
|
|
thenode = DerefNode ;
|
|
substptr = DerefSubst ;
|
|
if ( IS_NIL(thenode) ) return strings ;
|
|
|
|
if ( strings < strLimit ) {
|
|
switch ( NODEPTR_TYPE( thenode ) ) {
|
|
case INT:
|
|
default:
|
|
break ;
|
|
case ATOM:
|
|
*strings++ = ATOMPTR_NAME(NODEPTR_ATOM(thenode)) ;
|
|
break ;
|
|
case VAR:
|
|
break;
|
|
case STRING:
|
|
*strings++ = NODEPTR_STRING( thenode );
|
|
break ;
|
|
case PAIR:
|
|
strings = drlist( NODEPTR_HEAD( thenode ), substptr, strings, strLimit );
|
|
dereference( NODEPTR_TAIL( thenode ), substptr ) ;
|
|
if ( IS_NIL( DerefNode ) ) return strings ;
|
|
strings = drlist( DerefNode, DerefSubst, strings, strLimit );
|
|
break ;
|
|
}
|
|
}
|
|
return strings ;
|
|
}
|
|
|
|
static int dref_list ( int narg, char * * strings, char * * strLimit )
|
|
{
|
|
char * * strend ;
|
|
*strings = NULL ;
|
|
nth_arg(narg);
|
|
if ( NODEPTR_TYPE( DerefNode ) != PAIR && ( ! IS_NIL( DerefNode ) ) )
|
|
return FALSE ;
|
|
strend = drlist( DerefNode, DerefSubst, strings, strLimit );
|
|
*strend = NULL ;
|
|
return TRUE ;
|
|
}
|
|
|
|
|
|
static int intFromString ( char * s, integer * result )
|
|
{
|
|
char * c ;
|
|
integer i ;
|
|
for ( ; *s == ' ' ; s++ ) ; /* Skip leading blanks */
|
|
for ( i = 0, c = s ; *c ; c++ ) {
|
|
i *= 10 ;
|
|
if ( *c > '9' || *c < '0' ) break ;
|
|
i += *c - '0' ;
|
|
}
|
|
*result = i ;
|
|
return s < c ; /* If no numeric characters found, return FALSE */
|
|
}
|
|
|
|
static int string_case ( int upper )
|
|
{
|
|
char * s, * t ;
|
|
ARG_STRING( 1, s );
|
|
for ( t = s ; *t ; t++ ) *t = upper ? toupper(*t) : tolower(*t) ;
|
|
return(bind_string(2, s));
|
|
}
|
|
static int string_upper ()
|
|
{
|
|
return string_case( TRUE ) ;
|
|
}
|
|
static int string_lower ()
|
|
{
|
|
return string_case( FALSE ) ;
|
|
}
|
|
|
|
static int check_one_token ( char * s )
|
|
{
|
|
int result ;
|
|
char * temp; /* DEBUG */
|
|
|
|
Curr_string_input = s ;
|
|
if ( *s == 0 ) return EOF ;
|
|
String_input_flag = TRUE ;
|
|
result = scan();
|
|
String_input_flag = FALSE ;
|
|
for ( temp = Read_buffer ; *temp ; temp++ ) {
|
|
if ( *temp > 0x7f ) {
|
|
temp = temp ;
|
|
}
|
|
}
|
|
return result ;
|
|
}
|
|
|
|
/*
|
|
(atom_from "string" newatom)
|
|
Convert a string to an atom.
|
|
*/
|
|
static int atom_from ()
|
|
{
|
|
char * s ;
|
|
int result ;
|
|
atom_ptr_t atomptr ;
|
|
|
|
ARG_STRING( 1, s ) ;
|
|
result = check_one_token( s ) ;
|
|
if ( result != TOKEN_ATOM )
|
|
return FALSE ;
|
|
atomptr = intern( s );
|
|
return bind_atom( 2, atomptr ) ;
|
|
}
|
|
|
|
/* Convert a string to an integer; if illegal or null, fail. */
|
|
static int int_from ()
|
|
{
|
|
node_ptr_t nodeptr ;
|
|
integer i ;
|
|
Boolean ok = TRUE ;
|
|
int result ;
|
|
|
|
if ( ! (nodeptr = nth_arg(1)) )
|
|
return nargerr(1) ;
|
|
|
|
switch ( NODEPTR_TYPE(nodeptr) ) {
|
|
case STRING:
|
|
result = check_one_token( NODEPTR_STRING( nodeptr ) ) ;
|
|
if ( ! (ok = (result == TOKEN_INT)) ) break ;
|
|
ok = intFromString( NODEPTR_STRING( nodeptr ), & i ) ;
|
|
break ;
|
|
case INT:
|
|
i = NODEPTR_INT( nodeptr ) ;
|
|
break ;
|
|
#ifdef REAL
|
|
case REAL:
|
|
i = (integer) NODEPTR_REAL( nodeptr ) ;
|
|
break ;
|
|
#endif
|
|
default:
|
|
ok = FALSE ;
|
|
break ;
|
|
}
|
|
if ( ! ok ) return FALSE ;
|
|
return bind_int( 2, i ) ;
|
|
}
|
|
|
|
#ifdef REAL
|
|
|
|
static int real_from ()
|
|
{
|
|
node_ptr_t nodeptr ;
|
|
real r ;
|
|
Boolean ok = TRUE ;
|
|
int result ;
|
|
if ( ! (nodeptr = nth_arg(1)) )
|
|
return nargerr(1) ;
|
|
|
|
switch ( NODEPTR_TYPE(nodeptr) ) {
|
|
case STRING:
|
|
result = check_one_token( NODEPTR_STRING( nodeptr ) ) ;
|
|
if ( ! (ok = (result == TOKEN_REAL) ) ) break ; ;
|
|
r = atof( NODEPTR_STRING( nodeptr ) ) ;
|
|
break ;
|
|
case INT:
|
|
r = NODEPTR_INT( nodeptr ) ;
|
|
break ;
|
|
case REAL:
|
|
r = NODEPTR_REAL( nodeptr ) ;
|
|
break ;
|
|
default:
|
|
ok = FALSE ;
|
|
break ;
|
|
}
|
|
if ( ! ok ) return FALSE ;
|
|
return bind_real( 2, r ) ;
|
|
}
|
|
|
|
/**********************************************************************
|
|
(rleq <arg1:real><arg2:real>)
|
|
***********************************************************************/
|
|
static int rleq()
|
|
{
|
|
real i1, i2;
|
|
|
|
ARG_REAL(1, i1);
|
|
ARG_REAL(2, i2);
|
|
|
|
return(i1 <= i2);
|
|
}
|
|
|
|
/**********************************************************************
|
|
(rminus <arg1:real><arg2:real><difference:argument>)
|
|
***********************************************************************/
|
|
static int rminus() /* third arg is difference of first two */
|
|
{
|
|
real r1, r2;
|
|
|
|
ARG_REAL(1, r1);
|
|
ARG_REAL(2, r2);
|
|
|
|
return(bind_real(3, r1 - r2));
|
|
}
|
|
|
|
/**********************************************************************
|
|
(rmult <arg1:real><arg2:real><argument>)
|
|
***********************************************************************/
|
|
static int rmult() /* third arg is product of first two */
|
|
{
|
|
real r1, r2;
|
|
|
|
ARG_REAL(1, r1);
|
|
ARG_REAL(2, r2);
|
|
|
|
return(bind_real(3, r1 * r2));
|
|
}
|
|
static int rabs()
|
|
{
|
|
real r1 ;
|
|
|
|
ARG_REAL(1, r1);
|
|
return(bind_real(2, fabs( r1 )));
|
|
}
|
|
|
|
/**********************************************************************
|
|
(rdiv <arg1:real><arg2:real><argument>)
|
|
***********************************************************************/
|
|
#define TooCloseToZero (1.0e-20)
|
|
static int rdiv() /* third arg = first arg / second arg */
|
|
{
|
|
real r1, r2;
|
|
|
|
ARG_REAL(1, r1);
|
|
ARG_REAL(2, r2);
|
|
if ( fabs(r2) < TooCloseToZero ) {
|
|
argerr(1, msgDeref( MSG_DIVBYZEROR ) );
|
|
return(CRASH);
|
|
}
|
|
return(bind_real(3, r1 / r2));
|
|
}
|
|
|
|
#endif /* REAL operations */
|
|
|
|
/**********************************************************************
|
|
(idiv <arg1:integer><arg2:integer><argument>)
|
|
***********************************************************************/
|
|
static int idiv()
|
|
{
|
|
integer i1, i2;
|
|
|
|
ARG_INT(1, i1);
|
|
ARG_INT(2, i2);
|
|
if ( i2 == 0 ) {
|
|
argerr(1, msgDeref( MSG_DIVBYZEROR ) );
|
|
return(CRASH);
|
|
}
|
|
return(bind_int(3, i1 / i2));
|
|
}
|
|
|
|
static int iabs()
|
|
{
|
|
integer i1 ;
|
|
|
|
ARG_INT(1, i1);
|
|
return(bind_int(2, i1 < 0 ? -i1 : i1 ));
|
|
}
|
|
|
|
static int bitor()
|
|
{
|
|
integer i1, i2;
|
|
|
|
ARG_INT(1, i1);
|
|
ARG_INT(2, i2);
|
|
return(bind_int(3, i1 | i2));
|
|
}
|
|
static int bitand()
|
|
{
|
|
integer i1, i2;
|
|
|
|
ARG_INT(1, i1);
|
|
ARG_INT(2, i2);
|
|
return(bind_int(3, i1 & i2));
|
|
}
|
|
static int bitxor()
|
|
{
|
|
integer i1, i2;
|
|
|
|
ARG_INT(1, i1);
|
|
ARG_INT(2, i2);
|
|
return(bind_int(3, i1 ^ i2));
|
|
}
|
|
static int bitright()
|
|
{
|
|
integer i1, i2;
|
|
|
|
ARG_INT(1, i1);
|
|
ARG_INT(2, i2);
|
|
return(bind_int(3, i1 >> i2));
|
|
}
|
|
static int bitleft()
|
|
{
|
|
integer i1, i2;
|
|
|
|
ARG_INT(1, i1);
|
|
ARG_INT(2, i2);
|
|
return(bind_int(3, i1 << i2));
|
|
}
|
|
|
|
static int bitnot()
|
|
{
|
|
integer i1;
|
|
|
|
ARG_INT(1, i1);
|
|
return(bind_int(2, ~ i1));
|
|
}
|
|
|
|
|
|
/*
|
|
Split a string at a substring boundary:
|
|
(string_break " an" "tommorrow is another day" X Y)
|
|
X = "tommorow is"; characters up to boundary;
|
|
Y = "other day"; characters remaining after " an".
|
|
(string_break "null" "tommorow is another day" X Y)
|
|
X = "tommorow is another day"; original string;
|
|
Y = ""; empty because "null" was not found.
|
|
*/
|
|
static int string_break ()
|
|
{
|
|
char *substr, *str, save, *s, *s2, *sb ;
|
|
integer result ;
|
|
|
|
ARG_STRING(1, substr);
|
|
ARG_STRING(2, str);
|
|
for ( s = str ; *s ; s++ ) {
|
|
for ( sb = substr, s2 = s ;
|
|
*sb && *sb == *s2 ; sb++, s2++ ) ;
|
|
if ( *sb == 0 ) break ;
|
|
}
|
|
save = *s ;
|
|
*s = 0 ;
|
|
|
|
result = bind_string( 3, str ) ;
|
|
|
|
if ( result == CRASH || result == FALSE )
|
|
return result ;
|
|
|
|
*s = save ;
|
|
if ( *sb == 0 ) s += strlen( substr ) ;
|
|
return( bind_string(4, s ) );
|
|
}
|
|
/*
|
|
Use the "string read" capability of PRSCAN.C to scan the first non-blank
|
|
token from the given string.
|
|
(scan_token "-3.4e-17 is a real number" Token Rest)
|
|
Token = "-3.4e-17"
|
|
Rest = " is a real number"
|
|
*/
|
|
static int scan_tok ( Boolean opCheck)
|
|
{
|
|
char * s, str [4], * token, * rest ;
|
|
int result ;
|
|
|
|
ARG_STRING(1,s);
|
|
|
|
if ( opCheck && (*s == '-' || *s == '+') ) {
|
|
result = *s ;
|
|
rest = s + 1 ;
|
|
} else {
|
|
result = check_one_token( s ) ;
|
|
rest = Curr_string_input ;
|
|
}
|
|
if ( result == SCAN_ERR || result == EOF || result == ' ' ) {
|
|
return FALSE ;
|
|
} else
|
|
if ( result < 256 ) {
|
|
str[0] = result ;
|
|
str[1] = 0 ;
|
|
token = str ;
|
|
} else {
|
|
token = Read_buffer ;
|
|
}
|
|
result = bind_string( 2, token ) ;
|
|
if ( result == CRASH || result == FAIL ) return result ;
|
|
return bind_string( 3, rest ) ;
|
|
}
|
|
/* Normal token scanning, allowing for unary signs */
|
|
static int scan_token ()
|
|
{
|
|
return scan_tok( FALSE );
|
|
}
|
|
/* Token scanning al la Turbo Prolog, separating signs */
|
|
static int scan_tokop ()
|
|
{
|
|
return scan_tok( TRUE );
|
|
}
|
|
|
|
static int pstring_stdout()
|
|
{
|
|
char *s;
|
|
|
|
ARG_STRING(1, s);
|
|
tty_pr_string(s);
|
|
return(TRUE);
|
|
}
|
|
static int nl_stdout () /* write newline */
|
|
{
|
|
tty_pr_string("\n");
|
|
return(TRUE);
|
|
}
|
|
static int putc_stdout ()
|
|
{
|
|
integer c;
|
|
|
|
ARG_INT(1, c);
|
|
*Print_buffer = (char)c;
|
|
Print_buffer[1] = '\0';
|
|
tty_pr_string(Print_buffer);
|
|
return(1);
|
|
}
|
|
|
|
|
|
static int alloc_percent ()
|
|
{
|
|
integer type, percent ;
|
|
ARG_INT( 1, type ) ;
|
|
percent = allocPercent( (int) type ) ;
|
|
return bind_int( 2, percent ) ;
|
|
}
|
|
|
|
static int abort_query ()
|
|
{
|
|
char * s ;
|
|
|
|
ARG_STRING( 1, s ) ;
|
|
fatalmsg( s ) ;
|
|
return ABORT ;
|
|
}
|
|
|
|
/**************************************************************
|
|
*
|
|
* WIN32 Special Built-ins
|
|
*
|
|
* (fault) generate an access violation;
|
|
* used for testing exception handling.
|
|
*
|
|
* (dbgwrites String)
|
|
*
|
|
* Write a string to debugger
|
|
*
|
|
* (dbgnl) Write '\n' to the debugger
|
|
*
|
|
*
|
|
* (tracewrites String)
|
|
*
|
|
* Write a string to debugger #ifdef TRACE
|
|
*
|
|
* (tracenl) Write '\n' to the debugger #ifdef TRACE
|
|
*
|
|
*
|
|
**************************************************************/
|
|
|
|
#ifdef WIN32
|
|
|
|
extern void ini_win32 ( void ) ;
|
|
extern void end_win32 ( void ) ;
|
|
|
|
// Define the ANSI version of the OutputDebugString export
|
|
|
|
extern void OutputDebugStringA ( char * lpOutputString ) ;
|
|
#define OutputDebugString(str) OutputDebugStringA(str)
|
|
|
|
static int fault ()
|
|
{
|
|
char * bogus = (char *) 0xFFFFFFFF ;
|
|
return *bogus ;
|
|
}
|
|
|
|
static int dbgwrites ()
|
|
{
|
|
char *s;
|
|
|
|
ARG_STRING(1, s);
|
|
OutputDebugString( s ) ;
|
|
|
|
return(TRUE);
|
|
}
|
|
|
|
static int dbgnl()
|
|
{
|
|
OutputDebugString( "\n" ) ;
|
|
|
|
return(TRUE);
|
|
}
|
|
|
|
static int tracewrites ()
|
|
{
|
|
#ifdef TRACE
|
|
char *s;
|
|
|
|
ARG_STRING(1, s);
|
|
OutputDebugString( s ) ;
|
|
#endif
|
|
return(TRUE);
|
|
}
|
|
|
|
static int tracenl()
|
|
{
|
|
#ifdef TRACE
|
|
OutputDebugString( "\n" ) ;
|
|
#endif
|
|
return(TRUE);
|
|
}
|
|
|
|
|
|
static int testlist ()
|
|
{
|
|
// Save the current input settings
|
|
|
|
extern varindx Nvars ;
|
|
int saveStringInputFlag = String_input_flag ;
|
|
PRFILE * saveCurrInfile = Curr_infile ;
|
|
char * saveCurrStringInput = Curr_string_input ;
|
|
node_ptr_t nodeptr ;
|
|
|
|
static char * theList = "(first second third)" ;
|
|
|
|
String_input_flag = 1 ;
|
|
Curr_string_input = theList ;
|
|
|
|
nodeptr = read_list( DYNAMIC ) ;
|
|
|
|
// Restore original input settings
|
|
|
|
String_input_flag = saveStringInputFlag ;
|
|
Curr_infile = saveCurrInfile ;
|
|
Curr_string_input = saveCurrStringInput ;
|
|
|
|
if ( nodeptr )
|
|
{
|
|
nth_arg(1);
|
|
return unify( DerefNode, DerefSubst, nodeptr,
|
|
my_Subst_alloc((unsigned int)Nvars*sizeof(struct subst)));
|
|
}
|
|
return nodeptr != NULL ;
|
|
}
|
|
#endif // WIN32
|
|
|
|
/**************************************************************
|
|
* End of Win32isms
|
|
**************************************************************/
|
|
|
|
|
|
void ini_extra ( )
|
|
{
|
|
make_builtin( (intfun) string_upper, "string_upper" );
|
|
make_builtin( (intfun) string_lower, "string_lower" );
|
|
make_builtin( (intfun) atom_from, "atom_from" );
|
|
make_builtin( (intfun) int_from, "int_from" );
|
|
#ifdef REAL
|
|
make_builtin( (intfun) real_from, "real_from" );
|
|
make_builtin( (intfun) rminus, "rminus" );
|
|
make_builtin( (intfun) rmult, "rmult" );
|
|
make_builtin( (intfun) rleq, "rleq" );
|
|
make_builtin( (intfun) rdiv, "rdiv" );
|
|
make_builtin( (intfun) rdiv, "rdiv" );
|
|
make_builtin( (intfun) rabs, "rabs" );
|
|
#endif
|
|
make_builtin( (intfun) iabs, "iabs" );
|
|
make_builtin( (intfun) bitor, "bitor" );
|
|
make_builtin( (intfun) bitand, "bitand" );
|
|
make_builtin( (intfun) bitnot, "bitnot" );
|
|
make_builtin( (intfun) bitxor, "bitxor" );
|
|
make_builtin( (intfun) bitleft, "bitleft" );
|
|
make_builtin( (intfun) bitright, "bitright" );
|
|
make_builtin( (intfun) string_break, "string_break" );
|
|
make_builtin( (intfun) pstring_stdout, "writesout" );
|
|
make_builtin( (intfun) nl_stdout, "nlout" );
|
|
make_builtin( (intfun) putc_stdout, "putout" );
|
|
make_builtin( (intfun) alloc_percent, "alloc_percent" );
|
|
make_builtin( (intfun) scan_token, "scan_token" );
|
|
make_builtin( (intfun) scan_tokop, "scan_tokop" );
|
|
make_builtin( (intfun) abort_query, "abort_query" );
|
|
|
|
#ifdef WIN32
|
|
make_builtin( (intfun) fault, "fault" );
|
|
make_builtin( (intfun) dbgwrites, "dbgwrites" );
|
|
make_builtin( (intfun) dbgnl, "dbgnl" );
|
|
make_builtin( (intfun) tracewrites, "tracewrites" );
|
|
make_builtin( (intfun) tracenl, "tracenl" );
|
|
make_builtin( (intfun) testlist, "testlist" );
|
|
#endif
|
|
|
|
#ifdef WIN32
|
|
ini_win32();
|
|
#endif
|
|
}
|
|
|
|
void end_extra ()
|
|
{
|
|
#ifdef WIN32
|
|
end_win32();
|
|
#endif
|
|
}
|
|
|