From dbdae6a9307d9bc01d21d47a9ffc1300d9cea2ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 27 Jul 2015 22:22:44 -0500 Subject: [PATCH] syntax error handling --- C/parser.c | 149 +- C/scanner.c | 7 +- C/threads.c | 2 +- C/x.c | 3792 ---------------------------------------- H/Yap.h | 20 + H/iatoms.h | 2 +- OPTYap/locks_pthread.h | 16 +- include/YapError.h | 2 - misc/ATOMS | 2 +- os/charsio.c | 112 +- os/format.c | 12 +- os/iopreds.h | 16 +- os/readterm.c | 103 +- os/yapio.h | 15 - pl/boot.yap | 3 +- pl/errors.yap | 4 +- pl/init.yap | 2 +- pl/messages.yap | 106 +- 18 files changed, 338 insertions(+), 4027 deletions(-) delete mode 100644 C/x.c diff --git a/C/parser.c b/C/parser.c index d3db3fe7f..070924683 100755 --- a/C/parser.c +++ b/C/parser.c @@ -147,6 +147,9 @@ dot with single quotes. #if HAVE_STRING_H #include #endif +#if HAVE_STDARG_H +#include +#endif #ifdef __STDC__XXX #define Volatile volatile @@ -164,6 +167,21 @@ static Term ParseArgs( Atom, wchar_t, JMPBUFF *, Term CACHE_TYPE); static Term ParseList( JMPBUFF *CACHE_TYPE); static Term ParseTerm( int, JMPBUFF *CACHE_TYPE); +static void +syntax_msg( const char *msg, ...) +{ + CACHE_REGS + va_list ap; + + if (LOCAL_toktide == LOCAL_tokptr) { + va_start(ap, msg); + vsnprintf( LOCAL_FileNameBuf2, YAP_FILENAME_MAX-1, msg, ap ); + LOCAL_ErrorMessage = LOCAL_FileNameBuf2; + LOCAL_Error_TYPE = SYNTAX_ERROR; + va_end(ap); + } +} + #define TRY(S, P) \ { \ Volatile JMPBUFF *saveenv, newenv; \ @@ -205,6 +223,54 @@ static Term ParseTerm( int, JMPBUFF *CACHE_TYPE); #define FAIL siglongjmp(FailBuff->JmpBuff, 1) +static const char *tokRep(TokEntry *tokptr) +{ + CACHE_REGS + Term info = tokptr->TokInfo; + char *b, *buf = LOCAL_FileNameBuf2; + size_t length, sze = YAP_FILENAME_MAX-1; + UInt flags = 0; + + switch (tokptr->Tok) { + case Name_tok: + return RepAtom((Atom)info)->StrOfAE; + case Number_tok: + if ((b = Yap_TermToString(info, buf, sze, &length,LOCAL_encoding, flags)) != buf) { + if (b) free(b); + return NULL; + } + return buf; + case Var_tok: + { + VarEntry *varinfo = (VarEntry *)info; + return varinfo->VarRep; + } + case String_tok: + case BQString_tok: + return (char *)info; + case WString_tok: + case WBQString_tok: + return utf8_wcscpy(buf, (wchar_t *)info); + case Error_tok: + return ""; + case eot_tok: + return ""; + case Ponctuation_tok: + { + buf[1] = '\0'; + if ((info) == 'l') { + buf[0] = '('; + } else { + buf[0] = (char)info; + } + } + return buf; + case QuasiQuotes_tok: + case WQuasiQuotes_tok: + return ""; + } +} + VarEntry *Yap_LookupVar(const char *var) /* lookup variable in variables table */ { CACHE_REGS @@ -430,16 +496,18 @@ int Yap_IsPosfixOp(Atom op, int *pptr, int *lpptr) { inline static void GNextToken(USES_REGS1) { if (LOCAL_tokptr->Tok == Ord(eot_tok)) return; - if (LOCAL_tokptr == LOCAL_toktide) + if (LOCAL_tokptr == LOCAL_toktide) { LOCAL_toktide = LOCAL_tokptr = LOCAL_tokptr->TokNext; - else + } else LOCAL_tokptr = LOCAL_tokptr->TokNext; } inline static void checkfor(wchar_t c, JMPBUFF *FailBuff USES_REGS) { if (LOCAL_tokptr->Tok != Ord(Ponctuation_tok) || - LOCAL_tokptr->TokInfo != (Term)c) + LOCAL_tokptr->TokInfo != (Term)c) { + syntax_msg("expected to find \'%c\', found %s", tokRep(LOCAL_tokptr)); FAIL; + } NextToken; } @@ -517,12 +585,12 @@ static Term ParseArgs( Atom a, wchar_t close, JMPBUFF *FailBuff, func = Yap_MkFunctor(a, 1); if (func == NULL) { - LOCAL_ErrorMessage = "Heap Overflow"; + syntax_msg("Heap Overflow"); FAIL; } t = Yap_MkApplTerm(func, nargs, p); if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); return TermNil; } NextToken; @@ -532,7 +600,7 @@ static Term ParseArgs( Atom a, wchar_t close, JMPBUFF *FailBuff, while (1) { Term *tp = (Term *)ParserAuxSp; if (ParserAuxSp + 1 > LOCAL_TrailTop) { - LOCAL_ErrorMessage = "Trail Overflow"; + syntax_msg("Trail Overflow"); FAIL; } *tp++ = Unsigned(ParseTerm( 999, FailBuff PASS_REGS)); @@ -550,12 +618,12 @@ static Term ParseArgs( Atom a, wchar_t close, JMPBUFF *FailBuff, * order */ if (HR > ASP - (nargs + 1)) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); FAIL; } func = Yap_MkFunctor(a, nargs); if (func == NULL) { - LOCAL_ErrorMessage = "Heap Overflow"; + syntax_msg("Heap Overflow"); FAIL; } #ifdef SFUNC @@ -570,7 +638,7 @@ static Term ParseArgs( Atom a, wchar_t close, JMPBUFF *FailBuff, t = Yap_MkApplTerm(func, nargs, p); #endif if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); return TermNil; } /* check for possible overflow against local stack */ @@ -609,7 +677,7 @@ loop: /* check for possible overflow against local stack */ if (HR > ASP - 4096) { to_store[1] = TermNil; - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); FAIL; } else { to_store[1] = AbsPair(HR); @@ -622,8 +690,10 @@ loop: } else { to_store[1] = MkAtomTerm(AtomNil); } - } else - FAIL; + } else { + syntax_msg("looking for symbol ',','|' got symbol '%s'", tokRep(LOCAL_tokptr) ); + FAIL; + } return (o); } @@ -693,13 +763,13 @@ static Term ParseTerm( int prio, JMPBUFF *FailBuff USES_REGS) { /* build appl on the heap */ func = Yap_MkFunctor((Atom)t, 1); if (func == NULL) { - LOCAL_ErrorMessage = "Heap Overflow"; + syntax_msg( "Heap Overflow" ); FAIL; } t = ParseTerm( oprprio, FailBuff PASS_REGS); t = Yap_MkApplTerm(func, 1, &t); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg( "Stack Overflow" ); FAIL; } curprio = opprio; , break;) @@ -722,7 +792,8 @@ static Term ParseTerm( int prio, JMPBUFF *FailBuff USES_REGS) { Volatile char *p = (char *)LOCAL_tokptr->TokInfo; t = Yap_CharsToTDQ(p, CurrentModule PASS_REGS); if (!t) { - FAIL; + syntax_msg( "could not convert \'%s\'", (char *)LOCAL_tokptr->TokInfo ); + FAIL; } NextToken; } break; @@ -732,7 +803,8 @@ static Term ParseTerm( int prio, JMPBUFF *FailBuff USES_REGS) { Volatile wchar_t *p = (wchar_t *)LOCAL_tokptr->TokInfo; t = Yap_WCharsToTDQ(p, CurrentModule PASS_REGS); if (!t) { - FAIL; + syntax_msg( "could not convert \'%S\'", (wchar_t *)LOCAL_tokptr->TokInfo ); + FAIL; } NextToken; } break; @@ -742,6 +814,7 @@ static Term ParseTerm( int prio, JMPBUFF *FailBuff USES_REGS) { Volatile char *p = (char *)LOCAL_tokptr->TokInfo; t = Yap_CharsToTBQ(p, CurrentModule PASS_REGS); if (!t) { + syntax_msg( "could not convert \'%s\"", (char *)LOCAL_tokptr->TokInfo ); FAIL; } NextToken; @@ -752,6 +825,7 @@ static Term ParseTerm( int prio, JMPBUFF *FailBuff USES_REGS) { Volatile wchar_t *p = (wchar_t *)LOCAL_tokptr->TokInfo; t = Yap_WCharsToTBQ(p, CurrentModule PASS_REGS); if (!t) { + syntax_msg( "could not convert \"%S\"", (wchar_t *)LOCAL_tokptr->TokInfo ); FAIL; } NextToken; @@ -766,6 +840,7 @@ case Var_tok: break; case Error_tok: + syntax_msg( "found ill-formed \"%s\"", tokRep(LOCAL_tokptr) ); FAIL; case Ponctuation_tok: @@ -799,12 +874,13 @@ case Var_tok: t = Yap_MkApplTerm(FunctorBraces, 1, &t); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); FAIL; } checkfor('}', FailBuff PASS_REGS); break; default: + syntax_msg("unexpected ponctuation signal %s", tokRep(LOCAL_tokptr)); FAIL; } break; @@ -848,19 +924,23 @@ case Var_tok: NextToken; t = ParseTerm( 1200, FailBuff PASS_REGS); if (LOCAL_tokptr->Tok != QuasiQuotes_tok) { + syntax_msg( "expected to find quasi quotes, got \"%s\"", , tokRep(LOCAL_tokptr) ); FAIL; } - if (!(is_quasi_quotation_syntax(t, &at))) + if (!(is_quasi_quotation_syntax(t, &at))) { + syntax_msg( "bad quasi quotation syntax, at \"%s\"", tokRep(LOCAL_tokptr) ); FAIL; + } /* Arg 2: the content */ tn = Yap_MkNewApplTerm(SWIFunctorToFunctor(FUNCTOR_quasi_quotation4), 4); tnp = RepAppl(tn) + 1; tnp[0] = MkAtomTerm(at); if (!get_quasi_quotation(Yap_InitSlot(ArgOfTerm(2, tn)), &qq->text, - qq->text + strlen((const char *)qq->text))) - FAIL; - + qq->text + strlen((const char *)qq->text))) { + syntax_msg( "could not get quasi quotation, at \"%s\"", tokRep(LOCAL_tokptr) ); + FAIL; + } if (positions) { intptr_t qqend = qq->end.charno; @@ -869,6 +949,7 @@ case Var_tok: FUNCTOR_minus2, PL_INTPTR, qq->mid.charno + 2, /* end of | token */ PL_INTPTR, qqend - 2)) /* end minus "|}" */ + syntax_msg( "failed to unify quasi quotation, at \"%s\"", tokRep(LOCAL_tokptr) ); FAIL; } @@ -878,14 +959,16 @@ case Var_tok: t = ArgOfTerm(4, tn); if (!(to = PL_new_term_ref()) || !PL_unify_list(LOCAL_qq_tail, to, LOCAL_qq_tail) || - !PL_unify(to, Yap_InitSlot(tn ))) + !PL_unify(to, Yap_InitSlot(tn ))) { + syntax_msg( "failed to unify quasi quotation, at \"%s\"", tokRep(LOCAL_tokptr) ); FAIL; + } } #endif NextToken; break; default: - + syntax_msg( "expected operator, got \'%s\'", tokRep(LOCAL_tokptr) ); FAIL; } @@ -900,7 +983,7 @@ case Var_tok: Volatile int oldprio = curprio; TRY3(func = Yap_MkFunctor((Atom)LOCAL_tokptr->TokInfo, 2); if (func == NULL) { - LOCAL_ErrorMessage = "Heap Overflow"; + syntax_msg("Heap Overflow"); FAIL; } NextToken; { @@ -910,7 +993,7 @@ case Var_tok: t = Yap_MkApplTerm(func, 2, args); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); FAIL; } }, @@ -923,13 +1006,13 @@ case Var_tok: /* parse as posfix operator */ Functor func = Yap_MkFunctor((Atom)LOCAL_tokptr->TokInfo, 1); if (func == NULL) { - LOCAL_ErrorMessage = "Heap Overflow"; + syntax_msg("Heap Overflow"); FAIL; } t = Yap_MkApplTerm(func, 1, &t); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); FAIL; } curprio = opprio; @@ -948,7 +1031,7 @@ case Var_tok: t = Yap_MkApplTerm(FunctorComma, 2, args); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); FAIL; } curprio = 1000; @@ -963,7 +1046,7 @@ case Var_tok: t = Yap_MkApplTerm(FunctorVBar, 2, args); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { - LOCAL_ErrorMessage = "Stack Overflow"; + syntax_msg("Stack Overflow"); FAIL; } curprio = opprio; @@ -992,8 +1075,10 @@ case Var_tok: continue; } } - if (LOCAL_tokptr->Tok <= Ord(WString_tok)) + if (LOCAL_tokptr->Tok <= Ord(WString_tok)) { + syntax_msg( "expected operator, got \'%s\'", tokRep(LOCAL_tokptr) ); FAIL; + } break; } #if DEBUG @@ -1014,6 +1099,10 @@ Term Yap_Parse(UInt prio) { if (!sigsetjmp(FailBuff.JmpBuff, 0)) { t = ParseTerm(prio, &FailBuff PASS_REGS); + if (LOCAL_Error_TYPE == SYNTAX_ERROR) { + LOCAL_Error_TYPE = YAP_NO_ERROR; + LOCAL_ErrorMessage = NULL; + } // if (LOCAL_tokptr->Tok != Ord(eot_tok)) // return (0L); return (t); diff --git a/C/scanner.c b/C/scanner.c index 46d14f0d3..efb175ac3 100755 --- a/C/scanner.c +++ b/C/scanner.c @@ -469,8 +469,7 @@ static char chtype0[NUMBER_OF_CHARS + 1] = { BS, BS, BS, BS, BS, BS, BS, /* sp ! " # $ % & ' ( ) * + , - . / */ - BS, SL, DC, SY, SY, CC, SY, QT, BK, - BK, SY, SY, BK, SY, SY, SY, + BS, SL, DC, SY, SY, CC, SY, QT, BK, BK, SY, SY, BK, SY, SY, SY, /* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */ NU, NU, NU, NU, NU, NU, NU, NU, NU, @@ -893,7 +892,7 @@ static Term get_num(int *chp, int *chbuffp, StreamDesc *inp_stream, char *s, ch = getchr(inp_stream); if (base == 0) { CACHE_REGS - wchar_t ascii = ch; + wchar_t ascii = ch; int scan_extra = TRUE; if (ch == '\\' && @@ -925,7 +924,7 @@ static Term get_num(int *chp, int *chbuffp, StreamDesc *inp_stream, char *s, has_overflow = (has_overflow || TRUE); ch = getchr(inp_stream); } - } + } } else if (ch == 'x' && base == 0) { might_be_float = FALSE; if (--max_size == 0) { diff --git a/C/threads.c b/C/threads.c index b7fcc7892..67b3126cf 100644 --- a/C/threads.c +++ b/C/threads.c @@ -51,7 +51,7 @@ blob_type_t PL_Message_Queue = { #if DEBUG_LOCKS||DEBUG_PE_LOCKS -int debug_locks = FALSE, debug_pe_locks = FALSE; +bool debug_locks = true, debug_pe_locks = true; static Int p_debug_locks( USES_REGS1 ) { debug_pe_locks = 1; return TRUE; } static Int p_nodebug_locks( USES_REGS1 ) { debug_locks = 0; debug_pe_locks = 0; return TRUE; } diff --git a/C/x.c b/C/x.c deleted file mode 100644 index 3846ccd29..000000000 --- a/C/x.c +++ /dev/null @@ -1,3792 +0,0 @@ -/************************************************************************* -* * -* YAP Prolog * -* * -* Yap Prolog was developed at NCCUP - Universidade do Porto * -* * -* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * -* * -************************************************************************** -* * -* File: sysbits.c * -* Last rev: 4/03/88 * -* mods: * -* comments: very much machine dependent routines * -* * -*************************************************************************/ -#ifdef SCCS -static char SccsId[] = "%W% %G%"; -#endif - -// @{ - -/** - @addtogroup YAPOS -*/ - -/* - * In this routine we shall try to include the inevitably machine dependant - * routines. These include, for the moment : Time, A rudimentary form of - * signal handling, OS calls, - * - * Vitor Santos Costa, February 1987 - * - */ - -/* windows.h does not like absmi.h, this - should fix it for now */ -#if _WIN32 || __MINGW32__ -#include -#endif -#include "absmi.h" -#include "yapio.h" -#include "alloc.h" -#include "pl-incl.h" -#include -#if STDC_HEADERS -#include -#endif -#if HAVE_WINDOWS_H -#include -#endif -#if HAVE_SYS_TIME_H && !_MSC_VER -#include -#endif -#if HAVE_UNISTD_H -#include -#endif -#if HAVE_SYS_WAIT_H && !defined(__MINGW32__) && !_MSC_VER -#include -#endif -#if HAVE_STRING_H -#include -#endif -#if !HAVE_STRNCAT -#define strncat(X,Y,Z) strcat(X,Y) -#endif -#if !HAVE_STRNCPY -#define strncpy(X,Y,Z) strcpy(X,Y) -#endif -#if HAVE_GETPWNAM -#include -#endif -#include -#if HAVE_SYS_STAT_H -#include -#endif -#if HAVE_SYS_TYPES_H -#include -#endif -#if HAVE_FCNTL_H -#include -#endif -#if _MSC_VER || defined(__MINGW32__) -#include -/* required for DLL compatibility */ -#if HAVE_DIRECT_H -#include -#endif -#include -#include -#else -#if HAVE_SYS_PARAM_H -#include -#endif -#endif -/* CYGWIN seems to include this automatically */ -#if HAVE_FENV_H && !defined(__CYGWIN__) -#include -#endif -#if defined(ENABLE_SYSTEM_EXPANSION) && HAVE_WORDEXP_H -#include -#endif -#if HAVE_LIBGEN_H -#include -#endif -#if HAVE_READLINE_READLINE_H -#include -#endif - -/// File Error Handler -static void -Yap_FileError(yap_error_number type, Term where, const char *format,...) -{ - GET_LD - if ( truePrologFlag(PLFLAG_FILEERRORS) ) { - va_list ap; - - va_start (ap, format); - /* now build the error string */ - Yap_Error(type, TermNil, format, ap); - va_end (ap); - - } -} - - - -static void InitTime(int); -static void InitWTime(void); -static Int p_sh( USES_REGS1 ); -static Int p_shell( USES_REGS1 ); -static Int p_system( USES_REGS1 ); -static Int p_mv( USES_REGS1 ); -static Int p_dir_sp( USES_REGS1 ); -static void InitRandom(void); -static Int p_srandom( USES_REGS1 ); -static Int p_alarm( USES_REGS1 ); -static Int p_getenv( USES_REGS1 ); -static Int p_putenv( USES_REGS1 ); -static bool set_fpu_exceptions(bool); -#ifdef MACYAP -static int chdir(char *); -/* #define signal skel_signal */ -#endif /* MACYAP */ - - -void exit(int); - -#ifdef __WINDOWS__ -void -Yap_WinError(char *yap_error) -{ - char msg[256]; - /* Error, we could not read time */ - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, GetLastError(), - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), msg, 256, - NULL); - Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "%s at %s", msg, yap_error); -} -#endif /* __WINDOWS__ */ - - -#define is_valid_env_char(C) ( ((C) >= 'a' && (C) <= 'z') || ((C) >= 'A' && \ - (C) <= 'Z') || (C) == '_' ) - -#if __ANDROID__ - -AAssetManager * Yap_assetManager; - - -void * -Yap_openAssetFile( const char *path ) { - const char * p = path+8; - AAsset* asset = AAssetManager_open(Yap_assetManager, p, AASSET_MODE_UNKNOWN); - return asset; -} - -bool -Yap_isAsset( const char *path ) -{ - if (Yap_assetManager == NULL) - return false; - return path[0] == '/'&& - path[1] == 'a'&& - path[2] == 's'&& - path[3] == 's'&& - path[4] == 'e'&& - path[5] == 't'&& - path[6] == 's'&& - (path[7] == '/' || path[7] == '\0'); -} - -bool -Yap_AccessAsset( const char *name, int mode ) -{ - AAssetManager* mgr = Yap_assetManager; - const char *bufp=name+7; - - if (bufp[0] == '/') - bufp++; - if ((mode & W_OK) == W_OK) { - return false; - } - // directory works if file exists - AAssetDir *assetDir = AAssetManager_openDir(mgr, bufp); - if (assetDir) { - AAssetDir_close(assetDir); - return true; - } - return false; -} - -bool -Yap_AssetIsFile( const char *name ) -{ - AAssetManager* mgr = Yap_assetManager; - const char *bufp=name+7; - if (bufp[0] == '/') - bufp++; - // check if file is a directory. - AAsset *asset = AAssetManager_open(mgr, bufp, AASSET_MODE_UNKNOWN); - if (!asset) - return false; - AAsset_close(asset); - return true; -} - -bool -Yap_AssetIsDir( const char *name ) -{ - AAssetManager* mgr = Yap_assetManager; - const char *bufp=name+7; - if (bufp[0] == '/') - bufp++; - // check if file is a directory. - AAssetDir *assetDir = AAssetManager_openDir(mgr, bufp); - if (!assetDir) { - return false; - } - AAssetDir_close(assetDir); - AAsset *asset = AAssetManager_open(mgr, bufp, AASSET_MODE_UNKNOWN); - if (!asset) - return true; - AAsset_close(asset); - return false; -} - -int64_t -Yap_AssetSize( const char *name ) -{ - AAssetManager* mgr = Yap_assetManager; - const char *bufp=name+7; - if (bufp[0] == '/') - bufp++; - AAsset *asset = AAssetManager_open(mgr, bufp, AASSET_MODE_UNKNOWN); - if (!asset) - return -1; - off64_t len = AAsset_getLength64(asset); - AAsset_close(asset); - return len; -} -#endif - - - -/// is_directory: verifies whether an expanded file name -/// points at a readable directory -static bool -is_directory(const char *FileName) -{ -#ifdef __ANDROID__ - if (Yap_isAsset(FileName)) { - return Yap_AssetIsDir(FileName); - } - -#endif - -#ifdef __WINDOWS__ - DWORD dwAtts = GetFileAttributes( FileName ); - if (dwAtts == INVALID_FILE_ATTRIBUTES) - return false; - return (dwAtts & FILE_ATTRIBUTE_DIRECTORY); -#elif HAVE_LSTAT - struct stat buf; - - if (lstat(FileName, &buf) == -1) { - /* return an error number */ - return false; - } - return S_ISDIR(buf.st_mode); - #else - Yap_Error(SYSTEM_ERROR, TermNil, - "stat not available in this configuration"); - return false; - #endif - } - -/// has_access just calls access -/// it uses F_OK, R_OK and friend -static bool -has_access(const char *FileName, int mode) -{ -#ifdef __ANDROID__ - if (Yap_isAsset(FileName)) { - return Yap_AccessAsset(FileName, mode); - } -#endif -#if HAVE_ACCESS - if (access( FileName, mode ) == 0) - return true; - if (errno == EINVAL) { - Yap_Error(SYSTEM_ERROR, TermNil, - "bad flags to access"); - } - return false; -#else - Yap_Error(SYSTEM_ERROR, TermNil, - "access not available in this configuration"); - return false; -#endif -} - -static bool -exists( const char *f) -{ - return has_access( f, F_OK ); -} - -static int - dir_separator (int ch) - { - #ifdef MAC - return (ch == ':'); - #elif ATARI || _MSC_VER - return (ch == '\\'); - #elif defined(__MINGW32__) || defined(__CYGWIN__) - return (ch == '\\' || ch == '/'); - #else - return (ch == '/'); - #endif - } - - int - Yap_dir_separator (int ch) - { - return dir_separator (ch); - } - -#if __WINDOWS__ -#include - -char *libdir = NULL; -#endif - - -int -IsAbsolutePath(const char *p) -{ -#if _WIN32 || __MINGW32__ - return !PathIsRelative(p); -#else - return p[0] == '/'; -#endif -} - -#define isValidEnvChar(C) ( ((C) >= 'a' && (C) <= 'z') || ((C) >= 'A' && \ - (C) <= 'Z') || (C) == '_' ) - -// this is necessary because -// support for ~expansion at the beginning -// systems like Android do not do this. -static char * -yapExpandVars (const char *source, char *result) -{ - const char *src = source; - char *res = result; - - if (!result) - result = malloc( cha r YAP_FILENAME_MAs ); - if ((s = yapExpandVars(pattern, expanded)) == NULL) { - if (strlen(source) >= YAP_FILENAME_MAX) { - Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "%s in true_file-name is larger than the buffer size (%d bytes)", source, strlen(source)); - } - /* step 1: eating home information */ - if (source[0] == '~') { - if (dir_separator(source[1]) || source[1] == '\0') - { - char *s; - src++; -#if defined(_WIN32) - s = getenv("HOMEDRIVE"); - if (s != NULL) - strncpy (result, getenv ("HOMEDRIVE"), YAP_FILENAME_MAX); - s = getenv("HOMEPATH"); -z if (s != NULL) - strncpy (result, s, YAP_FILENAME_MAX); -#else - s = getenv ("HOME"); - if (s != NULL) - strncpy (result, s, YAP_FILENAME_MAX); -#endif - } else { -#if HAVE_GETPWNAM - struct passwd *user_passwd; - - src++; - while (!dir_separator((*res = *src)) && *res != '\0') - res++, src++; - res[0] = '\0'; - if ((user_passwd = getpwnam (result)) == NULL) { - Yap_FileError(OPERATING_SYSTEM_ERROR, MkAtomTerm(Yap_LookupAtom(source)),"User %s does not exist in %s", result, source); - return NULL; - } - strncpy (result, user_passwd->pw_dir, YAP_FILENAME_MAX); -#else - Yap_FileError(OPERATING_SYSTEM_ERROR, MkAtomTerm(Yap_LookupAtom(source)),"User %s cannot be found in %s, missing getpwnam", result, source); - return NULL; -#endif - } - strncat (result, src, YAP_FILENAME_MAX); - return result; - } - // do VARIABLE expansion - else if (source[0] == '$') { - /* follow SICStus expansion rules */ - int ch; - char *s; - src = source+1; - if (src[0] == '{') { - src++; - while ((*res++ = (ch = *src++)) && isValidEnvChar (ch) && ch != '}') { - res++; - } - if (ch == '}') { - // {...} - // done - } - } else { - while ((*res++ = (ch = *src++)) && isValidEnvChar (ch) && ch != '}') { - res++; - } - src--; - } - res[0] = '\0'; - if ((s = (char *) getenv (result))) { - strncpy (result, s, YAP_FILENAME_MAX); - } else { - result[0] = '\0'; - } - strncat (result, src, YAP_FILENAME_MAX); - } else { - strncpy (result, source, YAP_FILENAME_MAX); - } - return result; -} - -char * -expandVars(const char *pattern, char *expanded, int maxlen) -{ - return yapExpandVars(pattern, expanded); -#if ( __WIN32 || __MINGW32__ ) - DWORD retval=0; - // notice that the file does not need to exist1 - if (ini == NULL) { - ini = malloc(strlen(w)+1); - } - retval = ExpandEnvironmentStrings(pattern, - expanded, - maxlen); - - if (retval == 0) - { - Yap_WinError("Generating a full path name for a file" ); - return NULL; - } - return expanded; -#elif 0 && HAVE_WORDEXP && defined(ENABLE_SYSTEM_EXPANSION) - wordexp_t result; - - /* Expand the string for the program to run. */ - switch (wordexp (pattern, &result, 0)) - { - case 0: /* Successful. */ - if (result.we_wordv[1]) { - wordfree (&result); - return NULL; - } else { - char *w = result.we_wordv[0]; - if (expanded == NULL) { - expanded = malloc(strlen(w)+1); - } - strncpy( expanded, w, maxlen ); - wordfree (&result); - return expanded; - } - break; - case WRDE_NOSPACE: - /* If the error was WRDE_NOSPACE, - then perhaps part of the result was allocated. */ - wordfree (&result); - default: /* Some other error. */ - return NULL; - } -#else - // just use basic - if (expanded == NULL) { - expanded = malloc(strlen(pattern)+1); - } - strcpy(expanded, pattern); - -#endif - return expanded; -} - -#if _WIN32 || defined(__MINGW32__) -// straightforward conversion from Unix style to WIN style -// check cygwin path.cc for possible improvements -static char * -unix2win( const char *source, char *target, int max) -{ - char *s = target; - const char *s0 = source; - char *s1; - int ch; - - if (s == NULL) - s = malloc(YAP_FILENAME_MAX+1); - s1 = s; - // win32 syntax - // handle drive notation, eg //a/ - if (s0[0] == '\0') { - s[0] = '.'; - s[1] = '\0'; - return s; - } - if (s0[0] == '/' && s0[1] == '/' && isalpha(s0[2]) && s0[3] == '/') -{ - s1[0] = s0[2]; - s1[1] = ':'; - s1[2] = '\\'; - s0+=4; - s1+=3; - } - while ((ch = *s1++ = *s0++)) { - if (ch == '$') { - s1[-1] = '%'; - ch = *s0; - // handle $(....) - if (ch == '{') { - s0++; - while ((ch = *s0++) != '}') { - *s1++ = ch; - if (ch == '\0') return FALSE; - } - *s1++ = '%'; - } else { - while (((ch = *s1++ = *s0++) >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch == '-') || (ch >= '0' && ch <= '9') || (ch == '_')); - s1[-1] = '%'; - *s1++ = ch; - if (ch == '\0') { s1--; s0--; } - } - } else if (ch == '/') - s1[-1] = '\\'; - } - return s; -} -#endif - -#if O_XOS -char * -PrologPath(const char *p, char *buf, size_t len) -{ GET_LD - int flags = (truePrologFlag(PLFLAG_FILE_CASE) ? 0 : XOS_DOWNCASE); - - return _xos_canonical_filename(p, buf, len, flags); -} - -char * -OsPath(const char *p, char *buf) -{ - if()z - trcpy(buf, p); - - return buf; -} -#else -char * -OsPath(const char *X, char *Y) { - //if (X!=Y && Y) strcpy(Y,X); - return (char *)X ; -} -#endif /* O_XOS */ - -#if _WIN32 -#define HAVE_BASENAME 1 -#define HAVE_REALPATH 1 -#define HAVE_WORDEXP 1 -#endif - -bool ChDir(const char *path) { - bool rc = false; - char *qpath = AbsoluteFile(path, NULL); - -#ifdef __ANDROID__ - if (GLOBAL_AssetsWD) { - free( GLOBAL_AssetsWD ); - GLOBAL_AssetsWD = NULL; - } - if (Yap_isAsset(qpath) ) { - AAssetManager* mgr = Yap_assetManager; - const char *ptr = qpath+8; - AAssetDir* d; - if (ptr[0] == '/') - ptr++; - d = AAssetManager_openDir(mgr, ptr); - if (d) { - GLOBAL_AssetsWD = malloc( strlen(qpath) + 1 ); - strcpy( GLOBAL_AssetsWD, qpath ); - AAssetDir_close( d ); - return true; - } - return false; - } else { - GLOBAL_AssetsWD = NULL; - } -#endif -#if _WIN32 || defined(__MINGW32__) - GET_LD - if ((rc = (SetCurrentDirectory(qpath) != 0)) == 0) - { - Yap_WinError("SetCurrentDirectory failed" ); - } -#else - rc = (chdir(qpath) == 0); -#endif - free( qpath ); - return rc; -} -#if _WIN32 || defined(__MINGW32__) -char * -BaseName(const char *X) { - char *qpath = unix2win(X, NULL, YAP_FILENAME_MAX); - char base[YAP_FILENAME_MAX], ext[YAP_FILENAME_MAX]; - _splitpath(qpath, NULL, NULL, base, ext); - strcpy(qpath, base); - strcat(qpath, ext); - return qpath; -} - -char * -DirName(const char *X) { - char dir[YAP_FILENAME_MAX]; - char drive[YAP_FILENAME_MAX]; - char *o = unix2win(X, NULL, YAP_FILENAME_MAX); - int err; - if (!o) - return NULL; - if (( err = _splitpath_s(o, drive, YAP_FILENAME_MAX-1, dir, YAP_FILENAME_MAX-1,NULL, 0, NULL, 0) ) != 0) { - Yap_FileError(OPERATING_SYSTEM_ERROR, TermNil, "could not perform _splitpath %s: %s", X, strerror(errno)); - return NULL; - - } - strncpy(o, drive, YAP_FILENAME_MAX-1); - strncat(o, dir, YAP_FILENAME_MAX-1); - return o; -} -#endif - -static char *myrealpath( const char *path, char *out) -{ -#if _WIN32 || defined(__MINGW32__) - DWORD retval=0; - // notice that the file does not need to exist - retval = GetFullPathName(path, - YAP_FILENAME_MAX, - out, - NULL); - - if (retval == 0) - { - Yap_WinError("Generating a full path name for a file" ); - return NULL; - } - return out; -#elif HAVE_REALPATH - { - char *rc = realpath(path,out); - char *s0; - - if (rc == NULL && (errno == ENOENT|| errno == EACCES)) { - char *s = basename((char *)path); - s0 = malloc(strlen(s)+1); - strcpy(s0, s); - if ((rc = myrealpath(dirname((char *)path), out))==NULL) { - Yap_FileError(OPERATING_SYSTEM_ERROR, TermNil, "could not find file %s: %s", path, strerror(errno)); - return NULL; - } - if(rc[strlen(rc)-1] != '/' ) - strcat(rc, "/"); - strcat(rc, s0); - free(s0); - } - return rc; - } -#else - return NULL; -#endif -} - -char * - AbsoluteFile(const char *spec, char *tmp) -{ - GET_LD - char *rc; -#if HAVE_WORDEXP - char o[YAP_FILENAME_MAX+1]; -#elif _WIN32 || defined(__MINGW32__) - char u[YAP_FILENAME_MAX+1]; - // first pass, remove Unix style stuff - if (unix2win(spec, u, YAP_FILENAME_MAX) == NULL) - return NULL; - spec = (const char *)u; -#endif - if (tmp == NULL) { - tmp = malloc(YAP_FILENAME_MAX+1); - if (tmp == NULL) { - return NULL; - } - } - if ( truePrologFlag(PLFLAG_FILEVARS) ) - { - spec=expandVars(spec,o,YAP_FILENAME_MAX); - } -#if HAVE_REALPATH - rc = myrealpath(spec, tmp); -#endif - return rc; -} - - char *canoniseFileName( char *path) { -#if HAVE_REALPATH && HAVE_BASENAME -#if _WIN32 || defined(__MINGW32__) - char *o = malloc(YAP_FILENAME_MAX+1); - if (!o) - return NULL; - // first pass, remove Unix style stuff - if (unix2win(path, o, YAP_FILENAME_MAX) == NULL) - return NULL; - path = o; -#endif - char *rc, *tmp = malloc(PATH_MAX); - if (tmp == NULL) return NULL; - rc = myrealpath(path, tmp); - if (rc != tmp) - free(tmp); -#if _WIN32 || defined(__MINGW32__) - free(o); -#endif - return rc; -#endif -} - -Atom Yap_TemporaryFile( const char *prefix, int *fd) { -#if HAVE_MKSTEMP - char *tmp = malloc(PATH_MAX); - int n; - int f; - if (tmp == NULL) return (atom_t)0; - strncpy(tmp, prefix, PATH_MAX-1); - n = strlen( tmp ); - if (n >= 6 && - tmp[n-1] == 'X' && - tmp[n-2] == 'X' && - tmp[n-3] == 'X' && - tmp[n-4] == 'X' && - tmp[n-5] == 'X' && - tmp[n-6] == 'X') - f = mkstemp(tmp); - else { - strncat(tmp, "XXXXXX", PATH_MAX-1); - f = mkstemp(tmp); - } - if (fd) *fd = f; - return Yap_LookupAtom(tmp); -#else - return AtomNil; -#endif -} - -static bool -initSysPath(Term tlib, Term tcommons, bool dir_done, bool commons_done) { - CACHE_REGS - int len; - -#if __WINDOWS__ - { - char *dir; - if ((dir = Yap_RegistryGetString("library")) && - is_directory(dir)) { - if (! Yap_unify( tlib, - MkAtomTerm(Yap_LookupAtom(dir))) ) - return FALSE; - } - dir_done = true; - if ((dir = Yap_RegistryGetString("prolog_commons")) && - is_directory(dir)) { - if (! Yap_unify( tcommons, - MkAtomTerm(Yap_LookupAtom(dir))) ) - return FALSE; - } - commons_done = true; - } - if (dir_done && commons_done) - return TRUE; -#endif - strncpy(LOCAL_FileNameBuf, YAP_SHAREDIR, YAP_FILENAME_MAX); - strncat(LOCAL_FileNameBuf,"/", YAP_FILENAME_MAX); - len = strlen(LOCAL_FileNameBuf); - if (!dir_done) { - strncat(LOCAL_FileNameBuf, "Yap", YAP_FILENAME_MAX); - if (is_directory(LOCAL_FileNameBuf)) - { - if (! Yap_unify( tlib, - MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf))) ) - return FALSE; - } - dir_done = true; - - } - if (!commons_done) { - LOCAL_FileNameBuf[len] = '\0'; - strncat(LOCAL_FileNameBuf, "PrologCommons", YAP_FILENAME_MAX); - if (is_directory(LOCAL_FileNameBuf)) { - if (! Yap_unify( tcommons, - MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf))) ) - return FALSE; - } - commons_done = true; - } - if (dir_done && commons_done) - return TRUE; - -#if __WINDOWS__ - { - size_t buflen; - char *pt; - /* couldn't find it where it was supposed to be, - let's try using the executable */ - if (!GetModuleFileName( NULL, LOCAL_FileNameBuf, YAP_FILENAME_MAX)) { - Yap_WinError( "could not find executable name" ); - /* do nothing */ - return FALSE; - } - buflen = strlen(LOCAL_FileNameBuf); - pt = LOCAL_FileNameBuf+buflen; - while (*--pt != '\\') { - /* skip executable */ - if (pt == LOCAL_FileNameBuf) { - Yap_FileError(OPERATING_SYSTEM_ERROR, TermNil, "could not find executable name"); - /* do nothing */ - return FALSE; - } - } - while (*--pt != '\\') { - /* skip parent directory "bin\\" */ - if (pt == LOCAL_FileNameBuf) { - Yap_FileError(OPERATING_SYSTEM_ERROR, TermNil, "could not find executable name"); - /* do nothing */ - return FALSE; - } - } - /* now, this is a possible location for the ROOT_DIR, let's look for a share directory here */ - pt[1] = '\0'; - /* grosse */ - strncat(LOCAL_FileNameBuf,"lib\\Yap",YAP_FILENAME_MAX); - libdir = Yap_AllocCodeSpace(strlen(LOCAL_FileNameBuf)+1); - strncpy(libdir, LOCAL_FileNameBuf, strlen(LOCAL_FileNameBuf)+1); - pt[1] = '\0'; - strncat(LOCAL_FileNameBuf,"share",YAP_FILENAME_MAX); - } - strncat(LOCAL_FileNameBuf,"\\", YAP_FILENAME_MAX); - len = strlen(LOCAL_FileNameBuf); - strncat(LOCAL_FileNameBuf, "Yap", YAP_FILENAME_MAX); - if (!dir_done && is_directory(LOCAL_FileNameBuf)) { - if (! Yap_unify( tlib, - MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf))) ) - return FALSE; - } - dir_done = true; - LOCAL_FileNameBuf[len] = '\0'; - strncat(LOCAL_FileNameBuf, "PrologCommons", YAP_FILENAME_MAX); - if (!commons_done && is_directory(LOCAL_FileNameBuf)) { - if (! Yap_unify( tcommons, - MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf))) ) - return FALSE; - } - commons_done = true; -#endif - return dir_done && commons_done; -} - - -static Int -p_libraries_path( USES_REGS1 ) -{ - return initSysPath( ARG1, ARG2 , false, false ); -} - - -static Int -p_library_dir( USES_REGS1 ) -{ - return initSysPath( ARG1, MkVarTerm(), false, true ); -} - -static Int -p_commons_dir( USES_REGS1 ) -{ - return initSysPath( MkVarTerm(), ARG1, true, false ); -} - -static Int -p_dir_sp ( USES_REGS1 ) -{ -#ifdef MAC - Term t = MkIntTerm(':'); - Term t2 = MkIntTerm('/'); -#elif ATARI || _MSC_VER || defined(__MINGW32__) - Term t = MkIntTerm('\\'); - Term t2 = MkIntTerm('/'); -#else - Term t = MkIntTerm('/'); - Term t2 = MkIntTerm('/'); -#endif - - return Yap_unify_constant(ARG1,t) || Yap_unify_constant(ARG1,t2) ; -} - - -void -Yap_InitPageSize(void) -{ -#ifdef _WIN32 - SYSTEM_INFO si; - GetSystemInfo(&si); - Yap_page_size = si.dwPageSize; -#elif HAVE_UNISTD_H -#if defined(__FreeBSD__) || defined(__DragonFly__) - Yap_page_size = getpagesize(); -#elif defined(_AIX) - Yap_page_size = sysconf(_SC_PAGE_SIZE); -#elif !defined(_SC_PAGESIZE) - Yap_page_size = getpagesize(); -#else - Yap_page_size = sysconf(_SC_PAGESIZE); -#endif -#else -bla bla -#endif -} - -#ifdef SIMICS -#ifdef HAVE_GETRUSAGE -#undef HAVE_GETRUSAGE -#endif -#ifdef HAVE_TIMES -#undef HAVE_TIMES -#endif -#endif /* SIMICS */ - -#ifdef _WIN32 -#if HAVE_GETRUSAGE -#undef HAVE_GETRUSAGE -#endif -#endif - -#if HAVE_GETRUSAGE - -#if HAVE_SYS_TIMES_H -#include -#endif -#if HAVE_SYS_RESOURCE_H -#include -#endif - -#if THREADS -#define StartOfTimes (*(LOCAL_ThreadHandle.start_of_timesp)) -#define last_time (*(LOCAL_ThreadHandle.last_timep)) - -#define StartOfTimes_sys (*(LOCAL_ThreadHandle.start_of_times_sysp)) -#define last_time_sys (*(LOCAL_ThreadHandle.last_time_sysp)) - -#else -/* since the point YAP was started */ -static struct timeval StartOfTimes; - -/* since last call to runtime */ -static struct timeval last_time; - -/* same for system time */ -static struct timeval last_time_sys; -static struct timeval StartOfTimes_sys; -#endif - -/* store user time in this variable */ -static void -InitTime (int wid) -{ - struct rusage rusage; - -#if THREADS - REMOTE_ThreadHandle(wid).start_of_timesp = (struct timeval *)malloc(sizeof(struct timeval)); - REMOTE_ThreadHandle(wid).last_timep = (struct timeval *)malloc(sizeof(struct timeval)); - REMOTE_ThreadHandle(wid).start_of_times_sysp = (struct timeval *)malloc(sizeof(struct timeval)); - REMOTE_ThreadHandle(wid).last_time_sysp = (struct timeval *)malloc(sizeof(struct timeval)); - getrusage(RUSAGE_SELF, &rusage); - (*REMOTE_ThreadHandle(wid).last_timep).tv_sec = - (*REMOTE_ThreadHandle(wid).start_of_timesp).tv_sec = - rusage.ru_utime.tv_sec; - (*REMOTE_ThreadHandle(wid).last_timep).tv_usec = - (*REMOTE_ThreadHandle(wid).start_of_timesp).tv_usec = - rusage.ru_utime.tv_usec; - (*REMOTE_ThreadHandle(wid).last_time_sysp).tv_sec = - (*REMOTE_ThreadHandle(wid).start_of_times_sysp).tv_sec = - rusage.ru_stime.tv_sec; - (*REMOTE_ThreadHandle(wid).last_time_sysp).tv_usec = - (*REMOTE_ThreadHandle(wid).start_of_times_sysp).tv_usec = - rusage.ru_stime.tv_usec; -#else - getrusage(RUSAGE_SELF, &rusage); - last_time.tv_sec = - StartOfTimes.tv_sec = - rusage.ru_utime.tv_sec; - last_time.tv_usec = - StartOfTimes.tv_usec = - rusage.ru_utime.tv_usec; - last_time_sys.tv_sec = - StartOfTimes_sys.tv_sec = - rusage.ru_stime.tv_sec; - last_time_sys.tv_usec = - StartOfTimes_sys.tv_usec = - rusage.ru_stime.tv_usec; -#endif -} - - -UInt -Yap_cputime ( void ) -{ - CACHE_REGS - struct rusage rusage; - - getrusage(RUSAGE_SELF, &rusage); - return((rusage.ru_utime.tv_sec - StartOfTimes.tv_sec)) * 1000 + - ((rusage.ru_utime.tv_usec - StartOfTimes.tv_usec) / 1000); -} - -void Yap_cputime_interval(Int *now,Int *interval) -{ - CACHE_REGS - struct rusage rusage; - - getrusage(RUSAGE_SELF, &rusage); - *now = (rusage.ru_utime.tv_sec - StartOfTimes.tv_sec) * 1000 + - (rusage.ru_utime.tv_usec - StartOfTimes.tv_usec) / 1000; - *interval = (rusage.ru_utime.tv_sec - last_time.tv_sec) * 1000 + - (rusage.ru_utime.tv_usec - last_time.tv_usec) / 1000; - last_time.tv_usec = rusage.ru_utime.tv_usec; - last_time.tv_sec = rusage.ru_utime.tv_sec; -} - -void Yap_systime_interval(Int *now,Int *interval) -{ - CACHE_REGS - struct rusage rusage; - - getrusage(RUSAGE_SELF, &rusage); - *now = (rusage.ru_stime.tv_sec - StartOfTimes_sys.tv_sec) * 1000 + - (rusage.ru_stime.tv_usec - StartOfTimes_sys.tv_usec) / 1000; - *interval = (rusage.ru_stime.tv_sec - last_time_sys.tv_sec) * 1000 + - (rusage.ru_stime.tv_usec - last_time_sys.tv_usec) / 1000; - last_time_sys.tv_usec = rusage.ru_stime.tv_usec; - last_time_sys.tv_sec = rusage.ru_stime.tv_sec; -} - -#elif defined(_WIN32) - -#ifdef __GNUC__ - -/* This is stolen from the Linux kernel. - The problem is that mingw32 does not seem to have acces to div */ -#ifndef do_div -#define do_div(n,base) ({ \ - unsigned long __upper, __low, __high, __mod; \ - asm("":"=a" (__low), "=d" (__high):"A" (n)); \ - __upper = __high; \ - if (__high) { \ - __upper = __high % (base); \ - __high = __high / (base); \ - } \ - asm("divl %2":"=a" (__low), "=d" (__mod):"rm" (base), "0" (__low), "1" (__upper)); \ - asm("":"=A" (n):"a" (__low),"d" (__high)); \ - __mod; \ -}) -#endif - -#endif - - - -#include - -static FILETIME StartOfTimes, last_time; - -static FILETIME StartOfTimes_sys, last_time_sys; - -static clock_t TimesStartOfTimes, Times_last_time; - -/* store user time in this variable */ -static void -InitTime (int wid) -{ - HANDLE hProcess = GetCurrentProcess(); - FILETIME CreationTime, ExitTime, KernelTime, UserTime; - if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) { - /* WIN98 */ - clock_t t; - t = clock (); - Times_last_time = TimesStartOfTimes = t; - } else { -#if THREADS - REMOTE_ThreadHandle(wid).start_of_timesp = (struct _FILETIME *)malloc(sizeof(FILETIME)); - REMOTE_ThreadHandle(wid).last_timep = (struct _FILETIME *)malloc(sizeof(FILETIME)); - REMOTE_ThreadHandle(wid).start_of_times_sysp = (struct _FILETIME *)malloc(sizeof(FILETIME)); - REMOTE_ThreadHandle(wid).last_time_sysp = (struct _FILETIME *)malloc(sizeof(FILETIME)); - (*REMOTE_ThreadHandle(wid).last_timep).dwLowDateTime = - UserTime.dwLowDateTime; - (*REMOTE_ThreadHandle(wid).last_timep).dwHighDateTime = - UserTime.dwHighDateTime; - (*REMOTE_ThreadHandle(wid).start_of_timesp).dwLowDateTime = - UserTime.dwLowDateTime; - (*REMOTE_ThreadHandle(wid).start_of_timesp).dwHighDateTime = - UserTime.dwHighDateTime; - (*REMOTE_ThreadHandle(wid).last_time_sysp).dwLowDateTime = - KernelTime.dwLowDateTime; - (*REMOTE_ThreadHandle(wid).last_time_sysp).dwHighDateTime = - KernelTime.dwHighDateTime; - (*REMOTE_ThreadHandle(wid).start_of_times_sysp).dwLowDateTime = - KernelTime.dwLowDateTime; - (*REMOTE_ThreadHandle(wid).start_of_times_sysp).dwHighDateTime = - KernelTime.dwHighDateTime; -#else - last_time.dwLowDateTime = - UserTime.dwLowDateTime; - last_time.dwHighDateTime = - UserTime.dwHighDateTime; - StartOfTimes.dwLowDateTime = - UserTime.dwLowDateTime; - StartOfTimes.dwHighDateTime = - UserTime.dwHighDateTime; - last_time_sys.dwLowDateTime = - KernelTime.dwLowDateTime; - last_time_sys.dwHighDateTime = - KernelTime.dwHighDateTime; - StartOfTimes_sys.dwLowDateTime = - KernelTime.dwLowDateTime; - StartOfTimes_sys.dwHighDateTime = - KernelTime.dwHighDateTime; -#endif - } -} - -#ifdef __GNUC__ -static unsigned long long int -sub_utime(FILETIME t1, FILETIME t2) -{ - ULARGE_INTEGER u[2]; - memcpy((void *)u,(void *)&t1,sizeof(FILETIME)); - memcpy((void *)(u+1),(void *)&t2,sizeof(FILETIME)); - return - u[0].QuadPart - u[1].QuadPart; -} -#endif - -UInt -Yap_cputime ( void ) -{ - HANDLE hProcess = GetCurrentProcess(); - FILETIME CreationTime, ExitTime, KernelTime, UserTime; - if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) { - clock_t t; - t = clock (); - return(((t - TimesStartOfTimes)*1000) / CLOCKS_PER_SEC); - } else { -#ifdef __GNUC__ - unsigned long long int t = - sub_utime(UserTime,StartOfTimes); - do_div(t,10000); - return((Int)t); -#endif -#ifdef _MSC_VER - __int64 t = *(__int64 *)&UserTime - *(__int64 *)&StartOfTimes; - return((Int)(t/10000)); -#endif - } -} - -void Yap_cputime_interval(Int *now,Int *interval) -{ - HANDLE hProcess = GetCurrentProcess(); - FILETIME CreationTime, ExitTime, KernelTime, UserTime; - if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) { - clock_t t; - t = clock (); - *now = ((t - TimesStartOfTimes)*1000) / CLOCKS_PER_SEC; - *interval = (t - Times_last_time) * 1000 / CLOCKS_PER_SEC; - Times_last_time = t; - } else { -#ifdef __GNUC__ - unsigned long long int t1 = - sub_utime(UserTime, StartOfTimes); - unsigned long long int t2 = - sub_utime(UserTime, last_time); - do_div(t1,10000); - *now = (Int)t1; - do_div(t2,10000); - *interval = (Int)t2; -#endif -#ifdef _MSC_VER - __int64 t1 = *(__int64 *)&UserTime - *(__int64 *)&StartOfTimes; - __int64 t2 = *(__int64 *)&UserTime - *(__int64 *)&last_time; - *now = (Int)(t1/10000); - *interval = (Int)(t2/10000); -#endif - last_time.dwLowDateTime = UserTime.dwLowDateTime; - last_time.dwHighDateTime = UserTime.dwHighDateTime; - } -} - -void Yap_systime_interval(Int *now,Int *interval) -{ - HANDLE hProcess = GetCurrentProcess(); - FILETIME CreationTime, ExitTime, KernelTime, UserTime; - if (!GetProcessTimes(hProcess, &CreationTime, &ExitTime, &KernelTime, &UserTime)) { - *now = *interval = 0; /* not available */ - } else { -#ifdef __GNUC__ - unsigned long long int t1 = - sub_utime(KernelTime, StartOfTimes_sys); - unsigned long long int t2 = - sub_utime(KernelTime, last_time_sys); - do_div(t1,10000); - *now = (Int)t1; - do_div(t2,10000); - *interval = (Int)t2; -#endif -#ifdef _MSC_VER - __int64 t1 = *(__int64 *)&KernelTime - *(__int64 *)&StartOfTimes_sys; - __int64 t2 = *(__int64 *)&KernelTime - *(__int64 *)&last_time_sys; - *now = (Int)(t1/10000); - *interval = (Int)(t2/10000); -#endif - last_time_sys.dwLowDateTime = KernelTime.dwLowDateTime; - last_time_sys.dwHighDateTime = KernelTime.dwHighDateTime; - } -} - -#elif HAVE_TIMES - -#if defined(_WIN32) - -#include - -#define TicksPerSec CLOCKS_PER_SEC - -#else - -#if HAVE_SYS_TIMES_H -#include -#endif - -#endif - -#if defined(__sun__) && (defined(__svr4__) || defined(__SVR4)) - -#if HAVE_LIMITS_H -#include -#endif - -#define TicksPerSec CLK_TCK -#endif - -#if defined(__alpha) || defined(__FreeBSD__) || defined(__linux__) || defined(__DragonFly__) - -#if HAVE_TIME_H -#include -#endif - -#define TicksPerSec sysconf(_SC_CLK_TCK) - -#endif - -#if !TMS_IN_SYS_TIME -#if HAVE_SYS_TIMES_H -#include -#endif -#endif - -static clock_t StartOfTimes, last_time; - -static clock_t StartOfTimes_sys, last_time_sys; - -/* store user time in this variable */ -static void -InitTime (void) -{ - struct tms t; - times (&t); - (*REMOTE_ThreadHandle(wid).last_timep) = StartOfTimes = t.tms_utime; - last_time_sys = StartOfTimes_sys = t.tms_stime; -} - -UInt -Yap_cputime (void) -{ - struct tms t; - times(&t); - return((t.tms_utime - StartOfTimes)*1000 / TicksPerSec); -} - -void Yap_cputime_interval(Int *now,Int *interval) -{ - struct tms t; - times (&t); - *now = ((t.tms_utime - StartOfTimes)*1000) / TicksPerSec; - *interval = (t.tms_utime - last_time) * 1000 / TicksPerSec; - last_time = t.tms_utime; -} - -void Yap_systime_interval(Int *now,Int *interval) -{ - struct tms t; - times (&t); - *now = ((t.tms_stime - StartOfTimes_sys)*1000) / TicksPerSec; - *interval = (t.tms_stime - last_time_sys) * 1000 / TicksPerSec; - last_time_sys = t.tms_stime; -} - -#else /* HAVE_TIMES */ - -#ifdef SIMICS - -#include - -/* since the point YAP was started */ -static struct timeval StartOfTimes; - -/* since last call to runtime */ -static struct timeval last_time; - -/* store user time in this variable */ -static void -InitTime (int wid) -{ - struct timeval tp; - - gettimeofday(&tp,NULL); - (*REMOTE_ThreadHandle(wid).last_timep).tv_sec = (*REMOTE_ThreadHandle.start_of_timesp(wid)).tv_sec = tp.tv_sec; - (*REMOTE_ThreadHandle(wid).last_timep).tv_usec = (*REMOTE_ThreadHandle.start_of_timesp(wid)).tv_usec = tp.tv_usec; -} - - -UInt -Yap_cputime (void) -{ - struct timeval tp; - - gettimeofday(&tp,NULL); - if (StartOfTimes.tv_usec > tp.tv_usec) - return((tp.tv_sec - StartOfTimes.tv_sec - 1) * 1000 + - (StartOfTimes.tv_usec - tp.tv_usec) /1000); - else - return((tp.tv_sec - StartOfTimes.tv_sec)) * 1000 + - ((tp.tv_usec - StartOfTimes.tv_usec) / 1000); -} - -void Yap_cputime_interval(Int *now,Int *interval) -{ - struct timeval tp; - - gettimeofday(&tp,NULL); - *now = (tp.tv_sec - StartOfTimes.tv_sec) * 1000 + - (tp.tv_usec - StartOfTimes.tv_usec) / 1000; - *interval = (tp.tv_sec - last_time.tv_sec) * 1000 + - (tp.tv_usec - last_time.tv_usec) / 1000; - last_time.tv_usec = tp.tv_usec; - last_time.tv_sec = tp.tv_sec; -} - -void Yap_systime_interval(Int *now,Int *interval) -{ - *now = *interval = 0; /* not available */ -} - -#endif /* SIMICS */ - -#ifdef COMMENTED_OUT -/* This code is not working properly. I left it here to help future ports */ -#ifdef MPW - -#include -#include - -#define TicksPerSec 60.0 - -static double -real_cputime () -{ - return (((double) TickCount ()) / TicksPerSec); -} - -#endif /* MPW */ - -#ifdef LATTICE - -#include "osbind.h" - -static long *ptime; - -gettime () -{ - *ptime = *(long *) 0x462; -} - -static double -real_cputime () -{ - long thetime; - ptime = &thetime; - xbios (38, gettime); - return (((double) thetime) / (Getrez () == 2 ? 70 : 60)); -} - -#endif /* LATTICE */ - -#ifdef M_WILLIAMS - -#include -#include - -static long *ptime; - -static long -readtime () -{ - return (*((long *) 0x4ba)); -} - -static double -real_cputime () -{ - long time; - - time = Supexec (readtime); - return (time / 200.0); -} - -#endif /* M_WILLIAMS */ - -#ifdef LIGHT - -#undef FALSE -#undef TRUE - -#include - -#define TicksPerSec 60.0 - -static double -real_cputime () -{ - return (((double) TickCount ()) / TicksPerSec); -} - -#endif /* LIGHT */ - -#endif /* COMMENTED_OUT */ - -#endif /* HAVE_GETRUSAGE */ - -#if HAVE_GETHRTIME - -#if HAVE_TIME_H -#include -#endif - -/* since the point YAP was started */ -static hrtime_t StartOfWTimes; - -/* since last call to walltime */ -#define LastWtime (*(hrtime_t *)ALIGN_BY_TYPE(LastWtimePtr,hrtime_t)) - -static void -InitWTime (void) -{ - StartOfWTimes = gethrtime(); -} - -static void -InitLastWtime(void) { - /* ask for twice the space in order to guarantee alignment */ - LastWtimePtr = (void *)Yap_AllocCodeSpace(2*sizeof(hrtime_t)); - LastWtime = StartOfWTimes; -} - -Int -Yap_walltime (void) -{ - hrtime_t tp = gethrtime(); - /* return time in milliseconds */ - return((Int)((tp-StartOfWTimes)/((hrtime_t)1000000))); - -} - -void Yap_walltime_interval(Int *now,Int *interval) -{ - hrtime_t tp = gethrtime(); - /* return time in milliseconds */ - *now = (Int)((tp-StartOfWTimes)/((hrtime_t)1000000)); - *interval = (Int)((tp-LastWtime)/((hrtime_t)1000000)); - LastWtime = tp; -} - - -#elif HAVE_GETTIMEOFDAY - -/* since the point YAP was started */ -static struct timeval StartOfWTimes; - -/* since last call to walltime */ -#define LastWtime (*(struct timeval *)LastWtimePtr) - -/* store user time in this variable */ -static void -InitWTime (void) -{ - gettimeofday(&StartOfWTimes,NULL); -} - -static void -InitLastWtime(void) { - LastWtimePtr = (void *)Yap_AllocCodeSpace(sizeof(struct timeval)); - LastWtime.tv_usec = StartOfWTimes.tv_usec; - LastWtime.tv_sec = StartOfWTimes.tv_sec; -} - - -Int -Yap_walltime (void) -{ - struct timeval tp; - - gettimeofday(&tp,NULL); - if (StartOfWTimes.tv_usec > tp.tv_usec) - return((tp.tv_sec - StartOfWTimes.tv_sec - 1) * 1000 + - (StartOfWTimes.tv_usec - tp.tv_usec) /1000); - else - return((tp.tv_sec - StartOfWTimes.tv_sec)) * 1000 + - ((tp.tv_usec - LastWtime.tv_usec) / 1000); -} - -void Yap_walltime_interval(Int *now,Int *interval) -{ - struct timeval tp; - - gettimeofday(&tp,NULL); - *now = (tp.tv_sec - StartOfWTimes.tv_sec) * 1000 + - (tp.tv_usec - StartOfWTimes.tv_usec) / 1000; - *interval = (tp.tv_sec - LastWtime.tv_sec) * 1000 + - (tp.tv_usec - LastWtime.tv_usec) / 1000; - LastWtime.tv_usec = tp.tv_usec; - LastWtime.tv_sec = tp.tv_sec; -} - -#elif defined(_WIN32) - -#include -#include - -/* since the point YAP was started */ -static struct _timeb StartOfWTimes; - -/* since last call to walltime */ -#define LastWtime (*(struct timeb *)LastWtimePtr) - -/* store user time in this variable */ -static void -InitWTime (void) -{ - _ftime(&StartOfWTimes); -} - -static void -InitLastWtime(void) { - LastWtimePtr = (void *)Yap_AllocCodeSpace(sizeof(struct timeb)); - LastWtime.time = StartOfWTimes.time; - LastWtime.millitm = StartOfWTimes.millitm; -} - - -Int -Yap_walltime (void) -{ - struct _timeb tp; - - _ftime(&tp); - if (StartOfWTimes.millitm > tp.millitm) - return((tp.time - StartOfWTimes.time - 1) * 1000 + - (StartOfWTimes.millitm - tp.millitm)); - else - return((tp.time - StartOfWTimes.time)) * 1000 + - ((tp.millitm - LastWtime.millitm) / 1000); -} - -void Yap_walltime_interval(Int *now,Int *interval) -{ - struct _timeb tp; - - _ftime(&tp); - *now = (tp.time - StartOfWTimes.time) * 1000 + - (tp.millitm - StartOfWTimes.millitm); - *interval = (tp.time - LastWtime.time) * 1000 + - (tp.millitm - LastWtime.millitm) ; - LastWtime.millitm = tp.millitm; - LastWtime.time = tp.time; -} - -#elif HAVE_TIMES - -static clock_t StartOfWTimes; - -#define LastWtime (*(clock_t *)LastWtimePtr) - -/* store user time in this variable */ -static void -InitWTime (void) -{ - StartOfWTimes = times(NULL); -} - -static void -InitLastWtime(void) { - LastWtimePtr = (void *)Yap_AllocCodeSpace(sizeof(clock_t)); - LastWtime = StartOfWTimes; -} - -Int -Yap_walltime (void) -{ - clock_t t; - t = times(NULL); - return ((t - StartOfWTimes)*1000 / TicksPerSec)); -} - -void Yap_walltime_interval(Int *now,Int *interval) -{ - clock_t t; - t = times(NULL); - *now = ((t - StartOfWTimes)*1000) / TicksPerSec; - *interval = (t - LastWtime) * 1000 / TicksPerSec; -} - -#endif /* HAVE_TIMES */ - -#if HAVE_TIME_H -#include -#endif - -unsigned int current_seed; - -static void -InitRandom (void) -{ - current_seed = (unsigned int) time (NULL); -#if HAVE_SRAND48 - srand48 (current_seed); -#elif HAVE_SRANDOM - srandom (current_seed); -#elif HAVE_SRAND - srand (current_seed); -#endif -} - -extern int rand(void); - - -double -Yap_random (void) -{ -#if HAVE_DRAND48 - return drand48(); -#elif HAVE_RANDOM - /* extern long random (); */ - return (((double) random ()) / 0x7fffffffL /* 2**31-1 */); -#elif HAVE_RAND - return (((double) (rand ()) / RAND_MAX)); -#else - Yap_Error(SYSTEM_ERROR, TermNil, - "random not available in this configuration"); - return (0.0); -#endif -} - -#if HAVE_RANDOM -static Int -p_init_random_state ( USES_REGS1 ) -{ - register Term t0 = Deref (ARG1); - char *old, *new; - - if (IsVarTerm (t0)) { - return(Yap_unify(ARG1,MkIntegerTerm((Int)current_seed))); - } - if(!IsNumTerm (t0)) - return (FALSE); - if (IsIntTerm (t0)) - current_seed = (unsigned int) IntOfTerm (t0); - else if (IsFloatTerm (t0)) - current_seed = (unsigned int) FloatOfTerm (t0); - else - current_seed = (unsigned int) LongIntOfTerm (t0); - - new = (char *) malloc(256); - old = initstate(random(), new, 256); - return Yap_unify(ARG2, MkIntegerTerm((Int)old)) && - Yap_unify(ARG3, MkIntegerTerm((Int)new)); -} - -static Int -p_set_random_state ( USES_REGS1 ) -{ - register Term t0 = Deref (ARG1); - char *old, * new; - - if (IsVarTerm (t0)) { - return FALSE; - } - if (IsIntegerTerm (t0)) - new = (char *) IntegerOfTerm (t0); - else - return FALSE; - old = setstate( new ); - return Yap_unify(ARG2, MkIntegerTerm((Int)old)); -} - -static Int -p_release_random_state ( USES_REGS1 ) -{ - register Term t0 = Deref (ARG1); - char *old; - - if (IsVarTerm (t0)) { - return FALSE; - } - if (IsIntegerTerm (t0)) - old = (char *) IntegerOfTerm (t0); - else - return FALSE; - free( old ); - return TRUE; -} -#endif - -static Int -p_srandom ( USES_REGS1 ) -{ - register Term t0 = Deref (ARG1); - if (IsVarTerm (t0)) { - return(Yap_unify(ARG1,MkIntegerTerm((Int)current_seed))); - } - if(!IsNumTerm (t0)) - return (FALSE); - if (IsIntTerm (t0)) - current_seed = (unsigned int) IntOfTerm (t0); - else if (IsFloatTerm (t0)) - current_seed = (unsigned int) FloatOfTerm (t0); - else - current_seed = (unsigned int) LongIntOfTerm (t0); -#if HAVE_SRAND48 - srand48(current_seed); -#elif HAVE_SRANDOM - srandom(current_seed); -#elif HAVE_SRAND - srand(current_seed); - -#endif - return (TRUE); -} - -#if HAVE_SIGNAL_H - -#include - -#ifdef MPW -#define signal sigset -#endif - - -#ifdef MSH - -#define SIGFPE SIGDIV - -#endif - -static void InitSignals(void); - -#define PLSIG_PREPARED 0x01 /* signal is prepared */ -#define PLSIG_THROW 0x02 /* throw signal(num, name) */ -#define PLSIG_SYNC 0x04 /* call synchronously */ -#define PLSIG_NOFRAME 0x08 /* Do not create a Prolog frame */ - -#define SIG_PROLOG_OFFSET 32 /* Start of Prolog signals */ - -#define SIG_EXCEPTION (SIG_PROLOG_OFFSET+0) -#ifdef O_ATOMGC -#define SIG_ATOM_GC (SIG_PROLOG_OFFSET+1) -#endif -#define SIG_GC (SIG_PROLOG_OFFSET+2) -#ifdef THREADS -#define SIG_THREAD_SIGNAL (SIG_PROLOG_OFFSET+3) -#endif -#define SIG_FREECLAUSES (SIG_PROLOG_OFFSET+4) -#define SIG_PLABORT (SIG_PROLOG_OFFSET+5) - -static struct signame -{ int sig; - const char *name; - int flags; -} signames[] = -{ -#ifdef SIGHUP - { SIGHUP, "hup", 0}, -#endif - { SIGINT, "int", 0}, -#ifdef SIGQUIT - { SIGQUIT, "quit", 0}, -#endif - { SIGILL, "ill", 0}, - { SIGABRT, "abrt", 0}, -#if HAVE_SIGFPE - { SIGFPE, "fpe", PLSIG_THROW}, -#endif -#ifdef SIGKILL - { SIGKILL, "kill", 0}, -#endif - { SIGSEGV, "segv", 0}, -#ifdef SIGPIPE - { SIGPIPE, "pipe", 0}, -#endif -#ifdef SIGALRM - { SIGALRM, "alrm", PLSIG_THROW}, -#endif - { SIGTERM, "term", 0}, -#ifdef SIGUSR1 - { SIGUSR1, "usr1", 0}, -#endif -#ifdef SIGUSR2 - { SIGUSR2, "usr2", 0}, -#endif -#ifdef SIGCHLD - { SIGCHLD, "chld", 0}, -#endif -#ifdef SIGCONT - { SIGCONT, "cont", 0}, -#endif -#ifdef SIGSTOP - { SIGSTOP, "stop", 0}, -#endif -#ifdef SIGTSTP - { SIGTSTP, "tstp", 0}, -#endif -#ifdef SIGTTIN - { SIGTTIN, "ttin", 0}, -#endif -#ifdef SIGTTOU - { SIGTTOU, "ttou", 0}, -#endif -#ifdef SIGTRAP - { SIGTRAP, "trap", 0}, -#endif -#ifdef SIGBUS - { SIGBUS, "bus", 0}, -#endif -#ifdef SIGSTKFLT - { SIGSTKFLT, "stkflt", 0}, -#endif -#ifdef SIGURG - { SIGURG, "urg", 0}, -#endif -#ifdef SIGIO - { SIGIO, "io", 0}, -#endif -#ifdef SIGPOLL - { SIGPOLL, "poll", 0}, -#endif -#ifdef SIGXCPU - { SIGXCPU, "xcpu", PLSIG_THROW}, -#endif -#ifdef SIGXFSZ - { SIGXFSZ, "xfsz", PLSIG_THROW}, -#endif -#ifdef SIGVTALRM - { SIGVTALRM, "vtalrm", PLSIG_THROW}, -#endif -#ifdef SIGPROF - { SIGPROF, "prof", 0}, -#endif -#ifdef SIGPWR - { SIGPWR, "pwr", 0}, -#endif - { SIG_EXCEPTION, "prolog:exception", 0 }, -#ifdef SIG_ATOM_GC - { SIG_ATOM_GC, "prolog:atom_gc", 0 }, -#endif - { SIG_GC, "prolog:gc", 0 }, -#ifdef SIG_THREAD_SIGNAL - { SIG_THREAD_SIGNAL, "prolog:thread_signal", 0 }, -#endif - - { -1, NULL, 0} -}; - -/* SWI emulation */ -int -Yap_signal_index(const char *name) -{ struct signame *sn = signames; - char tmp[12]; - - if ( strncmp(name, "SIG", 3) == 0 && strlen(name) < 12 ) - { char *p = (char *)name+3, *q = tmp; - while ((*q++ = tolower(*p++))) {}; - name = tmp; - } - - for( ; sn->name; sn++ ) - { if ( !strcmp(sn->name, name) ) - return sn->sig; - } - - return -1; -} - -#if HAVE_SIGINFO_H -#include -#endif -#if HAVE_SYS_UCONTEXT_H -#include -#endif - -#if HAVE_SIGSEGV -static void -SearchForTrailFault(void *ptr, int sure) -{ - - /* If the TRAIL is very close to the top of mmaped allocked space, - then we can try increasing the TR space and restarting the - instruction. In the worst case, the system will - crash again - */ -#if OS_HANDLES_TR_OVERFLOW && !USE_SYSTEM_MALLOC - if ((ptr > (void *)LOCAL_TrailTop-1024 && - TR < (tr_fr_ptr) LOCAL_TrailTop+(64*1024))) { - if (!Yap_growtrail(64*1024, TRUE)) { - Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, "YAP failed to reserve %ld bytes in growtrail", K64); - } - /* just in case, make sure the OS keeps the signal handler. */ - /* my_signal_info(SIGSEGV, HandleSIGSEGV); */ - } else -#endif /* OS_HANDLES_TR_OVERFLOW */ - if (sure) - Yap_Error(FATAL_ERROR, TermNil, - "tried to access illegal address %p!!!!", ptr); - else - Yap_Error(FATAL_ERROR, TermNil, - "likely bug in YAP, segmentation violation"); -} - - -/* This routine believes there is a continuous space starting from the - HeapBase and ending on TrailTop */ -static void -HandleSIGSEGV(int sig, void *sipv, void *uap) -{ - CACHE_REGS - - void *ptr = TR; - int sure = FALSE; - if (LOCAL_PrologMode & ExtendStackMode) { - Yap_Error(FATAL_ERROR, TermNil, "OS memory allocation crashed at address %p, bailing out\n",LOCAL_TrailTop); - } -#if (defined(__svr4__) || defined(__SVR4)) - siginfo_t *sip = sipv; - if ( - sip->si_code != SI_NOINFO && - sip->si_code == SEGV_MAPERR) { - ptr = sip->si_addr; - sure = TRUE; - } -#elif __linux__ - siginfo_t *sip = sipv; - ptr = sip->si_addr; - sure = TRUE; -#endif - SearchForTrailFault( ptr, sure ); -} -#endif /* SIGSEGV */ - -yap_error_number -Yap_MathException__( USES_REGS1 ) -{ -#if HAVE_FETESTEXCEPT - int raised; - - // #pragma STDC FENV_ACCESS ON - if ((raised = fetestexcept( FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW)) ) { - - feclearexcept(FE_ALL_EXCEPT); - if (raised & FE_OVERFLOW) { - return EVALUATION_ERROR_FLOAT_OVERFLOW; - } else if (raised & FE_DIVBYZERO) { - return EVALUATION_ERROR_ZERO_DIVISOR; - } else if (raised & FE_UNDERFLOW) { - return EVALUATION_ERROR_FLOAT_UNDERFLOW; - //} else if (raised & (FE_INVALID|FE_INEXACT)) { - // return EVALUATION_ERROR_UNDEFINED; - } else { - return EVALUATION_ERROR_UNDEFINED; - } - } -#elif _WIN32 && FALSE - unsigned int raised; - int err; - - // Show original FP control word and do calculation. - err = _controlfp_s(&raised, 0, 0); - if (err) { - return EVALUATION_ERROR_UNDEFINED; - } - if (raised ) { - - feclearexcept(FE_ALL_EXCEPT); - if (raised & FE_OVERFLOW) { - return EVALUATION_ERROR_FLOAT_OVERFLOW; - } else if (raised & FE_DIVBYZERO) { - return EVALUATION_ERROR_ZERO_DIVISOR; - } else if (raised & FE_UNDERFLOW) { - return EVALUATION_ERROR_FLOAT_UNDERFLOW; - //} else if (raised & (FE_INVALID|FE_INEXACT)) { - // return EVALUATION_ERROR_UNDEFINED; - } else { - return EVALUATION_ERROR_UNDEFINED; - } - } -#elif (defined(__svr4__) || defined(__SVR4)) - switch(sip->si_code) { - case FPE_INTDIV: - return EVALUATION_ERROR_ZERO_DIVISOR; - break; - case FPE_INTOVF: - return EVALUATION_ERROR_INT_OVERFLOW; - break; - case FPE_FLTDIV: - return EVALUATION_ERROR_ZERO_DIVISOR; - break; - case FPE_FLTOVF: - return EVALUATION_ERROR_FLOAT_OVERFLOW; - break; - case FPE_FLTUND: - return EVALUATION_ERROR_FLOAT_UNDERFLOW; - break; - case FPE_FLTRES: - case FPE_FLTINV: - case FPE_FLTSUB: - default: - return EVALUATION_ERROR_UNDEFINED; - } - set_fpu_exceptions(0); -#endif - - return LOCAL_matherror; -} - -static Int -p_fpe_error( USES_REGS1 ) -{ - Yap_Error(LOCAL_matherror, LOCAL_mathtt, LOCAL_mathstring); - LOCAL_matherror = YAP_NO_ERROR; - LOCAL_mathtt = TermNil; - LOCAL_mathstring = NULL; - return FALSE; -} - -#if HAVE_SIGFPE -static void -HandleMatherr(int sig, void *sipv, void *uapv) -{ - CACHE_REGS - LOCAL_matherror = Yap_MathException( ); - /* reset the registers so that we don't have trash in abstract machine */ - Yap_external_signal( worker_id, YAP_FPE_SIGNAL ); -} - -#endif /* SIGFPE */ - - - -typedef void (*signal_handler_t)(int, void *, void *); - -#if HAVE_SIGACTION -static void -my_signal_info(int sig, void * handler) -{ - struct sigaction sigact; - - sigact.sa_handler = handler; - sigemptyset(&sigact.sa_mask); - sigact.sa_flags = SA_SIGINFO; - - sigaction(sig,&sigact,NULL); -} - -static void -my_signal(int sig, void * handler) -{ - struct sigaction sigact; - - sigact.sa_handler= (void *)handler; - sigemptyset(&sigact.sa_mask); - sigact.sa_flags = 0; - sigaction(sig,&sigact,NULL); -} - -#else - -static void -my_signal(int sig, void *handler) -{ - signal(sig, handler); -} - -static void -my_signal_info(int sig, void *handler) -{ - if(signal(sig, (void *)handler) == SIG_ERR) - exit(1); -} - -#endif - -#if !defined(LIGHT) && !_MSC_VER && !defined(__MINGW32__) && !defined(LIGHT) -static RETSIGTYPE -ReceiveSignal (int s, void *x, void *y) -{ - CACHE_REGS - LOCAL_PrologMode |= InterruptMode; - my_signal (s, ReceiveSignal); - switch (s) - { - case SIGINT: - // always direct SIGINT to console - Yap_external_signal( 0, YAP_INT_SIGNAL ); - break; - case SIGALRM: - Yap_external_signal( worker_id, YAP_ALARM_SIGNAL ); - break; - case SIGVTALRM: - Yap_external_signal( worker_id, YAP_VTALARM_SIGNAL ); - break; -#ifndef MPW -#ifdef HAVE_SIGFPE - case SIGFPE: - Yap_external_signal( worker_id, YAP_FPE_SIGNAL ); - break; -#endif -#endif -#if !defined(LIGHT) && !defined(_WIN32) - /* These signals are not handled by WIN32 and not the Macintosh */ - case SIGQUIT: - case SIGKILL: - LOCAL_PrologMode &= ~InterruptMode; - Yap_Error(INTERRUPT_ERROR,MkIntTerm(s),NULL); - break; -#endif -#ifdef SIGUSR1 - case SIGUSR1: - /* force the system to creep */ - Yap_external_signal ( worker_id, YAP_USR1_SIGNAL); - break; -#endif /* defined(SIGUSR1) */ -#ifdef SIGUSR2 - case SIGUSR2: - /* force the system to creep */ - Yap_external_signal ( worker_id, YAP_USR2_SIGNAL); - break; -#endif /* defined(SIGUSR2) */ -#ifdef SIGPIPE - case SIGPIPE: - /* force the system to creep */ - Yap_external_signal ( worker_id, YAP_PIPE_SIGNAL); - break; -#endif /* defined(SIGPIPE) */ -#ifdef SIGHUP - case SIGHUP: - /* force the system to creep */ - /* Just ignore SUGHUP Yap_signal (YAP_HUP_SIGNAL); */ - break; -#endif /* defined(SIGHUP) */ - default: - fprintf(stderr, "\n[ Unexpected signal ]\n"); - exit (s); - } - LOCAL_PrologMode &= ~InterruptMode; -} -#endif - -#if (_MSC_VER || defined(__MINGW32__)) -static BOOL WINAPI -MSCHandleSignal(DWORD dwCtrlType) { -#if THREADS - if (REMOTE_InterruptsDisabled(0)) { -#else - if (LOCAL_InterruptsDisabled) { -#endif - return FALSE; - } - switch(dwCtrlType) { - case CTRL_C_EVENT: - case CTRL_BREAK_EVENT: -#if THREADS - Yap_external_signal(0, YAP_WINTIMER_SIGNAL); - REMOTE_PrologMode(0) |= InterruptMode; -#else - Yap_signal(YAP_WINTIMER_SIGNAL); - LOCAL_PrologMode |= InterruptMode; -#endif - return(TRUE); - default: - return(FALSE); - } -} -#endif - - -/* SIGINT can cause problems, if caught before full initialization */ -static void -InitSignals (void) -{ - if (GLOBAL_PrologShouldHandleInterrupts) { -#if !defined(LIGHT) && !_MSC_VER && !defined(__MINGW32__) && !defined(LIGHT) - my_signal (SIGQUIT, ReceiveSignal); - my_signal (SIGKILL, ReceiveSignal); - my_signal (SIGUSR1, ReceiveSignal); - my_signal (SIGUSR2, ReceiveSignal); - my_signal (SIGHUP, ReceiveSignal); - my_signal (SIGALRM, ReceiveSignal); - my_signal (SIGVTALRM, ReceiveSignal); -#endif -#ifdef SIGPIPE - my_signal (SIGPIPE, ReceiveSignal); -#endif -#if _MSC_VER || defined(__MINGW32__) - signal (SIGINT, SIG_IGN); - SetConsoleCtrlHandler(MSCHandleSignal,TRUE); -#else - my_signal (SIGINT, ReceiveSignal); -#endif -#ifdef HAVE_SIGFPE - my_signal (SIGFPE, HandleMatherr); -#endif -#if HAVE_SIGSEGV - my_signal_info (SIGSEGV, HandleSIGSEGV); -#endif -#ifdef YAPOR_COW - signal(SIGCHLD, SIG_IGN); /* avoid ghosts */ -#endif - } -} - -#endif /* HAVE_SIGNAL */ - - -/* TrueFileName -> Finds the true name of a file */ - -#ifdef __MINGW32__ -#include -#endif - -static int -volume_header(char *file) -{ -#if _MSC_VER || defined(__MINGW32__) - char *ch = file; - int c; - - while ((c = ch[0]) != '\0') { - if (isalnum(c)) ch++; - else return(c == ':'); - } -#endif - return(FALSE); -} - -int -Yap_volume_header(char *file) -{ - return volume_header(file); -} - - char * PL_cwd(char *cwd, size_t cwdlen) - { - return (char *)Yap_getcwd( (const char *)cwd, cwdlen ); - } - - const char * Yap_getcwd(const char *cwd, size_t cwdlen) - { -#if _WIN32 || defined(__MINGW32__) - if (GetCurrentDirectory(cwdlen, (char *)cwd) == 0) - { - Yap_WinError("GetCurrentDirectory failed" ); - return NULL; - } - return (char *)cwd; -#else -#if __ANDROID__ - if (GLOBAL_AssetsWD) { - return strncpy( (char *)cwd, (const char *)GLOBAL_AssetsWD, cwdlen); - } - -#endif - return getcwd((char *)cwd, cwdlen); -#endif - } - - - static char * - expandWithPrefix(const char *source, const char *root, char *result) - { - char *work; - char ares1[YAP_FILENAME_MAX+1]; - - - work = expandVars( source, ares1, YAP_FILENAME_MAX); - // expand names first - if (root && !IsAbsolutePath( source ) ) { - char ares2[YAP_FILENAME_MAX+1]; - strncpy( ares2, root, YAP_FILENAME_MAX ); - strncat( ares2, "/", YAP_FILENAME_MAX ); - strncat( ares2, work, YAP_FILENAME_MAX ); - return AbsoluteFile( ares2, result ); - } else { - // expand path - return myrealpath( work, result); - } - } - - /** Yap_trueFileName: tries to generate the true name of file - * - * - * @param isource the proper file - * @param idef the default name fo rthe file, ie, startup.yss - * @param root the prefix - * @param result the output - * @param access verify whether the file has access permission - * @param ftype saved state, object, saved file, prolog file - * @param expand_root expand $ ~, etc - * @param in_lib library file - * - * @return - */ - bool - Yap_trueFileName (const char *isource, const char * idef, const char *iroot, char *result, bool access, file_type_t ftype, bool expand_root, bool in_lib) -{ - - char save_buffer[YAP_FILENAME_MAX+1]; - const char *root, *source = isource; - int rc = FAIL_RESTORE; - int try = 0; - - while ( rc == FAIL_RESTORE) { - bool done = false; - // { CACHE_REGS __android_log_print(ANDROID_LOG_ERROR, __FUNCTION__, "try=%d %s %s", try, isource, iroot) ; } - switch (try++) { - case 0: // path or file name is given; - root = iroot; - if (iroot || isource) { - source = ( isource ? isource : idef ) ; - } else { - done = true; - } - break; - case 1: // library directory is given in command line - if ( in_lib && ftype == YAP_SAVED_STATE) { - root = iroot; - source = ( isource ? isource : idef ) ; - } else - done = true; - break; - case 2: // use environment variable YAPLIBDIR -#if HAVE_GETENV - if ( in_lib) { - if (ftype == YAP_SAVED_STATE || ftype == YAP_OBJ) { - root = getenv("YAPLIBDIR"); - } else { - root = getenv("YAPSHAREDIR"); - } - source = ( isource ? isource : idef ) ; - } else - done = true; - break; -#else - done = true; -#endif - break; - case 3: // use compilation variable YAPLIBDIR - if ( in_lib) { - source = ( isource ? isource : idef ) ; - if (ftype == YAP_PL || ftype == YAP_QLY) { - root = YAP_SHAREDIR; - } else { - root = YAP_LIBDIR; - } - } else - done = true; - break; - - case 4: // WIN stuff: registry -#if __WINDOWS__ - if ( in_lib) { - source = ( ftype == YAP_PL || ftype == YAP_QLY ? "library" : "startup" ) ; - source = Yap_RegistryGetString( source ); - root = NULL; - } else -#endif - done = true; - break; - - case 5: // search from the binary - { -#ifndef __ANDROID__ - done = true; - break; -#endif - const char *pt = Yap_FindExecutable(); - - if (pt) { - source = ( ftype == YAP_SAVED_STATE || ftype == YAP_OBJ ? "../../lib/Yap" : "../../share/Yap" ) ; - if (Yap_trueFileName(source, NULL, pt, save_buffer, access, ftype, expand_root, in_lib) ) - root = save_buffer; - else - done = true; - } else { - done = true; - } - source = ( isource ? isource : idef ) ; - } - break; - case 6: // default, try current directory - if (!isource && ftype == YAP_SAVED_STATE) - source = idef; - root = NULL; - break; - default: - return false; - } - - if (done) - continue; - if (expand_root && root) { - root = expandWithPrefix( root, NULL, save_buffer ); - } - // { CACHE_REGS __android_log_print(ANDROID_LOG_ERROR, __FUNCTION__, "root= %s %s ", root, source) ; } - char *work = expandWithPrefix( source, root, result ); - - // expand names in case you have - // to add a prefix - if ( !access || exists( work ) ) - return true; // done - } - return false; -} - -int -Yap_TrueFileName (const char *source, char *result, int in_lib) -{ - return Yap_trueFileName (source, NULL, NULL, result, true, YAP_PL, true, in_lib); -} - - int - Yap_TruePrefixedFileName (const char *source, const char *root, char *result, int in_lib) - { - return Yap_trueFileName (source, NULL, root, result, true, YAP_PL, true, in_lib); - } - -static Int -p_true_file_name ( USES_REGS1 ) -{ - Term t = Deref(ARG1); - - if (IsVarTerm(t)) { - Yap_Error(INSTANTIATION_ERROR,t,"argument to true_file_name unbound"); - return FALSE; - } - if (!IsAtomTerm(t)) { - Yap_Error(TYPE_ERROR_ATOM,t,"argument to true_file_name"); - return FALSE; - } - if (!Yap_trueFileName (RepAtom(AtomOfTerm(t))->StrOfAE, NULL, NULL, LOCAL_FileNameBuf, true, YAP_PL, false, false)) - return FALSE; - return Yap_unify(ARG2, MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf))); -} - -static Int -p_expand_file_name ( USES_REGS1 ) -{ - Term t = Deref(ARG1); - - if (IsVarTerm(t)) { - Yap_Error(INSTANTIATION_ERROR,t,"argument to true_file_name unbound"); - return FALSE; - } - if (!IsAtomTerm(t)) { - Yap_Error(TYPE_ERROR_ATOM,t,"argument to true_file_name"); - return FALSE; - } - if (!Yap_trueFileName (RepAtom(AtomOfTerm(t))->StrOfAE, NULL, NULL, LOCAL_FileNameBuf, true, YAP_PL, true, false)) - return false; - return Yap_unify(ARG2, MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf))); -} - -static Int -p_true_file_name3 ( USES_REGS1 ) -{ - Term t = Deref(ARG1), t2 = Deref(ARG2); - char *root = NULL; - - if (IsVarTerm(t)) { - Yap_Error(INSTANTIATION_ERROR,t,"argument to true_file_name unbound"); - return FALSE; - } - if (!IsAtomTerm(t)) { - Yap_Error(TYPE_ERROR_ATOM,t,"argument to true_file_name"); - return FALSE; - } - if (!IsVarTerm(t2)) { - if (!IsAtomTerm(t)) { - Yap_Error(TYPE_ERROR_ATOM,t2,"argument to true_file_name"); - return FALSE; - } - root = RepAtom(AtomOfTerm(t2))->StrOfAE; - } - if (!Yap_trueFileName (RepAtom(AtomOfTerm(t))->StrOfAE, NULL, root, LOCAL_FileNameBuf, true, YAP_PL, false, false)) - return FALSE; - return Yap_unify(ARG3, MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf))); -} - -/* Executes $SHELL under Prolog */ -/** @pred sh - - -Creates a new shell interaction. - - -*/ -static Int -p_sh ( USES_REGS1 ) -{ /* sh */ -#ifdef HAVE_SYSTEM - char *shell; - shell = (char *) getenv ("SHELL"); - if (shell == NULL) - shell = "/bin/sh"; - if (system (shell) < 0) { -#if HAVE_STRERROR - Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "%s in sh/0", strerror(errno)); -#else - Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, "in sh/0"); -#endif - return FALSE; - } - return TRUE; -#else -#ifdef MSH - register char *shell; - shell = "msh -i"; - system (shell); - return (TRUE); -#else - Yap_Error(SYSTEM_ERROR,TermNil,"sh not available in this configuration"); - return(FALSE); -#endif /* MSH */ -#endif -} - -/** shell(+Command:text, -Status:integer) is det. - - Run an external command and wait for its completion. -*/ -static Int -p_shell ( USES_REGS1 ) -{ /* '$shell'(+SystCommand) */ -#if _MSC_VER || defined(__MINGW32__) - char *cmd; - term_t A1 = Yap_InitSlot(ARG1); - if ( PL_get_chars(A1, &cmd, CVT_ALL|REP_FN|CVT_EXCEPTION) ) - { int rval = System(cmd); - - return rval == 0; - } - - return FALSE; -#else -#if HAVE_SYSTEM - char *shell; - register int bourne = FALSE; - Term t1 = Deref (ARG1); - const char *cmd; - - shell = (char *) getenv ("SHELL"); - if (!strcmp (shell, "/bin/sh")) - bourne = TRUE; - if (shell == NIL) - bourne = TRUE; - if (IsAtomTerm(t1)) - cmd = RepAtom(AtomOfTerm(t1))->StrOfAE; - else if (IsStringTerm(t1)) - cmd = StringOfTerm(t1); - else - return FALSE; - /* Yap_CloseStreams(TRUE); */ - if (bourne) - return system( cmd ) == 0; - else { - int status = -1; - int child = fork (); - - if (child == 0) { /* let the children go */ - if (!execl (shell, shell, "-c", cmd , NULL)) { - exit(-1); - } - exit(TRUE); - } - { /* put the father on wait */ - int result = child < 0 || -/* vsc:I am not sure this is used, Stevens say wait returns an integer. -#if NO_UNION_WAIT -*/ - wait ((&status)) != child || -/* -#else - wait ((union wait *) (&status)) != child || -#endif -*/ - status == 0; - return result; - } - } -#else /* HAVE_SYSTEM */ -#ifdef MSH - register char *shell; - shell = "msh -i"; - /* Yap_CloseStreams(); */ - system (shell); - return TRUE; -#else - Yap_Error (SYSTEM_ERROR,TermNil,"shell not available in this configuration"); - return FALSE; -#endif -#endif /* HAVE_SYSTEM */ -#endif /* _MSC_VER */ -} - -/** system(+Command:text). - -Run an external command. -*/ - -static Int -p_system ( USES_REGS1 ) -{ /* '$system'(+SystCommand) */ -#if _MSC_VER || defined(__MINGW32__) - char *cmd; - term_t A1 = Yap_InitSlot(ARG1); - if ( PL_get_chars(A1, &cmd, CVT_ALL|REP_FN|CVT_EXCEPTION) ) - { STARTUPINFO si; - PROCESS_INFORMATION pi; - - ZeroMemory( &si, sizeof(si) ); - si.cb = sizeof(si); - ZeroMemory( &pi, sizeof(pi) ); - - // Start the child process. - if( !CreateProcess( NULL, // No module name (use command line) - cmd, // Command line - NULL, // Process handle not inheritable - NULL, // Thread handle not inheritable - FALSE, // Set handle inheritance to FALSE - 0, // No creation flags - NULL, // Use parent's environment block - NULL, // Use parent's starting directory - &si, // Pointer to STARTUPINFO structure - &pi ) // Pointer to PROCESS_INFORMATION structure - ) - { - Yap_Error( SYSTEM_ERROR, ARG1, "CreateProcess failed (%d).\n", GetLastError() ); - return FALSE; - } - // Wait until child process exits. - WaitForSingleObject( pi.hProcess, INFINITE ); - - // Close process and thread handles. - CloseHandle( pi.hProcess ); - CloseHandle( pi.hThread ); - - return TRUE; - } - - return FALSE; -#elif HAVE_SYSTEM - Term t1 = Deref (ARG1); - const char *s; - - if (IsVarTerm(t1)) { - Yap_Error(INSTANTIATION_ERROR,t1,"argument to system/1 unbound"); - return FALSE; - } else if (IsAtomTerm(t1)) { - s = RepAtom(AtomOfTerm(t1))->StrOfAE; - } else if (IsStringTerm(t1)) { - s = StringOfTerm(t1); - } else { - if (!Yap_GetName (LOCAL_FileNameBuf, YAP_FILENAME_MAX, t1)) { - Yap_Error(TYPE_ERROR_ATOM,t1,"argument to system/1"); - return FALSE; - } - s = LOCAL_FileNameBuf; - } - /* Yap_CloseStreams(TRUE); */ -#if _MSC_VER - _flushall(); -#endif - if (system (s)) { -#if HAVE_STRERROR - Yap_Error(OPERATING_SYSTEM_ERROR,t1,"%s in system(%s)", strerror(errno), s); -#else - Yap_Error(OPERATING_SYSTEM_ERROR,t1,"in system(%s)", s); -#endif - return FALSE; - } - return TRUE; -#else -#ifdef MSH - register char *shell; - shell = "msh -i"; - /* Yap_CloseStreams(); */ - system (shell); - return (TRUE); -#undef command -#else - Yap_Error(SYSTEM_ERROR,TermNil,"sh not available in this machine"); - return(FALSE); -#endif -#endif /* HAVE_SYSTEM */ -} - - - -/* Rename a file */ -/** @pred rename(+ _F_,+ _G_) - - Renames file _F_ to _G_. -*/ -static Int -p_mv ( USES_REGS1 ) -{ /* rename(+OldName,+NewName) */ -#if HAVE_LINK - int r; - char oldname[YAP_FILENAME_MAX], newname[YAP_FILENAME_MAX]; - Term t1 = Deref (ARG1); - Term t2 = Deref (ARG2); - if (IsVarTerm(t1)) { - Yap_Error(INSTANTIATION_ERROR, t1, "first argument to rename/2 unbound"); - } else if (!IsAtomTerm(t1)) { - Yap_Error(TYPE_ERROR_ATOM, t1, "first argument to rename/2 not atom"); - } - if (IsVarTerm(t2)) { - Yap_Error(INSTANTIATION_ERROR, t2, "second argument to rename/2 unbound"); - } else if (!IsAtomTerm(t2)) { - Yap_Error(TYPE_ERROR_ATOM, t2, "second argument to rename/2 not atom"); - } - if (!Yap_trueFileName (RepAtom(AtomOfTerm(t1))->StrOfAE, NULL, NULL, oldname, true, YAP_STD, true, false)) - return FALSE; - if (!Yap_trueFileName (RepAtom(AtomOfTerm(t2))->StrOfAE, NULL, NULL, oldname, true, YAP_STD, true, false)) - return FALSE; - if ((r = link (oldname, newname)) == 0 && (r = unlink (oldname)) != 0) - unlink (newname); - if (r != 0) { -#if HAVE_STRERROR - Yap_Error(OPERATING_SYSTEM_ERROR,t2,"%s in rename(%s,%s)", strerror(errno),oldname,newname); -#else - Yap_Error(OPERATING_SYSTEM_ERROR,t2,"in rename(%s,%s)",oldname,newname); -#endif - return FALSE; - } - return TRUE; -#else - Yap_Error(SYSTEM_ERROR,TermNil,"rename/2 not available in this machine"); - return (FALSE); -#endif -} - - -#ifdef MAC - -void -Yap_SetTextFile (name) - char *name; -{ -#ifdef MACC - SetFileType (name, 'TEXT'); - SetFileSignature (name, 'EDIT'); -#else - FInfo f; - FInfo *p = &f; - GetFInfo (name, 0, p); - p->fdType = 'TEXT'; -#ifdef MPW - if (mpwshell) - p->fdCreator = 'MPS\0'; -#endif -#ifndef LIGHT - else - p->fdCreator = 'EDIT'; -#endif - SetFInfo (name, 0, p); -#endif -} - -#endif - - -/* return YAP's environment */ -static Int p_getenv( USES_REGS1 ) -{ -#if HAVE_GETENV - Term t1 = Deref(ARG1), to; - char *s, *so; - - if (IsVarTerm(t1)) { - Yap_Error(INSTANTIATION_ERROR, t1, - "first arg of getenv/2"); - return(FALSE); - } else if (!IsAtomTerm(t1)) { - Yap_Error(TYPE_ERROR_ATOM, t1, - "first arg of getenv/2"); - return(FALSE); - } else s = RepAtom(AtomOfTerm(t1))->StrOfAE; - if ((so = getenv(s)) == NULL) - return(FALSE); - to = MkAtomTerm(Yap_LookupAtom(so)); - return(Yap_unify_constant(ARG2,to)); -#else - Yap_Error(SYSTEM_ERROR, TermNil, - "getenv not available in this configuration"); - return (FALSE); -#endif -} - -/* set a variable in YAP's environment */ -static Int p_putenv( USES_REGS1 ) -{ -#if HAVE_PUTENV - Term t1 = Deref(ARG1), t2 = Deref(ARG2); - char *s, *s2, *p0, *p; - - if (IsVarTerm(t1)) { - Yap_Error(INSTANTIATION_ERROR, t1, - "first arg to putenv/2"); - return(FALSE); - } else if (!IsAtomTerm(t1)) { - Yap_Error(TYPE_ERROR_ATOM, t1, - "first arg to putenv/2"); - return(FALSE); - } else s = RepAtom(AtomOfTerm(t1))->StrOfAE; - if (IsVarTerm(t2)) { - Yap_Error(INSTANTIATION_ERROR, t1, - "second arg to putenv/2"); - return(FALSE); - } else if (!IsAtomTerm(t2)) { - Yap_Error(TYPE_ERROR_ATOM, t2, - "second arg to putenv/2"); - return(FALSE); - } else s2 = RepAtom(AtomOfTerm(t2))->StrOfAE; - while (!(p0 = p = Yap_AllocAtomSpace(strlen(s)+strlen(s2)+3))) { - if (!Yap_growheap(FALSE, MinHeapGap, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage); - return FALSE; - } - } - while ((*p++ = *s++) != '\0'); - p[-1] = '='; - while ((*p++ = *s2++) != '\0'); - if (putenv(p0) == 0) - return TRUE; -#if HAVE_STRERROR - Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, - "in putenv(%s)", strerror(errno), p0); -#else - Yap_Error(OPERATING_SYSTEM_ERROR, TermNil, - "in putenv(%s)", p0); -#endif - return FALSE; -#else - Yap_Error(SYSTEM_ERROR, TermNil, - "putenv not available in this configuration"); - return FALSE; -#endif -} - -/* wrapper for alarm system call */ -#if _MSC_VER || defined(__MINGW32__) - -static DWORD WINAPI -DoTimerThread(LPVOID targ) -{ - Int *time = (Int *)targ; - HANDLE htimer; - LARGE_INTEGER liDueTime; - - htimer = CreateWaitableTimer(NULL, FALSE, NULL); - liDueTime.QuadPart = -10000000; - liDueTime.QuadPart *= time[0]; - /* add time in usecs */ - liDueTime.QuadPart -= time[1]*10; - /* Copy the relative time into a LARGE_INTEGER. */ - if (SetWaitableTimer(htimer, &liDueTime,0,NULL,NULL,0) == 0) { - return(FALSE); - } - if (WaitForSingleObject(htimer, INFINITE) != WAIT_OBJECT_0) - fprintf(stderr,"WaitForSingleObject failed (%ld)\n", GetLastError()); - Yap_signal (YAP_WINTIMER_SIGNAL); - /* now, say what is going on */ - Yap_PutValue(AtomAlarm, MkAtomTerm(AtomTrue)); - ExitThread(1); -#if _MSC_VER - return(0L); -#endif -} - -#endif - -static Int -p_alarm( USES_REGS1 ) -{ - Term t = Deref(ARG1); - Term t2 = Deref(ARG2); - Int i1, i2; - if (IsVarTerm(t)) { - Yap_Error(INSTANTIATION_ERROR, t, "alarm/2"); - return(FALSE); - } - if (!IsIntegerTerm(t)) { - Yap_Error(TYPE_ERROR_INTEGER, t, "alarm/2"); - return(FALSE); - } - if (IsVarTerm(t2)) { - Yap_Error(INSTANTIATION_ERROR, t2, "alarm/2"); - return(FALSE); - } - if (!IsIntegerTerm(t2)) { - Yap_Error(TYPE_ERROR_INTEGER, t2, "alarm/2"); - return(FALSE); - } - i1 = IntegerOfTerm(t); - i2 = IntegerOfTerm(t2); - if (i1 == 0 && i2 == 0) { -#if _WIN32 - Yap_get_signal( YAP_WINTIMER_SIGNAL ); -#else - Yap_get_signal( YAP_ALARM_SIGNAL ); -#endif - } -#if _MSC_VER || defined(__MINGW32__) - { - Term tout; - Int time[2]; - - time[0] = i1; - time[1] = i2; - - if (time[0] != 0 && time[1] != 0) { - DWORD dwThreadId; - HANDLE hThread; - - hThread = CreateThread( - NULL, /* no security attributes */ - 0, /* use default stack size */ - DoTimerThread, /* thread function */ - (LPVOID)time, /* argument to thread function */ - 0, /* use default creation flags */ - &dwThreadId); /* returns the thread identifier */ - - /* Check the return value for success. */ - if (hThread == NULL) { - Yap_WinError("trying to use alarm"); - } - } - tout = MkIntegerTerm(0); - return Yap_unify(ARG3,tout) && Yap_unify(ARG4,MkIntTerm(0)); - } -#elif HAVE_SETITIMER && !SUPPORT_CONDOR - { - struct itimerval new, old; - - new.it_interval.tv_sec = 0; - new.it_interval.tv_usec = 0; - new.it_value.tv_sec = i1; - new.it_value.tv_usec = i2; - if (setitimer(ITIMER_REAL, &new, &old) < 0) { -#if HAVE_STRERROR - Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer: %s", strerror(errno)); -#else - Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer %d", errno); -#endif - return FALSE; - } - return Yap_unify(ARG3,MkIntegerTerm(old.it_value.tv_sec)) && - Yap_unify(ARG4,MkIntegerTerm(old.it_value.tv_usec)); - } -#elif HAVE_ALARM && !SUPPORT_CONDOR - { - Int left; - Term tout; - - left = alarm(i1); - tout = MkIntegerTerm(left); - return Yap_unify(ARG3,tout) && Yap_unify(ARG4,MkIntTerm(0)) ; - } -#else - /* not actually trying to set the alarm */ - if (IntegerOfTerm(t) == 0) - return TRUE; - Yap_Error(SYSTEM_ERROR, TermNil, - "alarm not available in this configuration"); - return FALSE; -#endif -} - -static Int -p_virtual_alarm( USES_REGS1 ) -{ - Term t = Deref(ARG1); - Term t2 = Deref(ARG2); - if (IsVarTerm(t)) { - Yap_Error(INSTANTIATION_ERROR, t, "alarm/2"); - return(FALSE); - } - if (!IsIntegerTerm(t)) { - Yap_Error(TYPE_ERROR_INTEGER, t, "alarm/2"); - return(FALSE); - } - if (IsVarTerm(t2)) { - Yap_Error(INSTANTIATION_ERROR, t2, "alarm/2"); - return(FALSE); - } - if (!IsIntegerTerm(t2)) { - Yap_Error(TYPE_ERROR_INTEGER, t2, "alarm/2"); - return(FALSE); - } -#if _MSC_VER || defined(__MINGW32__) - { - Term tout; - Int time[2]; - - time[0] = IntegerOfTerm(t); - time[1] = IntegerOfTerm(t2); - - if (time[0] != 0 && time[1] != 0) { - DWORD dwThreadId; - HANDLE hThread; - - hThread = CreateThread( - NULL, /* no security attributes */ - 0, /* use default stack size */ - DoTimerThread, /* thread function */ - (LPVOID)time, /* argument to thread function */ - 0, /* use default creation flags */ - &dwThreadId); /* returns the thread identifier */ - - /* Check the return value for success. */ - if (hThread == NULL) { - Yap_WinError("trying to use alarm"); - } - } - tout = MkIntegerTerm(0); - return Yap_unify(ARG3,tout) && Yap_unify(ARG4,MkIntTerm(0)); - } -#elif HAVE_SETITIMER && !SUPPORT_CONDOR - { - struct itimerval new, old; - - new.it_interval.tv_sec = 0; - new.it_interval.tv_usec = 0; - new.it_value.tv_sec = IntegerOfTerm(t); - new.it_value.tv_usec = IntegerOfTerm(t2); - if (setitimer(ITIMER_VIRTUAL, &new, &old) < 0) { -#if HAVE_STRERROR - Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer: %s", strerror(errno)); -#else - Yap_Error(OPERATING_SYSTEM_ERROR, ARG1, "setitimer %d", errno); -#endif - return FALSE; - } - return Yap_unify(ARG3,MkIntegerTerm(old.it_value.tv_sec)) && - Yap_unify(ARG4,MkIntegerTerm(old.it_value.tv_usec)); - } -#else - /* not actually trying to set the alarm */ - if (IntegerOfTerm(t) == 0) - return TRUE; - Yap_Error(SYSTEM_ERROR, TermNil, - "virtual_alarm not available in this configuration"); - return FALSE; -#endif -} - -#if HAVE_FPU_CONTROL_H -#include -#endif - -/* by default Linux with glibc is IEEE compliant anyway..., but we will pretend it is not. */ -static bool -set_fpu_exceptions(bool flag) -{ - if (flag) { -#if HAVE_FESETEXCEPTFLAG - fexcept_t excepts; - return fesetexceptflag(&excepts, FE_DIVBYZERO| FE_UNDERFLOW|FE_OVERFLOW) == 0; -#elif HAVE_FEENABLEEXCEPT - /* I shall ignore de-normalization and precision errors */ - feenableexcept(FE_DIVBYZERO| FE_INVALID|FE_OVERFLOW); -#elif _WIN32 - // Enable zero-divide, overflow and underflow exception - _controlfp_s(0, ~(_EM_ZERODIVIDE|_EM_UNDERFLOW|_EM_OVERFLOW), _MCW_EM); // Line B -#elif defined(__hpux) -# if HAVE_FESETTRAPENABLE -/* From HP-UX 11.0 onwards: */ - fesettrapenable(FE_INVALID|FE_DIVBYZERO|FE_OVERFLOW|FE_UNDERFLOW); -# else -/* - Up until HP-UX 10.20: - FP_X_INV invalid operation exceptions - FP_X_DZ divide-by-zero exception - FP_X_OFL overflow exception - FP_X_UFL underflow exception - FP_X_IMP imprecise (inexact result) - FP_X_CLEAR simply zero to clear all flags -*/ - fpsetmask(FP_X_INV|FP_X_DZ|FP_X_OFL|FP_X_UFL); -# endif -#endif /* __hpux */ -#if HAVE_FPU_CONTROL_H && i386 && defined(__GNUC__) - /* I shall ignore denormalization and precision errors */ - int v = _FPU_IEEE & ~(_FPU_MASK_IM|_FPU_MASK_ZM|_FPU_MASK_OM|_FPU_MASK_UM); - _FPU_SETCW(v); -#endif -#if HAVE_FETESTEXCEPT - feclearexcept(FE_ALL_EXCEPT); -#endif -#ifdef HAVE_SIGFPE - my_signal (SIGFPE, HandleMatherr); -#endif - } else { - /* do IEEE arithmetic in the way the big boys do */ -#if HAVE_FESETEXCEPTFLAG - fexcept_t excepts; - return fesetexceptflag(&excepts, 0) == 0; -#elif HAVE_FEENABLEEXCEPT - /* I shall ignore de-normalization and precision errors */ - feenableexcept(0); -#elif _WIN32 - // Enable zero-divide, overflow and underflow exception - _controlfp_s(0, (_EM_ZERODIVIDE|_EM_UNDERFLOW|_EM_OVERFLOW), _MCW_EM); // Line B -#elif defined(__hpux) -# if HAVE_FESETTRAPENABLE - fesettrapenable(FE_ALL_EXCEPT); -# else - fpsetmask(FP_X_CLEAR); -# endif -#endif /* __hpux */ -#if HAVE_FPU_CONTROL_H && i386 && defined(__GNUC__) - /* this will probably not work in older releases of Linux */ - int v = _FPU_IEEE; - _FPU_SETCW(v); -#endif -#ifdef HAVE_SIGFPE - my_signal (SIGFPE, SIG_IGN); -#endif - } - return true; -} - -bool -Yap_set_fpu_exceptions(bool flag) -{ - return set_fpu_exceptions(flag); -} - -static Int -p_set_fpu_exceptions( USES_REGS1 ) { - if (Deref(ARG1) == MkAtomTerm(AtomTrue)) { - return set_fpu_exceptions(true); - } else { - return set_fpu_exceptions( false ); - } -} - -static Int -p_host_type( USES_REGS1 ) { - Term out = MkAtomTerm(Yap_LookupAtom(HOST_ALIAS)); - return(Yap_unify(out,ARG1)); -} - -static Int -p_yap_home( USES_REGS1 ) { - Term out = MkAtomTerm(Yap_LookupAtom(YAP_ROOTDIR)); - return(Yap_unify(out,ARG1)); -} - -static Int -p_yap_paths( USES_REGS1 ) { - Term out1, out2, out3; - const char *env_destdir = getenv("DESTDIR"); - char destdir[YAP_FILENAME_MAX+1]; - - if (env_destdir) { - strncat(destdir, env_destdir, YAP_FILENAME_MAX ); - strncat(destdir, "/" YAP_LIBDIR, YAP_FILENAME_MAX ); - out1 = MkAtomTerm(Yap_LookupAtom(destdir)); - } else { - out1 = MkAtomTerm(Yap_LookupAtom(YAP_LIBDIR)); - } - if (env_destdir) { - strncat(destdir, env_destdir, YAP_FILENAME_MAX ); - strncat(destdir, "/" YAP_SHAREDIR, YAP_FILENAME_MAX ); - out2 = MkAtomTerm(Yap_LookupAtom(destdir)); - } else { - out2 = MkAtomTerm(Yap_LookupAtom(YAP_SHAREDIR)); - } - if (env_destdir) { - strncat(destdir, env_destdir, YAP_FILENAME_MAX ); - strncat(destdir, "/" YAP_BINDIR, YAP_FILENAME_MAX ); - out3 = MkAtomTerm(Yap_LookupAtom(destdir)); - } else { - out3 = MkAtomTerm(Yap_LookupAtom(YAP_BINDIR)); - } - return(Yap_unify(out1,ARG1) && - Yap_unify(out2,ARG2) && - Yap_unify(out3,ARG3)); -} - -static Int -p_log_event( USES_REGS1 ) { - Term in = Deref(ARG1); - Atom at; - - if (IsVarTerm(in)) - return FALSE; - if (!IsAtomTerm(in)) - return FALSE; - at = AtomOfTerm( in ); -#if DEBUG - if (IsWideAtom(at) ) - fprintf(stderr, "LOG %S\n", RepAtom(at)->WStrOfAE); - else if (IsBlob(at)) - return FALSE; - else - fprintf(stderr, "LOG %s\n", RepAtom(at)->StrOfAE); -#endif - if (IsWideAtom(at) || IsBlob(at)) - return FALSE; - LOG( " %s ",RepAtom(at)->StrOfAE); - return TRUE; - -} - - -static Int -p_env_separator( USES_REGS1 ) { -#if defined(_WIN32) - return Yap_unify(MkIntegerTerm(';'),ARG1); -#else - return Yap_unify(MkIntegerTerm(':'),ARG1); -#endif -} - -/* - * This is responsable for the initialization of all machine dependant - * predicates - */ -void -Yap_InitSysbits (void) -{ -#if __simplescalar__ - { - char *pwd = getenv("PWD"); - strncpy(GLOBAL_pwd,pwd,YAP_FILENAME_MAX); - } -#endif - InitWTime (); - InitRandom (); - /* let the caller control signals as it sees fit */ - InitSignals (); -} - -void -Yap_InitTime( int wid ) -{ - InitTime( wid ); -} - -void -Yap_ReInitWallTime (void) -{ - InitWTime(); - if (Yap_heap_regs->last_wtime != NULL) - Yap_FreeCodeSpace(Yap_heap_regs->last_wtime); - InitLastWtime(); -} - -static Int -p_unix( USES_REGS1 ) -{ -#ifdef unix - return TRUE; -#else -#ifdef __unix__ - return TRUE; -#else -#ifdef __APPLE__ - return TRUE; -#else - return FALSE; -#endif -#endif -#endif -} - -static Int -p_win32( USES_REGS1 ) -{ -#ifdef _WIN32 - return TRUE; -#else -#ifdef __CYGWIN__ - return TRUE; -#else - return FALSE; -#endif -#endif -} - - -static Int -p_enable_interrupts( USES_REGS1 ) -{ - LOCAL_InterruptsDisabled--; - if (LOCAL_Signals && !LOCAL_InterruptsDisabled) { - CreepFlag = Unsigned(LCL0); - if ( !Yap_only_has_signal( YAP_CREEP_SIGNAL ) ) - EventFlag = Unsigned( LCL0 ); - } - return TRUE; -} - -static Int -p_disable_interrupts( USES_REGS1 ) -{ - LOCAL_InterruptsDisabled++; - CalculateStackGap( PASS_REGS1 ); - return TRUE; -} - -static Int -p_ld_path( USES_REGS1 ) -{ - return Yap_unify(ARG1,MkAtomTerm(Yap_LookupAtom(YAP_LIBDIR))); -} - -static Int -p_address_bits( USES_REGS1 ) -{ -#if SIZEOF_INT_P==4 - return Yap_unify(ARG1,MkIntTerm(32)); -#else - return Yap_unify(ARG1,MkIntTerm(64)); -#endif -} - - - -#ifdef _WIN32 - -/* This code is from SWI-Prolog by Jan Wielemaker */ - -#define wstreq(s,q) (wcscmp((s), (q)) == 0) - -static HKEY -reg_open_key(const wchar_t *which, int create) -{ HKEY key = HKEY_CURRENT_USER; - DWORD disp; - LONG rval; - - while(*which) - { wchar_t buf[256]; - wchar_t *s; - HKEY tmp; - - for(s=buf; *which && !(*which == '/' || *which == '\\'); ) - *s++ = *which++; - *s = '\0'; - if ( *which ) - which++; - - if ( wstreq(buf, L"HKEY_CLASSES_ROOT") ) - { key = HKEY_CLASSES_ROOT; - continue; - } else if ( wstreq(buf, L"HKEY_CURRENT_USER") ) - { key = HKEY_CURRENT_USER; - continue; - } else if ( wstreq(buf, L"HKEY_LOCAL_MACHINE") ) - { key = HKEY_LOCAL_MACHINE; - continue; - } else if ( wstreq(buf, L"HKEY_USERS") ) - { key = HKEY_USERS; - continue; - } - - if ( RegOpenKeyExW(key, buf, 0L, KEY_READ, &tmp) == ERROR_SUCCESS ) - { RegCloseKey(key); - key = tmp; - continue; - } - - if ( !create ) - return NULL; - - rval = RegCreateKeyExW(key, buf, 0, L"", 0, - KEY_ALL_ACCESS, NULL, &tmp, &disp); - RegCloseKey(key); - if ( rval == ERROR_SUCCESS ) - key = tmp; - else - return NULL; - } - - return key; -} - -#define MAXREGSTRLEN 1024 - -static void -recover_space(wchar_t *k, Atom At) -{ - if (At->WStrOfAE != k) - Yap_FreeCodeSpace((char *)k); -} - -static wchar_t * -WideStringFromAtom(Atom KeyAt USES_REGS) -{ - if (IsWideAtom(KeyAt)) { - return KeyAt->WStrOfAE; - } else { - int len = strlen(KeyAt->StrOfAE); - int sz = sizeof(wchar_t)*(len+1); - char *chp = KeyAt->StrOfAE; - wchar_t *kptr, *k; - - k = (wchar_t *)Yap_AllocCodeSpace(sz); - while (k == NULL) { - if (!Yap_growheap(FALSE, sz, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, MkIntegerTerm(sz), "generating key in win_registry_get_value/3"); - return FALSE; - } - } - kptr = k; - while ((*kptr++ = *chp++)); - return k; - } -} - -static Int -p_win_registry_get_value( USES_REGS1 ) -{ - DWORD type; - BYTE data[MAXREGSTRLEN]; - DWORD len = sizeof(data); - wchar_t *k, *name; - HKEY key; - Term Key = Deref(ARG1); - Term Name = Deref(ARG2); - Atom KeyAt, NameAt; - - if (IsVarTerm(Key)) { - Yap_Error(INSTANTIATION_ERROR,Key,"argument to win_registry_get_value unbound"); - return FALSE; - } - if (!IsAtomTerm(Key)) { - Yap_Error(TYPE_ERROR_ATOM,Key,"argument to win_registry_get_value"); - return FALSE; - } - KeyAt = AtomOfTerm(Key); - if (IsVarTerm(Name)) { - Yap_Error(INSTANTIATION_ERROR,Key,"argument to win_registry_get_value unbound"); - return FALSE; - } - if (!IsAtomTerm(Name)) { - Yap_Error(TYPE_ERROR_ATOM,Key,"argument to win_registry_get_value"); - return FALSE; - } - NameAt = AtomOfTerm(Name); - - k = WideStringFromAtom(KeyAt PASS_REGS); - if ( !(key=reg_open_key(k, FALSE)) ) { - Yap_Error(EXISTENCE_ERROR_KEY, Key, "argument to win_registry_get_value"); - recover_space(k, KeyAt); - return FALSE; - } - name = WideStringFromAtom(NameAt PASS_REGS); - - if ( RegQueryValueExW(key, name, NULL, &type, data, &len) == ERROR_SUCCESS ) { - RegCloseKey(key); - switch(type) { - case REG_SZ: - recover_space(k, KeyAt); - recover_space(name, NameAt); - ((wchar_t *)data)[len] = '\0'; - return Yap_unify(MkAtomTerm(Yap_LookupMaybeWideAtom((wchar_t *)data)),ARG3); - case REG_DWORD: - recover_space(k, KeyAt); - recover_space(name, NameAt); - { - DWORD *d = (DWORD *)data; - return Yap_unify(MkIntegerTerm((Int)d[0]),ARG3); - } - default: - recover_space(k, KeyAt); - recover_space(name, NameAt); - return FALSE; - } - } - recover_space(k, KeyAt); - recover_space(name, NameAt); - return FALSE; -} - -char * -Yap_RegistryGetString(char *name) -{ - DWORD type; - BYTE data[MAXREGSTRLEN]; - DWORD len = sizeof(data); - HKEY key; - char *ptr; - int i; - -#if SIZEOF_INT_P == 8 - if ( !(key=reg_open_key(L"HKEY_LOCAL_MACHINE/SOFTWARE/YAP/Prolog64", FALSE)) ) { - return NULL; - } -#else - if ( !(key=reg_open_key(L"HKEY_LOCAL_MACHINE/SOFTWARE/YAP/Prolog", FALSE)) ) { - return NULL; - } -#endif - if ( RegQueryValueEx(key, name, NULL, &type, data, &len) == ERROR_SUCCESS ) { - RegCloseKey(key); - switch(type) { - case REG_SZ: - ptr = malloc(len+2); - if (!ptr) - return NULL; - for (i=0; i<= len; i++) - ptr[i] = data[i]; - ptr[len+1] = '\0'; - return ptr; - default: - return NULL; - } - } - return NULL; -} - - -#endif - -void -Yap_InitSysPreds(void) -{ - CACHE_REGS - Term cm = CurrentModule; - - /* can only do after heap is initialised */ - InitLastWtime(); - Yap_InitCPred ("srandom", 1, p_srandom, SafePredFlag); -#if HAVE_RANDOM - Yap_InitCPred ("init_random_state", 3, p_init_random_state, SafePredFlag); - Yap_InitCPred ("set_random_state", 2, p_set_random_state, SafePredFlag); - Yap_InitCPred ("release_random_state", 1, p_release_random_state, SafePredFlag); -#endif - Yap_InitCPred ("log_event", 1, p_log_event, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("sh", 0, p_sh, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("$shell", 1, p_shell, SafePredFlag|SyncPredFlag|UserCPredFlag); - Yap_InitCPred ("system", 1, p_system, SafePredFlag|SyncPredFlag|UserCPredFlag); - Yap_InitCPred ("rename", 2, p_mv, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("$yap_home", 1, p_yap_home, SafePredFlag); - Yap_InitCPred ("$yap_paths", 3, p_yap_paths, SafePredFlag); - Yap_InitCPred ("$dir_separator", 1, p_dir_sp, SafePredFlag); - Yap_InitCPred ("libraries_directories",2, p_libraries_path, 0); - Yap_InitCPred ("system_library", 1, p_library_dir, 0); - Yap_InitCPred ("commons_library", 1, p_commons_dir, 0); - Yap_InitCPred ("$alarm", 4, p_alarm, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("$getenv", 2, p_getenv, SafePredFlag); - Yap_InitCPred ("$putenv", 2, p_putenv, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("$set_fpu_exceptions",1, p_set_fpu_exceptions, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("$host_type", 1, p_host_type, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("$env_separator", 1, p_env_separator, SafePredFlag); - Yap_InitCPred ("$unix", 0, p_unix, SafePredFlag); - Yap_InitCPred ("$win32", 0, p_win32, SafePredFlag); - Yap_InitCPred ("$ld_path", 1, p_ld_path, SafePredFlag); - Yap_InitCPred ("$address_bits", 1, p_address_bits, SafePredFlag); - Yap_InitCPred ("$expand_file_name", 2, p_expand_file_name, SyncPredFlag); - Yap_InitCPred ("$fpe_error", 0, p_fpe_error, 0); -#ifdef _WIN32 - Yap_InitCPred ("win_registry_get_value", 3, p_win_registry_get_value,0); -#endif - CurrentModule = HACKS_MODULE; - Yap_InitCPred ("virtual_alarm", 4, p_virtual_alarm, SafePredFlag|SyncPredFlag); - Yap_InitCPred ("enable_interrupts", 0, p_enable_interrupts, SafePredFlag); - Yap_InitCPred ("disable_interrupts", 0, p_disable_interrupts, SafePredFlag); - CurrentModule = OPERATING_SYSTEM_MODULE; - Yap_InitCPred ("true_file_name", 2, p_true_file_name, SyncPredFlag); - Yap_InitCPred ("true_file_name", 3, p_true_file_name3, SyncPredFlag); - CurrentModule = cm; -} - - -#ifdef VAX - -/* avoid longjmp botch */ - -int vax_absmi_fp; - -typedef struct - { - int eh; - int flgs; - int ap; - int fp; - int pc; - int dummy1; - int dummy2; - int dummy3; - int oldfp; - int dummy4; - int dummy5; - int dummy6; - int oldpc; - } - - *VaxFramePtr; - - -VaxFixFrame (dummy) -{ - int maxframes = 100; - VaxFramePtr fp = (VaxFramePtr) (((int *) &dummy) - 6); - while (--maxframes) - { - fp = (VaxFramePtr) fp->fp; - if (fp->flgs == 0) - { - if (fp->oldfp >= ®S[6] && fp->oldfp < ®S[REG_SIZE]) - fp->oldfp = vax_absmi_fp; - return; - } - } -} - -#endif - - -#if defined(_WIN32) - -#include - -int WINAPI win_yap(HANDLE, DWORD, LPVOID); - -int WINAPI win_yap(HANDLE hinst, DWORD reason, LPVOID reserved) -{ - switch (reason) - { - case DLL_PROCESS_ATTACH: - break; - case DLL_PROCESS_DETACH: - break; - case DLL_THREAD_ATTACH: - break; - case DLL_THREAD_DETACH: - break; - } - return 1; -} -#endif - -#if (defined(YAPOR) || defined(THREADS)) && !defined(USE_PTHREAD_LOCKING) -#ifdef sparc -void rw_lock_voodoo(void); - -void -rw_lock_voodoo(void) { - /* code taken from the Linux kernel, it handles shifting between locks */ - /* Read/writer locks, as usual this is overly clever to make it as fast as possible. */ - /* caches... */ - __asm__ __volatile__( -"___rw_read_enter_spin_on_wlock:\n" -" orcc %g2, 0x0, %g0\n" -" be,a ___rw_read_enter\n" -" ldstub [%g1 + 3], %g2\n" -" b ___rw_read_enter_spin_on_wlock\n" -" ldub [%g1 + 3], %g2\n" -"___rw_read_exit_spin_on_wlock:\n" -" orcc %g2, 0x0, %g0\n" -" be,a ___rw_read_exit\n" -" ldstub [%g1 + 3], %g2\n" -" b ___rw_read_exit_spin_on_wlock\n" -" ldub [%g1 + 3], %g2\n" -"___rw_write_enter_spin_on_wlock:\n" -" orcc %g2, 0x0, %g0\n" -" be,a ___rw_write_enter\n" -" ldstub [%g1 + 3], %g2\n" -" b ___rw_write_enter_spin_on_wlock\n" -" ld [%g1], %g2\n" -"\n" -" .globl ___rw_read_enter\n" -"___rw_read_enter:\n" -" orcc %g2, 0x0, %g0\n" -" bne,a ___rw_read_enter_spin_on_wlock\n" -" ldub [%g1 + 3], %g2\n" -" ld [%g1], %g2\n" -" add %g2, 1, %g2\n" -" st %g2, [%g1]\n" -" retl\n" -" mov %g4, %o7\n" -" .globl ___rw_read_exit\n" -"___rw_read_exit:\n" -" orcc %g2, 0x0, %g0\n" -" bne,a ___rw_read_exit_spin_on_wlock\n" -" ldub [%g1 + 3], %g2\n" -" ld [%g1], %g2\n" -" sub %g2, 0x1ff, %g2\n" -" st %g2, [%g1]\n" -" retl\n" -" mov %g4, %o7\n" -" .globl ___rw_write_enter\n" -"___rw_write_enter:\n" -" orcc %g2, 0x0, %g0\n" -" bne ___rw_write_enter_spin_on_wlock\n" -" ld [%g1], %g2\n" -" andncc %g2, 0xff, %g0\n" -" bne,a ___rw_write_enter_spin_on_wlock\n" -" stb %g0, [%g1 + 3]\n" -" retl\n" -" mov %g4, %o7\n" - ); -} -#endif /* sparc */ - - -#endif /* YAPOR || THREADS */ - -//@ diff --git a/H/Yap.h b/H/Yap.h index f954b9b24..e8e909599 100755 --- a/H/Yap.h +++ b/H/Yap.h @@ -847,6 +847,26 @@ LOG0(const char *f, int l, const char *fmt, ...) #define REGS_LOG( ... ) #endif +// YAP lexicon + +/* Character types for tokenizer and write.c */ + +typedef enum char_kind_t { + BG = 0, /* initial state */ + UC = 1, /* Upper case */ + UL = 2, /* Underline */ + LC = 3, /* Lower case */ + NU = 4, /* digit */ + QT = 5, /* single quote */ + DC = 6, /* double quote */ + SY = 7, /* Symbol character */ + SL = 8, /* Solo character */ + BK = 9, /* Brackets & friends */ + BS = 10, /* Blank */ + EF = 11, /* End of File marker */ + CC = 12 /* comment,char % */ +} charkind_t; + #ifndef __ANDROID__ #define __android_log_print( ... ) #endif diff --git a/H/iatoms.h b/H/iatoms.h index 118b10771..8fb007219 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -500,7 +500,7 @@ FunctorStreamEOS = Yap_MkFunctor(AtomEndOfStream,1); FunctorStreamPos = Yap_MkFunctor(AtomStreamPos,4); FunctorString1 = Yap_MkFunctor(AtomString,1); - FunctorSyntaxError = Yap_MkFunctor(AtomSyntaxError,7); + FunctorSyntaxError = Yap_MkFunctor(AtomSyntaxError,5); FunctorShortSyntaxError = Yap_MkFunctor(AtomSyntaxError,1); FunctorTermExpansion = Yap_MkFunctor(AtomTermExpansion,2); FunctorThreadRun = Yap_MkFunctor(AtomTopThreadGoal,2); diff --git a/OPTYap/locks_pthread.h b/OPTYap/locks_pthread.h index 9229c0ab0..ba7b2002c 100755 --- a/OPTYap/locks_pthread.h +++ b/OPTYap/locks_pthread.h @@ -32,7 +32,7 @@ int Yap_ThreadID( void ); #define DESTROY_LOCK(LOCK_VAR) pthread_mutex_destroy(&(LOCK_VAR)) #define TRY_LOCK(LOCK_VAR) pthread_mutex_trylock(&(LOCK_VAR)) #if DEBUG_LOCKS -extern int debug_locks; +extern bool debug_locks; #define LOCK(LOCK_VAR) (void)(fprintf(debugf, "[%d] %s:%d: LOCK(%p)\n", Yap_ThreadID(),__BASE_FILE__, __LINE__,&(LOCK_VAR)) && pthread_mutex_lock(&(LOCK_VAR)) ) #define UNLOCK(LOCK_VAR) (void)(fprintf(debugf, "[%d] %s:%d: UNLOCK(%p)\n", Yap_ThreadID(),__BASE_FILE__, __LINE__,&(LOCK_VAR)) && pthread_mutex_unlock(&(LOCK_VAR)) ) @@ -41,21 +41,21 @@ extern int debug_locks; #define UNLOCK(LOCK_VAR) pthread_mutex_unlock(&(LOCK_VAR)) #endif -static inline int +static inline bool xIS_LOCKED(pthread_mutex_t *LOCK_VAR) { if (pthread_mutex_trylock(LOCK_VAR) == 0) { pthread_mutex_unlock(LOCK_VAR); - return TRUE; + return true; } - return FALSE; + return false; } -static inline int +static inline bool xIS_UNLOCKED(pthread_mutex_t *LOCK_VAR) { if (pthread_mutex_trylock(LOCK_VAR) == 0) { pthread_mutex_unlock(LOCK_VAR); - return FALSE; + return false; } - return TRUE; + return true; } #define IS_LOCKED(LOCK_VAR) xIS_LOCKED(&(LOCK_VAR)) @@ -65,7 +65,7 @@ xIS_UNLOCKED(pthread_mutex_t *LOCK_VAR) { #define INIT_RWLOCK(X) pthread_rwlock_init(&(X), NULL) #define DESTROY_RWLOCK(X) pthread_rwlock_destroy(&(X)) #if DEBUG_PE_LOCKS -extern int debug_pe_locks; +extern bool debug_pe_locks; #define READ_LOCK(X) ((debug_pe_locks ? \ fprintf(debugf, "[%d] %s:%d: RLOCK(%p)\n", \ diff --git a/include/YapError.h b/include/YapError.h index ade9963aa..bed48fef9 100644 --- a/include/YapError.h +++ b/include/YapError.h @@ -23,9 +23,7 @@ typedef enum FATAL_ERROR, INTERNAL_ERROR, INTERNAL_COMPILER_ERROR, -#if !YAP_JIT NOJIT_ERROR, /* I added */ -#endif PURE_ABORT, CALL_COUNTER_UNDERFLOW, /* ISO_ERRORS */ diff --git a/misc/ATOMS b/misc/ATOMS index 89e387a86..c498c2fd1 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -505,7 +505,7 @@ F Stream Stream 1 F StreamEOS EndOfStream 1 F StreamPos StreamPos 4 F String1 String 1 -F SyntaxError SyntaxError 7 +F SyntaxError SyntaxError 5 F ShortSyntaxError SyntaxError 1 F TermExpansion TermExpansion 2 F ThreadRun TopThreadGoal 2 diff --git a/os/charsio.c b/os/charsio.c index ce095b1c6..4b6a08b08 100644 --- a/os/charsio.c +++ b/os/charsio.c @@ -38,7 +38,7 @@ static char SccsId[] = "%W% %G%"; #if HAVE_IO_H /* Windows */ #include -#endif +#endif #if HAVE_SOCKET #include #endif @@ -60,12 +60,12 @@ static Int flush_all_streams( USES_REGS1); INLINE_ONLY inline EXTERN Term MkCharTerm (Int c); -/** +/** * MkCharTerm: convert a character into a single atom. - * + * * @param c the character code - * - * @return the term. + * + * @return the term. */ INLINE_ONLY inline EXTERN Term MkCharTerm (Int c) @@ -77,12 +77,12 @@ MkCharTerm (Int c) } -/** +/** * CharOfAtom: convert an atom into a single character. - * + * * @param at the atom - * - * @return the char . + * + * @return the char . */ INLINE_ONLY inline EXTERN Int CharOfAtom (Atom at) @@ -99,7 +99,7 @@ CharOfAtom (Atom at) static Int at_end_of_stream ( USES_REGS1 ) { /* at_end_of_stream */ - /* the next character is a EOF */ + /* the next character is a EOF */ int sno = Yap_CheckStream (ARG1, Input_Stream_f, "past_eof/1"); Int out; @@ -117,7 +117,7 @@ at_end_of_stream ( USES_REGS1 ) static Int at_end_of_stream_0 ( USES_REGS1 ) { /* at_end_of_stream */ - /* the next character is a EOF */ + /* the next character is a EOF */ int sno = LOCAL_c_input_stream; Int out; @@ -137,7 +137,7 @@ yap_fflush( sno) { Yap_ReadlineFlush( sno ); if ( (GLOBAL_Stream[sno].status & Output_Stream_f) && - ! (GLOBAL_Stream[sno].status & + ! (GLOBAL_Stream[sno].status & (Null_Stream_f| InMemory_Stream_f| Socket_Stream_f| @@ -295,7 +295,7 @@ get0_line_codes ( USES_REGS1 ) } out = read_line(sno); UNLOCK(GLOBAL_Stream[sno].streamlock); - if (rewind) + if (rewind) return Yap_unify(MkPairTerm(MkIntegerTerm(ch),out), ARG2); else return Yap_unify(out,ARG2); @@ -347,7 +347,7 @@ put_code_1 ( USES_REGS1 ) { /* '$put'(,N) */ int sno = LOCAL_c_output_stream, ch; Term t2; - + if (IsVarTerm(t2 = Deref(ARG1))) { Yap_Error(INSTANTIATION_ERROR, t2, "put_code/1"); return FALSE; @@ -367,7 +367,7 @@ put_code_1 ( USES_REGS1 ) GLOBAL_Stream[sno].stream_wputc (sno, (int) IntegerOfTerm (Deref (ARG2))); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -379,7 +379,7 @@ put_code ( USES_REGS1 ) int ch; Term t2; int sno; - + if (IsVarTerm(t2 = Deref(ARG2))) { Yap_Error(INSTANTIATION_ERROR, t2, "put_code/1"); return FALSE; @@ -398,11 +398,11 @@ put_code ( USES_REGS1 ) Yap_Error(PERMISSION_ERROR_OUTPUT_BINARY_STREAM, ARG1, "put/2"); return(FALSE); } - + GLOBAL_Stream[sno].stream_wputc (sno, ch); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -414,7 +414,7 @@ put_char_1 ( USES_REGS1 ) int sno = LOCAL_c_output_stream; Term t2; int ch; - + if (IsVarTerm(t2 = Deref(ARG1))) { Yap_Error(INSTANTIATION_ERROR, t2, "put_char/1"); return FALSE; @@ -434,7 +434,7 @@ put_char_1 ( USES_REGS1 ) GLOBAL_Stream[sno].stream_wputc (sno, ch); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -446,7 +446,7 @@ put_char ( USES_REGS1 ) Term t2; int ch; int sno; - + if (IsVarTerm(t2 = Deref(ARG1))) { Yap_Error(INSTANTIATION_ERROR, t2, "put_char/1"); return FALSE; @@ -468,7 +468,7 @@ put_char ( USES_REGS1 ) GLOBAL_Stream[sno].stream_wputc (sno, (int) IntegerOfTerm (Deref (ARG2))); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -490,7 +490,7 @@ tab_1 ( USES_REGS1 ) Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t2, "tab/1"); return FALSE; } - + LOCK(GLOBAL_Stream[sno].streamlock); if (GLOBAL_Stream[sno].status & Binary_Stream_f) { UNLOCK(GLOBAL_Stream[sno].streamlock); @@ -502,7 +502,7 @@ tab_1 ( USES_REGS1 ) GLOBAL_Stream[sno].stream_wputc (sno, ' '); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -527,7 +527,7 @@ tab ( USES_REGS1 ) sno = Yap_CheckStream (ARG1, Output_Stream_f, "nl/1"); if (sno < 0) return (FALSE); - + if (GLOBAL_Stream[sno].status & Binary_Stream_f) { UNLOCK(GLOBAL_Stream[sno].streamlock); Yap_Error(PERMISSION_ERROR_OUTPUT_BINARY_STREAM, ARG1, "nl/0"); @@ -538,7 +538,7 @@ tab ( USES_REGS1 ) GLOBAL_Stream[sno].stream_wputc (sno, ' '); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -557,7 +557,7 @@ nl_1 ( USES_REGS1 ) GLOBAL_Stream[sno].stream_wputc (sno, 10); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -577,7 +577,7 @@ nl ( USES_REGS1 ) GLOBAL_Stream[sno].stream_wputc (sno, 10); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -610,7 +610,7 @@ put_byte ( USES_REGS1 ) GLOBAL_Stream[sno].stream_putc(sno, ch); /* * if (!(GLOBAL_Stream[sno].status & Null_Stream_f)) - * yap_fflush(GLOBAL_Stream[sno].file); + * yap_fflush(GLOBAL_Stream[sno].file); */ UNLOCK(GLOBAL_Stream[sno].streamlock); return (TRUE); @@ -652,7 +652,7 @@ skip_1 ( USES_REGS1 ) Term t2; int sno; int ch; - + if (IsVarTerm(t2 = Deref(ARG1))) { Yap_Error(INSTANTIATION_ERROR, t2, "skip/2"); return FALSE; @@ -679,7 +679,7 @@ skip ( USES_REGS1 ) Term t2; int sno; int ch; - + if (IsVarTerm(t2 = Deref(ARG2))) { Yap_Error(INSTANTIATION_ERROR, t2, "skip/2"); return FALSE; @@ -698,14 +698,14 @@ skip ( USES_REGS1 ) return (TRUE); } -/** +/** * @pred flush_output(+Stream) * * Flush the stream _Stream_, that is, make sure all pending output is committed * before any further execution. - * - * @param +_Stream_ - * + * + * @param +_Stream_ + * */ static Int flush_output ( USES_REGS1 ) @@ -718,13 +718,13 @@ flush_output ( USES_REGS1 ) return (TRUE); } -/** +/** * @pred flush_output * * Flush the current output stream, that is, make sure all pending output is committed * before any further execution. By default this is user_output, but it may be * changed by current_output/1. - * + * */ static Int flush_output0 ( USES_REGS1 ) @@ -746,7 +746,7 @@ flush_all_streams ( USES_REGS1 ) #else fflush (NULL); #endif - + return TRUE; } @@ -755,7 +755,7 @@ static Int dopeek( int sno ) Int ocharcount, olinecount, olinepos; StreamDesc *s; Int ch; - + s = GLOBAL_Stream+sno; ocharcount = s->charcount; olinecount = s->linecount; @@ -784,7 +784,7 @@ static Int dopeek( int sno ) If _C_ is unbound, or is the code for a character, and the stream _S_ is a text stream, read the next character from the current stream and unify its code with _C_, while -leaving the current stream position unaltered. +leaving the current stream position unaltered. */ @@ -794,13 +794,13 @@ leaving the current stream position unaltered. If _C_ is unbound, or is the code for a character, and the stream _S_ is a text stream, read the next character from the current stream and unify its code with _C_, while -leaving the current stream position unaltered. +leaving the current stream position unaltered. */ static Int peek_code ( USES_REGS1 ) { /* at_end_of_stream */ - /* the next character is a EOF */ + /* the next character is a EOF */ int sno = Yap_CheckStream (ARG1, Input_Stream_f, "peek/2"); Int ch; @@ -824,13 +824,13 @@ peek_code ( USES_REGS1 ) If _C_ is unbound, or is the code for a character, and the current input stream is a text stream, read the next character from the current stream and unify its code with _C_, while -leaving the current stream position unaltered. +leaving the current stream position unaltered. */ static Int peek_code_1 ( USES_REGS1 ) { /* at_end_of_stream */ - /* the next character is a EOF */ + /* the next character is a EOF */ int sno = LOCAL_c_input_stream; Int ch; @@ -857,7 +857,7 @@ code with _C_, while leaving the current stream position unaltered. static Int peek_byte ( USES_REGS1 ) { /* at_end_of_stream */ - /* the next character is a EOF */ + /* the next character is a EOF */ int sno = Yap_CheckStream (ARG1, Input_Stream_f, "peek/2"); Int ch; @@ -885,7 +885,7 @@ code with _C_, while leaving the current stream position unaltered. static Int peek_byte_1 ( USES_REGS1 ) { /* at_end_of_stream */ - /* the next character is a EOF */ + /* the next character is a EOF */ int sno = LOCAL_c_input_stream; Int ch; @@ -915,8 +915,8 @@ atom with _C_, while leaving the stream position unaltered. */ static Int peek_char ( USES_REGS1 ) -{ - /* the next character is a EOF */ +{ + /* the next character is a EOF */ int sno = Yap_CheckStream (ARG1, Input_Stream_f, "peek/2"); wchar_t wsinp[2]; Int ch; @@ -947,12 +947,12 @@ atom with _C_, while leaving the stream position unaltered. */ static Int peek_char_1 ( USES_REGS1 ) -{ - /* the next character is a EOF */ +{ + /* the next character is a EOF */ int sno = LOCAL_c_input_stream; wchar_t wsinp[2]; Int ch; - + LOCK(GLOBAL_Stream[sno].streamlock); if ((ch = dopeek( sno )) < 0) { UNLOCK(GLOBAL_Stream[sno].streamlock); @@ -971,7 +971,7 @@ peek_char_1 ( USES_REGS1 ) If _C_ is unbound, or is the code for a character, and the stream _S_ is a text stream, read the next character from the current stream and unify its code with _C_, while -leaving the current stream position unaltered. +leaving the current stream position unaltered. Please use the ISO built-in peek_code/2. */ @@ -982,7 +982,7 @@ Please use the ISO built-in peek_code/2. If _C_ is unbound, or is the code for a character, and the currrent input stream is a text stream, read the next character from the current stream and unify its code with _C_, while -leaving the current stream position unaltered. +leaving the current stream position unaltered. */ @@ -1012,8 +1012,8 @@ Yap_InitCharsio( void ) Yap_InitCPred ("get_char", 1, getchar_1, SafePredFlag|SyncPredFlag); Yap_InitCPred ("get0", 1, getcode_1, SafePredFlag|SyncPredFlag); Yap_InitCPred ("$get0_line_codes", 2, get0_line_codes, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred ("get_byte", 2, get_byte, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred ("get_byte", 1, get_byte_1, SafePredFlag|SyncPredFlag|HiddenPredFlag); + Yap_InitCPred ("get_byte", 2, get_byte, SafePredFlag|SyncPredFlag); + Yap_InitCPred ("get_byte", 1, get_byte_1, SafePredFlag|SyncPredFlag); Yap_InitCPred ("put", 1, put_code_1, SafePredFlag|SyncPredFlag); Yap_InitCPred ("put", 2, put_code, SafePredFlag|SyncPredFlag); Yap_InitCPred ("put_code", 1, put_code_1, SafePredFlag|SyncPredFlag); @@ -1049,5 +1049,5 @@ Yap_InitCharsio( void ) Yap_InitCPred ("tab", 2, tab, SafePredFlag|SyncPredFlag); Yap_InitCPred ("tab1", 1, tab_1, SafePredFlag|SyncPredFlag); - + } diff --git a/os/format.c b/os/format.c index 286e8581d..6253cb8a2 100644 --- a/os/format.c +++ b/os/format.c @@ -658,7 +658,17 @@ doformat(volatile Term otail, volatile Term oargs, int sno USES_REGS) if (targ > tnum-1) goto do_consistency_error; t = targs[targ++]; - if (!format_print_str (sno, repeats, has_repeats, t, f_putc)) { + if (IsVarTerm(t)) + goto do_instantiation_error; + if (IsStringTerm(t)) { + if (has_repeats) + goto do_consistency_error; + yhandle_t sl = Yap_StartSlots(); + // stream is already locked. + Yap_plwrite (t, GLOBAL_Stream+sno, 0, Handle_vars_f|To_heap_f, 1200); + Yap_CloseSlots(sl); + LOCAL_FormatInfo = &finfo; + } else if (!format_print_str (sno, repeats, has_repeats, t, f_putc)) { goto do_default_error; } break; diff --git a/os/iopreds.h b/os/iopreds.h index 7edb79880..ed5c913c2 100644 --- a/os/iopreds.h +++ b/os/iopreds.h @@ -13,8 +13,12 @@ static char SccsId[] = "%W% %G%"; #ifndef IOPREDS_H #define IOPREDS_H 1 +#include +#include "Yap.h" +#include "Atoms.h" + /* - * This file defines main data-structure for stream management, + * This file defines main data-structure for stream management, * */ @@ -95,18 +99,18 @@ typedef struct read_data_t unsigned char *base; /* base of clause */ unsigned char *end; /* end of the clause */ unsigned char *token_start; /* start of most recent read token */ - + int magic; /* RD_MAGIC */ struct stream_desc *stream; FILE *f; /* file. of known */ Term position; /* Line, line pos, char and byte */ void *posp; /* position pointer */ size_t posi; /* position number */ - + Term subtpos; /* Report Subterm positions */ bool cycles; /* Re-establish cycles */ yapSourceLocation start_of_term; /* Position of start of term */ - ModEntry* module; /* Current source module */ + struct mod_entry* module; /* Current source module */ unsigned int flags; /* Module syntax flags */ int styleCheck; /* style-checking mask */ bool backquoted_string; /* Read `hello` as string */ @@ -119,7 +123,7 @@ typedef struct read_data_t Term exception; /* raised exception */ Term variables; /* report variables */ Term singles; /* Report singleton variables */ - Term varnames; /* Report variables+names */ + Term varnames; /* Report variables+names */ int strictness; /* Strictness level */ #ifdef O_QUASIQUOTATIONS @@ -327,7 +331,7 @@ INLINE_ONLY inline EXTERN void count_output_char(int ch, StreamDesc *s); Term Yap_StreamUserName(int sno); -INLINE_ONLY inline EXTERN void +INLINE_ONLY inline EXTERN void count_output_char(int ch, StreamDesc *s) { if (ch == '\n') diff --git a/os/readterm.c b/os/readterm.c index 788181a49..29a4e783b 100644 --- a/os/readterm.c +++ b/os/readterm.c @@ -230,25 +230,32 @@ static const param_t read_defs[] = * + */ Term -Yap_syntax_error (TokEntry * tokptr, int sno) +Yap_syntax_error (TokEntry * errtok, int sno) { CACHE_REGS - Term info; - Term out = MkIntTerm(0); + Term info; Term startline, errline, endline; - Term tf[7]; - Term *error = tf+3; + Term tf[5]; + Term *tailp = tf+4; CELL *Hi = HR; UInt count = 0; - - startline = MkIntegerTerm(tokptr->TokPos); + Term tcount = MkIntegerTerm(count); + TokEntry * tok = LOCAL_tokptr; + Int cline = tok->TokPos; + + *tailp = TermNil; + startline = MkIntegerTerm(cline); clean_vars(LOCAL_VarTable); clean_vars(LOCAL_AnonVarTable); - while (1) { + if (errtok != LOCAL_toktide) { + errtok = LOCAL_toktide; + } + errline = MkIntegerTerm( errtok->TokPos ); + while (tok) { Term ts[2]; if (HR > ASP-1024) { - tf[3] = TermNil; + tf[4] = TermNil; errline = MkIntegerTerm(0); endline = MkIntegerTerm( 0 ); count = 0; @@ -256,12 +263,16 @@ Yap_syntax_error (TokEntry * tokptr, int sno) HR = Hi; break; } - if (tokptr == LOCAL_toktide) { - errline = MkIntegerTerm( tokptr->TokPos ); - out = MkIntegerTerm(count); - } - info = tokptr->TokInfo; - switch (tokptr->Tok) { + if (tok->TokPos != cline) { + *tailp = MkPairTerm(MkAtomTerm(AtomNil),TermNil); + tailp = RepPair(*tailp)+1; + } + if (tok == errtok && tok->Tok != Error_tok) { + *tailp = MkPairTerm(MkAtomTerm(AtomError),TermNil); + tailp = RepPair(*tailp)+1; + } + info = tok->TokInfo; + switch (tok->Tok) { case Name_tok: { Term t0[1]; @@ -270,7 +281,7 @@ Yap_syntax_error (TokEntry * tokptr, int sno) } break; case Number_tok: - ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomNumber,1),1,&(tokptr->TokInfo)); + ts[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomNumber,1),1,&(tok->TokInfo)); break; case Var_tok: { @@ -312,10 +323,17 @@ Yap_syntax_error (TokEntry * tokptr, int sno) } break; case Error_tok: - case eot_tok: - break; + { + ts[0] = MkAtomTerm(AtomError); + } + break; + case eot_tok: + endline = MkIntegerTerm(tok->TokPos); + ts[0] = MkAtomTerm(AtomDot); + + break; case Ponctuation_tok: - { + { char s[2]; s[1] = '\0'; if ((info) == 'l') { @@ -325,21 +343,14 @@ Yap_syntax_error (TokEntry * tokptr, int sno) } ts[0] = MkAtomTerm(Yap_LookupAtom(s)); } - } - if (tokptr->Tok == Ord (eot_tok)) { - *error = TermNil; - endline = MkIntegerTerm(tokptr->TokPos); - break; - } else if (tokptr->Tok != Ord (Error_tok)) { - ts[1] = MkIntegerTerm(tokptr->TokPos); - *error = MkPairTerm(Yap_MkApplTerm(FunctorMinus,2,ts),TermNil); - error = RepPair(*error)+1; - count++; - } - tokptr = tokptr->TokNext; - } + } + tok = tok->TokNext; + if (!tok) + break; + *tailp = MkPairTerm(ts[0], TermNil); + tailp = RepPair(*tailp)+1; + } { - Term tcount = MkIntegerTerm(count); Term t[3]; tf[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomRead,1),1,&tcount); @@ -348,11 +359,17 @@ Yap_syntax_error (TokEntry * tokptr, int sno) t[2] = endline; tf[1] = Yap_MkApplTerm(Yap_MkFunctor(AtomBetween,3),3,t); } - tf[2] = tf[3] = TermDot; - tf[4] = MkIntegerTerm(count); - tf[5] = out; - tf[6] = Yap_StreamUserName(sno); - return(Yap_MkApplTerm(FunctorSyntaxError,7,tf)); + /* 0: id */ + /* 1: strat, error, end line */ + /*2 msg */ + if (LOCAL_ErrorMessage) + tf[2] = MkStringTerm(LOCAL_ErrorMessage); + else + tf[2] = MkStringTerm(""); + /* file */ + tf[3] = Yap_StreamUserName(sno); + /* tf[4] = ; */ + return(Yap_MkApplTerm(FunctorSyntaxError,5,tf)); } typedef struct FEnv { @@ -360,6 +377,7 @@ typedef struct FEnv { Term tpos; /// initial position of the term to be read. Term t; /// the output term TokEntry *tokstart; /// the token list + TokEntry *toklast; /// the last token CELL *old_H; /// initial H, will be reset on stack overflow. tr_fr_ptr old_TR; /// initial TR xarg *args; /// input args @@ -712,8 +730,6 @@ parseError(REnv *re, FEnv *fe, int inp_stream) { CACHE_REGS fe->t = 0; - TokEntry * tokstart = - LOCAL_tokptr; if (LOCAL_Error_TYPE == OUT_OF_TRAIL_ERROR || LOCAL_Error_TYPE == OUT_OF_AUXSPACE_ERROR || LOCAL_Error_TYPE == OUT_OF_HEAP_ERROR || @@ -725,7 +741,7 @@ parseError(REnv *re, FEnv *fe, int inp_stream) /* just fail */ return YAP_PARSING_FINISHED; } else { - Term terr = Yap_syntax_error(tokstart, inp_stream); + Term terr = Yap_syntax_error(fe->toklast, inp_stream); if (ParserErrorStyle ==TermError) { LOCAL_ErrorMessage = "SYNTAX ERROR"; Yap_Error(SYNTAX_ERROR,terr,LOCAL_ErrorMessage); @@ -747,6 +763,8 @@ parse(REnv *re, FEnv *fe, int inp_stream) LOCAL_tokptr; fe->t = Yap_Parse(re->prio); + fe->toklast = LOCAL_tokptr; + LOCAL_tokptr = tokstart; if (fe->t == 0 || LOCAL_ErrorMessage) return YAP_PARSING_ERROR; TR = (tr_fr_ptr)LOCAL_ScannerStack; @@ -760,7 +778,6 @@ parse(REnv *re, FEnv *fe, int inp_stream) first_char = tokstart->TokPos; #endif /* EMACS */ Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable); - LOCAL_tokptr = NULL; return YAP_PARSING_FINISHED; } @@ -775,7 +792,7 @@ parse(REnv *re, FEnv *fe, int inp_stream) * * @return the term or 0 in case of error. * - * Implemenfayubluses a state machine: default is init, scan, parse, complete. + * Implementation uses a state machine: default is init, scan, parse, complete. * * */ diff --git a/os/yapio.h b/os/yapio.h index 924649744..1e0a59e6f 100644 --- a/os/yapio.h +++ b/os/yapio.h @@ -31,21 +31,6 @@ #ifndef _PL_WRITE_ -/* Character types for tokenizer and write.c */ - -#define UC 1 /* Upper case */ -#define UL 2 /* Underline */ -#define LC 3 /* Lower case */ -#define NU 4 /* digit */ -#define QT 5 /* single quote */ -#define DC 6 /* double quote */ -#define SY 7 /* Symbol character */ -#define SL 8 /* Solo character */ -#define BK 9 /* Brackets & friends */ -#define BS 10 /* Blank */ -#define EF 11 /* End of File marker */ -#define CC 12 /* comment char % */ - #define EOFCHAR EOF #endif diff --git a/pl/boot.yap b/pl/boot.yap index 1f298c9e2..6ed339d48 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -237,8 +237,7 @@ private(_). '$cut_by'/1, '$disable_debugging'/0, '$do_live'/0, - '$ - '/0, + '$'/0, '$find_goal_definition'/4, '$handle_throw'/3, '$head_and_body'/3, diff --git a/pl/errors.yap b/pl/errors.yap index c06b11242..f203012e3 100644 --- a/pl/errors.yap +++ b/pl/errors.yap @@ -341,9 +341,9 @@ print_message(_, Term) :- '$print_system_message'(_, banner, _) :- current_prolog_flag(verbose, silent), !. '$print_system_message'(Term, Level, Lines) :- - ( Level == error -> Term \= error(syntax_error(_), _) ; Level == warning ), + ( Level == error -> true ; Level == warning ), '$messages':prefix(Level, LinePrefix, Stream, Lines2, Lines), - '$messages':file_location(LinesF, Lines2), !, + '$messages':file_location(Term, LinesF, Lines2), !, flush_output(user_output), flush_output(user_error), print_message_lines(Stream, LinePrefix, [nl|LinesF]). diff --git a/pl/init.yap b/pl/init.yap index 2f916e72e..7e4a8ce6a 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -240,7 +240,7 @@ yap_hacks:cut_by(CP) :- '$$cut_by'(CP). :- set_prolog_flag(generate_debug_info,true). -:- recorda('$dialect',yap,_). +grep:- recorda('$dialect',yap,_). % % cleanup ensure loaded and recover some data-base space. diff --git a/pl/messages.yap b/pl/messages.yap index a02dca06e..b33705867 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -67,14 +67,13 @@ handling in YAP: :- multifile user:generate_message_hook/3. -file_location --> - { source_location(FileName, LN) }, - file_position(FileName,LN). - -file_position(user_input,LN) --> - [ 'user_input:~d:0: ' - [LN] ]. -file_position(FileName,LN) --> - [ '~a:~d:0: ' - [FileName,LN] ]. +file_location(syntax_error(_,between(_,LN,_),_,FileName,_)) --> + [ '~a:~d:0: ' - [FileName,LN] ], + { source_location(FileName, LN) }. +file_location(_) --> + [ '~a:~d:0: ' - [FileName,LN] ], + { source_location(FileName, LN) }. + generate_message(Term, Lines, []) :- user:generate_message_hook(Term, [], Lines), !. @@ -121,7 +120,7 @@ generate_message(error(Error,Context)) --> system_message(error(Error,Context)), stack_dump(error(Error,Context)). generate_message(M) --> - file_location, + file_location(M), system_message(M), stack_dump(M). @@ -133,10 +132,10 @@ stack_dump(error(_,_)) --> '$hacks':display_stack_info(CPs, Envs, 20, CP). stack_dump(_) --> []. -prolog_message(X,Y,Z) :- - system_message(X,Y,Z). +prolog_message(X) --> + system_message(X). - %message(loaded(Past,AbsoluteFileName,user,Msec,Bytes), Prefix, Suffix) :- !, +%message(loaded(Past,AbsoluteFileName,user,Msec,Bytes), Prefix, Suffix) :- !, system_message(query(_QueryResult,_)) --> []. system_message(format(Msg, Args)) --> [Msg - Args]. @@ -212,6 +211,11 @@ system_message(myddas_version(Version)) --> [ 'MYDDAS version ~a' - [Version] ]. system_message(yes) --> [ 'yes' ]. +system_message( syntax_error(read(_R),between(L0,LM,LF),Msg,_,Term) ) --> + !, + ['SYNTAX ERROR: ~s' - [Msg]], + [nl], + syntax_error_term( between(L0,LM,LF), Term ). system_message(error(Msg,Info)) --> ( { var(Msg) } ; { var(Info)} ), !, ['bad error ~w' - [error(Msg,Info)]]. @@ -346,34 +350,9 @@ system_message(error(resource_error(trail), Where)) --> [ 'RESOURCE ERROR- not enough trail space' - [Where] ]. system_message(error(signal(SIG,_), _)) --> [ 'UNEXPECTED SIGNAL: ~a' - [SIG] ]. -system_message(error(syntax_error(_), [syntax_error(G,_,Msg,[],_,0,File)|_])) --> - [ 'SYNTAX ERROR at "~a", goal ~q: ~a' - [File,G,Msg] ]. % SWI like I/O error message. system_message(error(syntax_error(end_of_clause), [stream(Stream, Line, _, _)|_])) --> [ 'SYNTAX ERROR ~a, stream ~w, near line ~d.' - ['Unexpected end of clause',Stream,Line] ]. -system_message(error(syntax_error(read(_R),between(_L0,_LM,_LF),_Dot,Term,Pos,Start,File))) --> - { Term = [_|_] }, - ['SYNTAX ERROR' - []], - syntax_error_line(File, Start, Pos), - syntax_error_term(10, Pos, Term), - [ '.' ]. -system_message(error(system_error, Where)) --> - [ 'SYSTEM ERROR- ~w' - [Where] ]. -system_message(error(internal_compiler_error, Where)) --> - [ 'INTERNAL COMPILER ERROR- ~w' - [Where] ]. -system_message(error(system_error(Message), Where)) --> - [ 'SYSTEM ERROR- ~w at ~w]' - [Message,Where] ]. -system_message(error(timeout_error(T,Obj), _Where)) --> - [ 'TIMEOUT ERROR- operation ~w on object ~w' - [T,Obj] ]. -system_message(error(type_error(T,_,Err,M), _Where)) --> - [ 'TYPE ERROR- ~w: expected ~w, got ~w' - [T,Err,M] ]. -system_message(error(type_error(TE,W), Where)) --> - { object_name(TE, M) }, !, - [ 'TYPE ERROR- ~w: expected ~a, got ~w' - [Where,M,W] ]. -system_message(error(type_error(TE,W), Where)) --> - [ 'TYPE ERROR- ~w: expected ~q, got ~w' - [Where,TE,W] ]. -system_message(error(unknown, Where)) --> - [ 'EXISTENCE ERROR- procedure ~w undefined' - [Where] ]. system_message(error(unhandled_exception,Throw)) --> [ 'UNHANDLED EXCEPTION - message ~w unknown' - [Throw] ]. system_message(error(uninstantiation_error(TE), _Where)) --> @@ -500,43 +479,46 @@ list_of_preds([P|L]) --> ['~q' - [P]], list_of_preds(L). +syntax_error_term(between(I,I,I),L) --> + !, + syntax_error_tokens(L). +syntax_error_term(between(I,_J,L),LTaL) --> + [' term from line ~d to line ~d' - [I,L] ], + syntax_error_tokens(LTaL). -syntax_error_line('', _,_) --> !, - [':~n' ]. -syntax_error_line(File, Position,_) --> - [' at ~a, near line ~d:~n' - [File,Position]]. - -syntax_error_term(0,J,L) --> - ['~n' ], - syntax_error_term(10,J,L). -syntax_error_term(_,0,L) --> !, - [ '~n<==== HERE ====>~n' ], - syntax_error_term(10,-1,L). -syntax_error_term(_,_,[]) --> !. -syntax_error_term(I,J,[T-_P|R]) --> +syntax_error_tokens([]) --> []. +syntax_error_tokens([T|L]) --> syntax_error_token(T), - { - I1 is I-1, - J1 is J-1 - }, - syntax_error_term(I1,J1,R). + syntax_error_tokens(L). syntax_error_token(atom(A)) --> !, - [ ' ~a' - [A] ]. + [ '~a' - [A] ]. syntax_error_token(number(N)) --> !, - [ ' ~w' - [N] ]. + [ '~w' - [N] ]. syntax_error_token(var(_,S,_)) --> !, - [ ' ~s' - [S] ]. + [ '~s' - [S] ]. syntax_error_token(string(S)) --> !, - [ ' ""~s"' - [S] ]. + [ '\"~s\"' - [S] ]. +syntax_error_token(error) --> !, + [ '~n<==== HERE ====>~n' ]. +syntax_error_token('[]') --> !, + [ nl ]. syntax_error_token('(') --> !, [ '(' ]. +syntax_error_token('(') --> !, + [ '{' ]. +syntax_error_token('(') --> !, + [ '[' ]. syntax_error_token(')') --> !, [ ' )' ]. +syntax_error_token(')') --> !, + [ ']' ]. +syntax_error_token(')') --> !, + [ '}' ]. syntax_error_token(',') --> !, - [ ' ,' ]. + [ ',' ]. syntax_error_token(A) --> !, - [ ' ~a' - [A] ]. + [ '~a' - [A] ]. % print_message_lines(+Stream, +Prefix, +Lines) @@ -571,7 +553,7 @@ the _Prefix_ is printed too. */ prolog:print_message_lines(_S, _, []) :- !. -prolog:print_message_lines(_S, P, [at_same_line|Lines]) :- !, +prolog:print_message_lines(S, P, [at_same_line|Lines]) :- !, '$messages':print_message_line(S, Lines, Rest), prolog:print_message_lines(S, P, Rest). prolog:print_message_lines(S, kind(Kind), Lines) :- !,