diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' of /yap-6.3

Browse Source 
Conflicts:
	C/c_interface.c
This commit is contained in:
Vitor Santos Costa
2011-02-03 11:33:50 +00:00
parent 48b891a5b2 a4a1feeacc
commit c1721df472
12 changed files with 2922 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
C/c_interface.c
View File

@@ -3253,7 +3253,6 @@ YAP_signal(int sig)
Yap_signal(sig);
}
X_API int
YAP_SetYAPFlag(yap_flag_t flag, int val)
{

30
Makefile.in
View File

@@ -236,6 +236,12 @@ C_SOURCES= \
$(srcdir)/MYDDAS/myddas_top_level.c \
$(srcdir)/MYDDAS/myddas_wkb2prolog.c
PLCONS_SOURCES = \
$(srcdir)/console/LGPL/pl-nt.c \
$(srcdir)/console/LGPL/pl-ntcon.c \
$(srcdir)/console/LGPL/pl-ntconsole.c \
$(srcdir)/console/LGPL/pl-ntmain.c
PL_SOURCES= \
$(srcdir)/pl/arith.yap \
$(srcdir)/pl/arrays.yap \
@@ -318,7 +324,11 @@ LIB_OBJECTS = $(ENGINE_OBJECTS) $(C_INTERFACE_OBJECTS) $(OR_OBJECTS) $(BEAM_OBJE
OBJECTS = yap.o $(LIB_OBJECTS)
PLCONS_OBJECTS = \
pl-nt.o \
pl-ntcon.o \
pl-ntconsole.o \
pl-ntmain.o
all: parms.h startup.yss
@@ -483,6 +493,18 @@ regfree.o: $(srcdir)/library/regex/regfree.c $(srcdir)/library/regex/regex2.h co
regexec.o: $(srcdir)/library/regex/regexec.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir)/include -I$(srcdir)/library/regex $(srcdir)/library/regex/regexec.c -o regexec.o
pl-nt.o: $(srcdir)/console/LGPL/pl-nt.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir)/include -I$(srcdir)/packages/PLStream $(srcdir)/console/LGPL/pl-nt.c -o $@
pl-ntcon.o: $(srcdir)/console/LGPL/pl-ntcon.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir)/include $(srcdir)/console/LGPL/pl-ntcon.c -o $@
pl-ntconsole.o: $(srcdir)/console/LGPL/pl-ntconsole.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir) -I$(srcdir)/include -I$(srcdir)/packages/PLStream $(srcdir)/console/LGPL/pl-ntconsole.c -o $@
pl-ntmain.o: $(srcdir)/console/LGPL/pl-ntmain.c config.h
$(CC) -c $(CFLAGS) -I$(srcdir)/include -I$(srcdir) -I$(srcdir)/packages/PLStream $(srcdir)/console/LGPL/pl-ntmain.c -o $@
# default rule
%.o : $(srcdir)/C/%.c config.h
$(CC) -c $(CFLAGS) $< -o $@
@@ -511,6 +533,7 @@ all: startup.yss
@INSTALL_DLLS@ (cd library/random; $(MAKE))
@INSTALL_DLLS@ (cd library/regex; $(MAKE))
@INSTALL_DLLS@ (cd library/rltree; $(MAKE))
@ENABLE_WINCONSOLE@ (cd LGPL/swi_console; $(MAKE))
@INSTALL_DLLS@ (cd library/system; $(MAKE))
@INSTALL_DLLS@ (cd library/tries; $(MAKE))
@INSTALL_DLLS@ (cd packages/clib; $(MAKE))
@@ -534,6 +557,10 @@ startup.yss: yap@EXEC_SUFFIX@ $(PL_SOURCES)
yap@EXEC_SUFFIX@: $(HEADERS) yap.o @YAPLIB@
$(MPI_CC) $(EXECUTABLE_CFLAGS) $(LDFLAGS) -o yap yap.o @YAPLIB@ $(LIBS) @MPI_LIBS@
pl-yap@EXEC_SUFFIX@: $(PLCONS_OBJECTS) LGPL/swi_console/plterm.dll packages/PLSTream/libplstream.dll
(cd LGPL/swi_console; $(MAKE))
$(MPI_CC) $(EXECUTABLE_CFLAGS) $(LDFLAGS) -o pl-yap $(PLCONS_OBJECTS) LGPL/swi_console/plterm.dll packages/PLSTream/libplstream.dll @YAPLIB@ $(LIBS) @MPI_LIBS@
libYap.a: $(LIB_OBJECTS)
-rm -f libYap.a
$(AR) rc libYap.a $(LIB_OBJECTS)
@@ -673,6 +700,7 @@ clean: clean_docs
@INSTALL_DLLS@ (cd library/random; $(MAKE) clean)
@INSTALL_DLLS@ (cd library/regex; $(MAKE) clean)
@INSTALL_DLLS@ (cd library/rltree; $(MAKE) clean)
@ENABLE_WINCONSOLE@ (cd LGPL/swi_console; $(MAKE) clean)
@INSTALL_DLLS@ (cd library/system; $(MAKE) clean)
@INSTALL_DLLS@ (cd library/tries; $(MAKE) clean)
@INSTALL_DLLS@ (cd packages/clib; $(MAKE) clean)

959
console/LGPL/pl-nt.c Executable file
View File

@@ -0,0 +1,959 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifdef _YAP_NOT_INSTALLED_
#define __WINDOWS__ 1
#endif
#ifdef __WINDOWS__
#define _WIN32_WINNT 0x0400
#if (_MSC_VER >= 1300)
#include <winsock2.h> /* Needed on VC8 */
#include <windows.h>
#else
#include <windows.h> /* Needed for MSVC 5&6 */
#include <winsock2.h>
#endif
#include "pl-incl.h"
#include "pl-utf8.h"
#include <crtdbg.h>
#include <process.h>
#include "pl-ctype.h"
#include <stdio.h>
#include <stdarg.h>
#include "SWI-Stream.h"
#include <process.h>
#include <winbase.h>
/*******************************
* CONSOLE *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
There is no way to tell which subsystem an app belongs too, except for
peeking in its executable-header. This is a bit too much ...
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
int
hasConsole(void)
{ HANDLE h;
if ( GD->os.gui_app == FALSE ) /* has been set explicitly */
succeed;
/* I found a console */
if ( (h = GetStdHandle(STD_OUTPUT_HANDLE)) != INVALID_HANDLE_VALUE )
{ DWORD mode;
if ( GetConsoleMode(h, &mode) )
succeed;
}
/* assume we are GUI */
fail;
}
int
PL_wait_for_console_input(void *handle)
{ BOOL rc;
HANDLE hConsole = handle;
for(;;)
{ rc = MsgWaitForMultipleObjects(1,
&hConsole,
FALSE, /* wait for either event */
INFINITE,
QS_ALLINPUT);
if ( rc == WAIT_OBJECT_0+1 )
{ MSG msg;
while( PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) )
{ TranslateMessage(&msg);
DispatchMessage(&msg);
}
} else if ( rc == WAIT_OBJECT_0 )
{ return TRUE;
} else
{ Sdprintf("MsgWaitForMultipleObjects(): 0x%x\n", rc);
}
}
}
/*******************************
* MESSAGE BOX *
*******************************/
void
PlMessage(const char *fm, ...)
{ va_list(args);
va_start(args, fm);
if ( hasConsole() )
{ Sfprintf(Serror, "SWI-Prolog: ");
Svfprintf(Serror, fm, args);
Sfprintf(Serror, "\n");
} else
{ char buf[1024];
vsprintf(buf, fm, args);
MessageBox(NULL, buf, "SWI-Prolog", MB_OK|MB_TASKMODAL);
}
va_end(args);
}
/*******************************
* WinAPI ERROR CODES *
*******************************/
char *
WinError()
{ int id = GetLastError();
char *msg;
static WORD lang;
static int lang_initialised = 0;
if ( !lang_initialised )
lang = MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_UK);
again:
if ( FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER|
FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_FROM_SYSTEM,
NULL, /* source */
id, /* identifier */
lang,
(LPTSTR) &msg,
0, /* size */
NULL) ) /* arguments */
{ atom_t a = PL_new_atom(msg);
LocalFree(msg);
lang_initialised = 1;
return stringAtom(a);
} else
{ if ( lang_initialised == 0 )
{ lang = MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT);
lang_initialised = 1;
goto again;
}
return "Unknown Windows error";
}
}
/*******************************
* SLEEP/1 SUPPORT *
*******************************/
int
Pause(double t)
{ HANDLE h;
if ( (h = CreateWaitableTimer(NULL, TRUE, NULL)) )
{ LARGE_INTEGER ft;
ft.QuadPart = -(LONGLONG)(t * 10000000.0); /* 100 nanosecs per tick */
SetWaitableTimer(h, &ft, 0, NULL, NULL, FALSE);
for(;;)
{ int rc = MsgWaitForMultipleObjects(1,
&h,
FALSE,
INFINITE,
QS_ALLINPUT);
if ( rc == WAIT_OBJECT_0+1 )
{ MSG msg;
while( PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) )
{ TranslateMessage(&msg);
DispatchMessage(&msg);
}
if ( PL_handle_signals() < 0 )
{ CloseHandle(h);
return FALSE;
}
} else
break;
}
CloseHandle(h);
return TRUE;
} else /* Pre NT implementation */
{ DWORD msecs = (DWORD)(t * 1000.0);
while( msecs >= 100 )
{ Sleep(100);
if ( PL_handle_signals() < 0 )
return FALSE;
msecs -= 100;
}
if ( msecs > 0 )
Sleep(msecs);
return TRUE;
}
}
/*******************************
* SET FILE SIZE *
*******************************/
int
ftruncate(int fileno, int64_t length)
{ errno_t e;
if ( (e=_chsize_s(fileno, length)) == 0 )
return 0;
errno = e;
return -1;
}
#ifndef _YAP_NOT_INSTALLED_
/*******************************
* QUERY CPU TIME *
*******************************/
#define nano * 0.0000001
#define ntick 1.0 /* manual says 100.0 ??? */
double
CpuTime(cputime_kind which)
{ double t;
HANDLE proc = GetCurrentProcess();
FILETIME created, exited, kerneltime, usertime;
if ( GetProcessTimes(proc, &created, &exited, &kerneltime, &usertime) )
{ FILETIME *p;
switch ( which )
{ case CPU_USER:
p = &usertime;
break;
case CPU_SYSTEM:
p = &kerneltime;
break;
}
t = (double)p->dwHighDateTime * (4294967296.0 * ntick nano);
t += (double)p->dwLowDateTime * (ntick nano);
} else /* '95, Windows 3.1/win32s */
{ extern intptr_t clock_wait_ticks;
t = (double) (clock() - clock_wait_ticks) / (double) CLOCKS_PER_SEC;
}
return t;
}
#endif
static int
CpuCount()
{ SYSTEM_INFO si;
GetSystemInfo(&si);
return si.dwNumberOfProcessors;
}
void
setOSPrologFlags()
{ PL_set_prolog_flag("cpu_count", PL_INTEGER, CpuCount());
}
char *
findExecutable(const char *module, char *exe)
{ int n;
wchar_t wbuf[MAXPATHLEN];
HMODULE hmod;
if ( module )
{ if ( !(hmod = GetModuleHandle(module)) )
{ hmod = GetModuleHandle("libpl.dll");
DEBUG(0,
Sdprintf("Warning: could not find module from \"%s\"\n"
"Warning: Trying %s to find home\n",
module,
hmod ? "\"LIBPL.DLL\"" : "executable"));
}
} else
hmod = NULL;
if ( (n = GetModuleFileNameW(hmod, wbuf, MAXPATHLEN)) > 0 )
{ wbuf[n] = EOS;
return _xos_long_file_name_toA(wbuf, exe, MAXPATHLEN);
} else if ( module )
{ char buf[MAXPATHLEN];
PrologPath(module, buf, sizeof(buf));
strcpy(exe, buf);
} else
*exe = EOS;
return exe;
}
/*******************************
* SUPPORT FOR SHELL/2 *
*******************************/
typedef struct
{ const char *name;
int id;
} showtype;
static int
get_showCmd(term_t show, int *cmd)
{ char *s;
showtype *st;
static showtype types[] =
{ { "hide", SW_HIDE },
{ "maximize", SW_MAXIMIZE },
{ "minimize", SW_MINIMIZE },
{ "restore", SW_RESTORE },
{ "show", SW_SHOW },
{ "showdefault", SW_SHOWDEFAULT },
{ "showmaximized", SW_SHOWMAXIMIZED },
{ "showminimized", SW_SHOWMINIMIZED },
{ "showminnoactive", SW_SHOWMINNOACTIVE },
{ "showna", SW_SHOWNA },
{ "shownoactive", SW_SHOWNOACTIVATE },
{ "shownormal", SW_SHOWNORMAL },
/* compatibility */
{ "normal", SW_SHOWNORMAL },
{ "iconic", SW_MINIMIZE },
{ NULL, 0 },
};
if ( show == 0 )
{ *cmd = SW_SHOWNORMAL;
succeed;
}
if ( !PL_get_chars_ex(show, &s, CVT_ATOM) )
fail;
for(st=types; st->name; st++)
{ if ( streq(st->name, s) )
{ *cmd = st->id;
succeed;
}
}
return PL_error(NULL, 0, NULL, ERR_DOMAIN,
PL_new_atom("win_show"), show);
}
static int
win_exec(size_t len, const wchar_t *cmd, UINT show)
{ GET_LD
STARTUPINFOW startup;
PROCESS_INFORMATION info;
int rval;
wchar_t *wcmd;
memset(&startup, 0, sizeof(startup));
startup.cb = sizeof(startup);
startup.wShowWindow = show;
/* ensure 0-terminated */
wcmd = PL_malloc((len+1)*sizeof(wchar_t));
memcpy(wcmd, cmd, len*sizeof(wchar_t));
wcmd[len] = 0;
rval = CreateProcessW(NULL, /* app */
wcmd,
NULL, NULL, /* security */
FALSE, /* inherit handles */
0, /* flags */
NULL, /* environment */
NULL, /* Directory */
&startup,
&info); /* process info */
PL_free(wcmd);
if ( rval )
{ CloseHandle(info.hProcess);
CloseHandle(info.hThread);
succeed;
} else
{ term_t tmp = PL_new_term_ref();
PL_unify_wchars(tmp, PL_ATOM, len, cmd);
return PL_error(NULL, 0, WinError(), ERR_SHELL_FAILED, tmp);
}
}
static void
utf8towcs(wchar_t *o, const char *src)
{ for( ; *src; )
{ int wc;
src = utf8_get_char(src, &wc);
*o++ = wc;
}
*o = 0;
}
int
System(char *command) /* command is a UTF-8 string */
{ STARTUPINFOW sinfo;
PROCESS_INFORMATION pinfo;
int shell_rval;
size_t len;
wchar_t *wcmd;
memset(&sinfo, 0, sizeof(sinfo));
sinfo.cb = sizeof(sinfo);
len = utf8_strlen(command, strlen(command));
wcmd = PL_malloc((len+1)*sizeof(wchar_t));
utf8towcs(wcmd, command);
if ( CreateProcessW(NULL, /* module */
wcmd, /* command line */
NULL, /* Security stuff */
NULL, /* Thread security stuff */
FALSE, /* Inherit handles */
CREATE_NO_WINDOW, /* flags */
NULL, /* environment */
NULL, /* CWD */
&sinfo, /* startup info */
&pinfo) ) /* process into */
{ BOOL rval;
DWORD code;
CloseHandle(pinfo.hThread); /* don't need this */
PL_free(wcmd);
do
{ MSG msg;
if ( PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) )
{ TranslateMessage(&msg);
DispatchMessage(&msg);
} else
Sleep(50);
rval = GetExitCodeProcess(pinfo.hProcess, &code);
} while(rval == TRUE && code == STILL_ACTIVE);
shell_rval = (rval == TRUE ? code : -1);
CloseHandle(pinfo.hProcess);
} else
{ PL_free(wcmd);
return shell_rval = -1;
}
return shell_rval;
}
word
pl_win_exec(term_t cmd, term_t how)
{ wchar_t *s;
size_t len;
UINT h;
if ( PL_get_wchars(cmd, &len, &s, CVT_ALL|CVT_EXCEPTION) &&
get_showCmd(how, &h) )
{ return win_exec(len, s, h);
} else
fail;
}
typedef struct
{ int eno;
const char *message;
} shell_error;
static const shell_error se_errors[] =
{ { 0 , "Out of memory or resources" },
{ ERROR_FILE_NOT_FOUND, "File not found" },
{ ERROR_PATH_NOT_FOUND, "path not found" },
{ ERROR_BAD_FORMAT, "Invalid .EXE" },
{ SE_ERR_ACCESSDENIED, "Access denied" },
{ SE_ERR_ASSOCINCOMPLETE, "Incomplete association" },
{ SE_ERR_DDEBUSY, "DDE server busy" },
{ SE_ERR_DDEFAIL, "DDE transaction failed" },
{ SE_ERR_DDETIMEOUT, "DDE request timed out" },
{ SE_ERR_DLLNOTFOUND, "DLL not found" },
{ SE_ERR_FNF, "File not found (FNF)" },
{ SE_ERR_NOASSOC, "No association" },
{ SE_ERR_OOM, "Not enough memory" },
{ SE_ERR_PNF, "Path not found (PNF)" },
{ SE_ERR_SHARE, "Sharing violation" },
{ 0, NULL }
};
static int
win_shell(term_t op, term_t file, term_t how)
{ size_t lo, lf;
wchar_t *o, *f;
UINT h;
HINSTANCE instance;
if ( !PL_get_wchars(op, &lo, &o, CVT_ALL|CVT_EXCEPTION|BUF_RING) ||
!PL_get_wchars(file, &lf, &f, CVT_ALL|CVT_EXCEPTION|BUF_RING) ||
!get_showCmd(how, &h) )
fail;
instance = ShellExecuteW(NULL, o, f, NULL, NULL, h);
if ( (intptr_t)instance <= 32 )
{ const shell_error *se;
for(se = se_errors; se->message; se++)
{ if ( se->eno == (int)instance )
return PL_error(NULL, 0, se->message, ERR_SHELL_FAILED, file);
}
PL_error(NULL, 0, NULL, ERR_SHELL_FAILED, file);
}
succeed;
}
static
PRED_IMPL("win_shell", 2, win_shell2, 0)
{ return win_shell(A1, A2, 0);
}
static
PRED_IMPL("win_shell", 3, win_shell3, 0)
{ return win_shell(A1, A2, A3);
}
foreign_t
pl_win_module_file(term_t module, term_t file)
{ char buf[MAXPATHLEN];
char *m;
char *f;
if ( !PL_get_chars_ex(module, &m, CVT_ALL) )
fail;
if ( (f = findExecutable(m, buf)) )
return PL_unify_atom_chars(file, f);
fail;
}
/*******************************
* WINDOWS MESSAGES *
*******************************/
LRESULT
PL_win_message_proc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)
{
#ifdef O_PLMT
if ( hwnd == NULL &&
message == WM_SIGNALLED &&
wParam == 0 && /* or another constant? */
lParam == 0 )
{ if ( PL_handle_signals() < 0 )
return PL_MSG_EXCEPTION_RAISED;
return PL_MSG_HANDLED;
}
#endif
return PL_MSG_IGNORED;
}
/*******************************
* DLOPEN AND FRIENDS *
*******************************/
#ifdef EMULATE_DLOPEN
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
These functions emulate the bits from the ELF shared object interface we
need. They are used by pl-load.c, which defines the actual Prolog
interface.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static char *dlmsg;
void *
dlopen(const char *file, int flags) /* file is in UTF-8 */
{ HINSTANCE h;
size_t len = utf8_strlen(file, strlen(file));
wchar_t *wfile = alloca((len+1)*sizeof(wchar_t));
if ( !wfile )
{ dlmsg = "No memory";
return NULL;
}
utf8towcs(wfile, file);
if ( (h = LoadLibraryW(wfile)) )
{ dlmsg = "No Error";
return (void *)h;
}
dlmsg = WinError();
return NULL;
}
const char *
dlerror()
{ return dlmsg;
}
void *
dlsym(void *handle, char *symbol)
{ void *addr = GetProcAddress(handle, symbol);
if ( addr )
{ dlmsg = "No Error";
return addr;
}
dlmsg = WinError();
return NULL;
}
int
dlclose(void *handle)
{ FreeLibrary(handle);
return 0;
}
#endif /*EMULATE_DLOPEN*/
/*******************************
* FOLDERS *
*******************************/
#include <Shlobj.h>
typedef struct folderid
{ int csidl;
const char *name;
} folderid;
static const folderid folderids[] =
{ { CSIDL_COMMON_ALTSTARTUP, "common_altstartup" },
{ CSIDL_ALTSTARTUP, "altstartup" },
{ CSIDL_APPDATA, "appdata" },
{ CSIDL_CONTROLS, "controls" },
{ CSIDL_COOKIES, "cookies" },
{ CSIDL_DESKTOP, "desktop" },
{ CSIDL_COMMON_DESKTOPDIRECTORY, "common_desktopdirectory" },
{ CSIDL_DESKTOPDIRECTORY, "desktopdirectory" },
{ CSIDL_COMMON_FAVORITES, "common_favorites" },
{ CSIDL_FAVORITES, "favorites" },
{ CSIDL_FONTS, "fonts" },
{ CSIDL_HISTORY, "history" },
{ CSIDL_INTERNET_CACHE, "internet_cache" },
{ CSIDL_INTERNET, "internet" },
{ CSIDL_DRIVES, "drives" },
{ CSIDL_PERSONAL, "personal" },
{ CSIDL_NETWORK, "network" },
{ CSIDL_NETHOOD, "nethood" },
{ CSIDL_PERSONAL, "personal" },
{ CSIDL_PRINTERS, "printers" },
{ CSIDL_PRINTHOOD, "printhood" },
{ CSIDL_COMMON_PROGRAMS, "common_programs" },
{ CSIDL_PROGRAMS, "programs" },
{ CSIDL_RECENT, "recent" },
{ CSIDL_BITBUCKET, "bitbucket" },
{ CSIDL_SENDTO, "sendto" },
{ CSIDL_COMMON_STARTMENU, "common_startmenu" },
{ CSIDL_STARTMENU, "startmenu" },
{ CSIDL_COMMON_STARTUP, "common_startup" },
{ CSIDL_STARTUP, "startup" },
{ CSIDL_TEMPLATES, "templates" },
{ 0, NULL }
};
static int
unify_csidl_path(term_t t, int csidl)
{ wchar_t buf[MAX_PATH];
if ( SHGetSpecialFolderPathW(0, buf, csidl, FALSE) )
{ wchar_t *p;
for(p=buf; *p; p++)
{ if ( *p == '\\' )
*p = '/';
}
return PL_unify_wchars(t, PL_ATOM, -1, buf);
} else
return PL_error(NULL, 0, WinError(), ERR_SYSCALL, "SHGetSpecialFolderPath");
}
static
PRED_IMPL("win_folder", 2, win_folder, PL_FA_NONDETERMINISTIC)
{ GET_LD
int n;
switch( CTX_CNTRL )
{ case FRG_FIRST_CALL:
if ( PL_is_variable(A1) )
{ n = 0;
goto generate;
} else
{ char *s;
if ( PL_get_chars(A1, &s, CVT_ATOM|CVT_EXCEPTION) )
{ const folderid *fid;
for(fid = folderids; fid->name; fid++)
{ if ( streq(s, fid->name) )
return unify_csidl_path(A2, fid->csidl);
}
{ atom_t dom = PL_new_atom("win_folder");
PL_error(NULL, 0, NULL, ERR_DOMAIN, dom, A1);
PL_unregister_atom(dom);
return FALSE;
}
} else
return FALSE;
}
case FRG_REDO:
{ fid_t fid;
n = (int)CTX_INT+1;
generate:
fid = PL_open_foreign_frame();
for(; folderids[n].name; n++)
{ if ( unify_csidl_path(A2, folderids[n].csidl) &&
PL_unify_atom_chars(A1, folderids[n].name) )
{ PL_close_foreign_frame(fid);
ForeignRedoInt(n);
}
PL_rewind_foreign_frame(fid);
}
PL_close_foreign_frame(fid);
return FALSE;
}
default:
succeed;
}
}
/*******************************
* REGISTRY *
*******************************/
#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;
}
DEBUG(2, Sdprintf("Trying %s\n", buf));
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
PRED_IMPL("win_registry_get_value", 3, win_registry_get_value, 0)
{ GET_LD
DWORD type;
BYTE data[MAXREGSTRLEN];
DWORD len = sizeof(data);
size_t klen, namlen;
wchar_t *k, *name;
HKEY key;
term_t Key = A1;
term_t Name = A2;
term_t Value = A3;
if ( !PL_get_wchars(Key, &klen, &k, CVT_ATOM|CVT_EXCEPTION) ||
!PL_get_wchars(Name, &namlen, &name, CVT_ATOM|CVT_ATOM) )
return FALSE;
if ( !(key=reg_open_key(k, FALSE)) )
return PL_error(NULL, 0, NULL, ERR_EXISTENCE, PL_new_atom("key"), Key);
DEBUG(9, Sdprintf("key = %p, name = %s\n", key, name));
if ( RegQueryValueExW(key, name, NULL, &type, data, &len) == ERROR_SUCCESS )
{ RegCloseKey(key);
switch(type)
{ case REG_SZ:
return PL_unify_wchars(Value, PL_ATOM,
len/sizeof(wchar_t)-1, (wchar_t*)data);
case REG_DWORD:
return PL_unify_integer(Value, *((DWORD *)data));
default:
warning("get_registry_value/2: Unknown registery-type: %d", type);
fail;
}
}
return FALSE;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Get the local, global, trail and argument-stack defaults from the
registry. They can be on the HKEY_CURRENT_USER as well as the
HKEY_LOCAL_MACHINE registries to allow for both user-only and
system-wide settings.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static struct regdef
{ const char *name;
int *address;
} const regdefs[] =
{ { "localSize", &GD->defaults.local },
{ "globalSize", &GD->defaults.global },
{ "trailSize", &GD->defaults.trail },
{ NULL, NULL }
};
static void
setStacksFromKey(HKEY key)
{ DWORD type;
BYTE data[128];
DWORD len = sizeof(data);
const struct regdef *rd;
for(rd = regdefs; rd->name; rd++)
{ if ( RegQueryValueEx(key, rd->name, NULL, &type, data, &len) ==
ERROR_SUCCESS &&
type == REG_DWORD )
{ DWORD v = *((DWORD *)data);
*rd->address = (int)v;
}
}
}
void
getDefaultsFromRegistry()
{ HKEY key;
if ( (key = reg_open_key(L"HKEY_LOCAL_MACHINE/Software/SWI/Prolog", FALSE)) )
{ setStacksFromKey(key);
RegCloseKey(key);
}
if ( (key = reg_open_key(L"HKEY_CURRENT_USER/Software/SWI/Prolog", FALSE)) )
{ setStacksFromKey(key);
RegCloseKey(key);
}
}
/*******************************
* PUBLISH PREDICATES *
*******************************/
BeginPredDefs(win)
PRED_DEF("win_shell", 2, win_shell2, 0)
PRED_DEF("win_shell", 3, win_shell3, 0)
PRED_DEF("win_registry_get_value", 3, win_registry_get_value, 0)
PRED_DEF("win_folder", 2, win_folder, PL_FA_NONDETERMINISTIC)
EndPredDefs
#endif /*__WINDOWS__*/

91
console/LGPL/pl-ntcon.c Executable file
View File

@@ -0,0 +1,91 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2010, University of Amsterdam, VU University Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include <winsock2.h>
#include <windows.h>
#include "SWI-Stream.h"
#include "SWI-Prolog.h"
#include <signal.h>
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This is the simple main program of swipl.exe; the SWI-Prolog console
application. It can be used as a basis for console-based applications
that have SWI-Prolog embedded.
The default version does Control-C processing and decodes ANSI color
sequences to support colors in the console window.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#ifndef O_CTRLC
#define O_CTRLC 1
#endif
#ifndef O_ANSI_COLORS
#define O_ANSI_COLORS 1
#endif
/*******************************
* INTERRUPT *
*******************************/
#if O_CTRLC
static DWORD main_thread_id;
static BOOL
consoleHandlerRoutine(DWORD id)
{ switch(id)
{ case CTRL_C_EVENT:
PL_w32thread_raise(main_thread_id, SIGINT);
return TRUE;
}
return FALSE;
}
#endif
/*******************************
* MAIN *
*******************************/
int
main(int argc, char **argv)
{
#if O_CTRLC
main_thread_id = GetCurrentThreadId();
SetConsoleCtrlHandler((PHANDLER_ROUTINE)consoleHandlerRoutine, TRUE);
#endif
#if O_ANSI_COLORS
PL_w32_wrap_ansi_console(); /* decode ANSI color sequences (ESC[...m) */
#endif
if ( !PL_initialise(argc, argv) )
PL_halt(1);
PL_halt(PL_toplevel() ? 0 : 1);
return 0;
}

459
console/LGPL/pl-ntconsole.c Executable file
View File

@@ -0,0 +1,459 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker and Matt Lilley
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2010, VU University, Amsterdam
Copyright (C): 2009, SCIENTIFIC SOFTWARE AND SYSTEMS LIMITED
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#define WINDOWS_LEAN_AND_MEAN 1
#if (_MSC_VER >= 1300)
#include <winsock2.h> /* Needed on VC8 */
#include <windows.h>
#else
#include <windows.h> /* Needed for MSVC 5&6 */
#include <winsock2.h>
#endif
#include "pl-incl.h"
#define ANSI_MAGIC (0x734ab9de)
#define ANSI_BUFFER_SIZE (256)
#define ANSI_MAX_ARGC (10)
typedef enum
{ CMD_INITIAL = 0,
CMD_ESC,
CMD_ANSI
} astate;
typedef struct
{ int magic;
HANDLE hConsole;
IOSTREAM *pStream;
void *saved_handle;
wchar_t buffer[ANSI_BUFFER_SIZE];
size_t buffered;
int argv[ANSI_MAX_ARGC];
int argc;
int argstat;
astate cmdstat; /* State for sequence processing */
WORD def_attr; /* Default attributes */
} ansi_stream;
static IOFUNCTIONS con_functions;
static IOFUNCTIONS *saved_functions;
static void
Message(const char *fm, ...)
{ char buf[1024];
va_list(args);
return;
va_start(args, fm);
vsprintf(buf, fm, args);
MessageBox(NULL, buf, "SWI-Prolog", MB_OK|MB_TASKMODAL);
va_end(args);
}
static int
flush_ansi(ansi_stream *as)
{ size_t written = 0;
while ( written < as->buffered )
{ BOOL rc;
DWORD done;
rc = WriteConsoleW(as->hConsole,
&as->buffer[written],
(DWORD)(as->buffered-written),
&done,
NULL);
if ( rc )
{ written += done;
} else
{ as->buffered = 0;
return -1;
}
}
as->buffered = 0;
return 0;
}
static int
send_ansi(ansi_stream *as, int chr)
{ as->buffer[as->buffered++] = chr;
if ( as->buffered == ANSI_BUFFER_SIZE ||
(as->pStream->flags & SIO_NBUF) ||
(chr == '\n' && (as->pStream->flags & SIO_LBUF)) )
return flush_ansi(as);
return 0;
}
#define FG_MASK (FOREGROUND_RED|FOREGROUND_BLUE|FOREGROUND_GREEN)
#define BG_MASK (BACKGROUND_RED|BACKGROUND_BLUE|BACKGROUND_GREEN)
static void
set_ansi_attributes(ansi_stream *as)
{ CONSOLE_SCREEN_BUFFER_INFO info;
if ( GetConsoleScreenBufferInfo(as->hConsole, &info) )
{ int i;
WORD attr = info.wAttributes;
for(i=0; i < as->argc; i++)
{ switch( as->argv[i] )
{ case 0:
attr = as->def_attr;
break;
case 1:
attr |= FOREGROUND_INTENSITY;
break;
case 22:
attr &= ~FOREGROUND_INTENSITY;
break;
default:
if ( as->argv[i] >= 30 && as->argv[i] <= 39 )
{ int fg = as->argv[i] - 30;
attr &= ~FG_MASK;
if ( fg == 9 ) /* default */
{ attr |= (as->def_attr & FG_MASK);
} else
{ if ( fg % 2 == 1 )
attr |= FOREGROUND_RED;
if ( fg >= 4 )
attr |= FOREGROUND_BLUE;
if ( (fg == 2) || (fg == 3) || (fg == 6) || (fg == 7) )
attr |= FOREGROUND_GREEN;
}
} else if ( as->argv[i] >= 40 && as->argv[i] <= 49 )
{ int bg = as->argv[i] - 40;
attr &= ~BG_MASK;
if ( bg == 9 ) /* default */
{ attr |= (as->def_attr & BG_MASK);
} else
{ if ( bg % 2 == 1 )
attr |= BACKGROUND_RED;
if ( bg >= 4 )
attr |= BACKGROUND_BLUE;
if ( (bg == 2) || (bg == 3) || (bg == 6) || (bg == 7) )
attr |= BACKGROUND_GREEN;
}
}
}
}
if ( attr != info.wAttributes )
{ flush_ansi(as);
SetConsoleTextAttribute(as->hConsole, attr);
}
}
}
static void
rlc_need_arg(ansi_stream *as, int arg, int def)
{ if ( as->argc < arg )
{ as->argv[arg-1] = def;
as->argc = arg;
}
}
static int
put_ansi(ansi_stream *as, int chr)
{ switch(as->cmdstat)
{ case CMD_INITIAL:
switch(chr)
{
#if 0
case '\b':
CMD(rlc_caret_backward(b, 1));
break;
case Control('G'):
MessageBeep(MB_ICONEXCLAMATION);
break;
case '\r':
CMD(rlc_cariage_return(b));
break;
case '\n':
CMD(rlc_caret_down(b, 1));
break;
case '\t':
CMD(rlc_tab(b));
break;
#endif
case 27: /* ESC */
as->cmdstat = CMD_ESC;
break;
default:
return send_ansi(as, chr);
}
break;
case CMD_ESC:
switch(chr)
{ case '[':
as->cmdstat = CMD_ANSI;
as->argc = 0;
as->argstat = 0; /* no arg */
break;
default:
as->cmdstat = CMD_INITIAL;
break;
}
break;
case CMD_ANSI: /* ESC [ */
if ( chr >= '0' && chr <= '9' )
{ if ( !as->argstat )
{ as->argv[as->argc] = (chr - '0');
as->argstat = 1; /* positive */
} else
{ as->argv[as->argc] = as->argv[as->argc] * 10 + (chr - '0');
}
break;
}
if ( !as->argstat && chr == '-' )
{ as->argstat = -1; /* negative */
break;
}
if ( as->argstat )
{ as->argv[as->argc] *= as->argstat;
if ( as->argc < (ANSI_MAX_ARGC-1) )
as->argc++; /* silently discard more of them */
as->argstat = 0;
}
switch(chr)
{ case ';':
return 0; /* wait for more args */
#if 0
case 'H':
case 'f':
rlc_need_arg(as, 1, 0);
rlc_need_arg(as, 2, 0);
CMD(rlc_set_caret(as, as->argv[0], as->argv[1]));
break;
case 'A':
rlc_need_arg(as, 1, 1);
CMD(rlc_caret_up(as, as->argv[0]));
break;
case 'B':
rlc_need_arg(as, 1, 1);
CMD(rlc_caret_down(as, as->argv[0]));
break;
case 'C':
rlc_need_arg(as, 1, 1);
CMD(rlc_caret_forward(as, as->argv[0]));
break;
case 'D':
rlc_need_arg(as, 1, 1);
CMD(rlc_caret_backward(as, as->argv[0]));
break;
case 's':
CMD(rlc_save_caret_position(as));
break;
case 'u':
CMD(rlc_restore_caret_position(as));
break;
case 'J':
if ( as->argv[0] == 2 )
CMD(rlc_erase_display(as));
break;
case 'K':
CMD(rlc_erase_line(as));
break;
#endif
case 'm':
rlc_need_arg(as, 1, 0);
set_ansi_attributes(as);
}
as->cmdstat = CMD_INITIAL;
}
return 0;
}
static ssize_t
write_ansi(void *handle, char *buffer, size_t size)
{ ansi_stream *as = handle;
size_t n = size/sizeof(wchar_t);
const wchar_t *s = (const wchar_t*)buffer;
const wchar_t *e = &s[n];
Message("Writing %d characters", n);
for( ; s<e; s++)
{ if ( put_ansi(as, *s) != 0 )
return -1; /* error */
}
Message("Wrote %d characters", n);
return n * sizeof(wchar_t);
}
static int
close_ansi(void *handle)
{ ansi_stream *as = handle;
if ( as->magic == ANSI_MAGIC )
{ as->pStream->functions = saved_functions;
as->pStream->handle = as->saved_handle;
PL_free(as);
return 0;
}
return -1;
}
static int
control_ansi(void *handle, int op, void *data)
{ ansi_stream *as = handle;
switch( op )
{ case SIO_FLUSHOUTPUT:
return flush_ansi(as);
case SIO_SETENCODING:
return -1; /* We cannot change the encoding! */
case SIO_LASTERROR:
return 0; /* TBD */
default:
return -1;
}
}
/*******************************
* USER WIN32 CONSOLE *
*******************************/
static ssize_t
Sread_win32_console(void *handle, char *buffer, size_t size)
{ GET_LD
ansi_stream *as = handle;
BOOL rc;
DWORD done;
DWORD mode;
int isRaw = FALSE;
if ( Suser_input &&
Suser_input->handle == handle &&
PL_ttymode(Suser_input) == PL_RAWTTY )
{ if ( GetConsoleMode(as->hConsole, &mode) &&
SetConsoleMode(as->hConsole,
mode & ~(ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT)) )
isRaw = TRUE;
}
if ( !PL_wait_for_console_input(as->hConsole) )
goto error;
rc = ReadConsoleW(as->hConsole,
buffer,
(DWORD)(size / sizeof(wchar_t)),
&done,
NULL);
if ( rc )
{ if ( isRaw )
SetConsoleMode(as->hConsole, mode);
return done * sizeof(wchar_t);
}
error:
if ( isRaw )
SetConsoleMode(as->hConsole, mode);
return -1;
}
static int
wrap_console(HANDLE h, IOSTREAM *s, IOFUNCTIONS *funcs)
{ ansi_stream *as;
as = PL_malloc(sizeof(*as));
memset(as, 0, sizeof(*as));
as->hConsole = h;
as->pStream = s;
as->saved_handle = s->handle;
s->handle = as;
s->encoding = ENC_WCHAR;
s->functions = funcs;
return TRUE;
}
static void
init_output(void *handle, CONSOLE_SCREEN_BUFFER_INFO *info)
{ ansi_stream *as = handle;
as->def_attr = info->wAttributes;
}
int
PL_w32_wrap_ansi_console(void)
{ HANDLE hIn = GetStdHandle(STD_INPUT_HANDLE);
HANDLE hOut = GetStdHandle(STD_OUTPUT_HANDLE);
HANDLE hError = GetStdHandle(STD_ERROR_HANDLE);
CONSOLE_SCREEN_BUFFER_INFO info;
if ( hIn == INVALID_HANDLE_VALUE ||
hOut == INVALID_HANDLE_VALUE ||
hError == INVALID_HANDLE_VALUE ||
!GetConsoleScreenBufferInfo(hOut, &info) )
return FALSE;
saved_functions = Sinput->functions;
con_functions = *Sinput->functions;
con_functions.read = Sread_win32_console;
con_functions.write = write_ansi;
con_functions.close = close_ansi;
con_functions.control = control_ansi;
con_functions.seek = NULL;
wrap_console(hIn, Sinput, &con_functions);
wrap_console(hOut, Soutput, &con_functions);
wrap_console(hError, Serror, &con_functions);
init_output(Soutput->handle, &info);
init_output(Serror->handle, &info);
PL_set_prolog_flag("tty_control", PL_BOOL, TRUE);
return TRUE;
}

1061
console/LGPL/pl-ntmain.c Executable file
View File

File diff suppressed because it is too large Load Diff

151
include/SWI-Prolog.h
View File

@@ -314,6 +314,83 @@ typedef struct foreign_context *control_t;
/* end from pl-itf.h */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Output representation for PL_get_chars() and friends. The
prepresentation type REP_FN is for PL_get_file_name() and friends. On
Windows we use UTF-8 which is translated by the `XOS' layer to Windows
UNICODE file functions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define REP_ISO_LATIN_1 0x0000 /* output representation */
#define REP_UTF8 0x1000
#define REP_MB 0x2000
#ifdef __WINDOWS__
#define REP_FN REP_UTF8
#else
#define REP_FN REP_MB
#endif
#define PL_DIFF_LIST 0x20000 /* PL_unify_chars() */
#ifdef SIO_MAGIC /* defined from <SWI-Stream.h> */
/*******************************
* STREAM SUPPORT *
*******************************/
/* Make IOSTREAM known to Prolog */
#define PL_open_stream PL_unify_stream /* compatibility */
PL_EXPORT(int) PL_unify_stream(term_t t, IOSTREAM *s);
PL_EXPORT(int) PL_get_stream_handle(term_t t, IOSTREAM **s);
PL_EXPORT(int) PL_release_stream(IOSTREAM *s);
PL_EXPORT(IOSTREAM *) PL_open_resource(module_t m,
const char *name,
const char *rc_class,
const char *mode);
PL_EXPORT(IOSTREAM *)*_PL_streams(void); /* base of streams */
#ifndef PL_KERNEL
#define Suser_input (_PL_streams()[0])
#define Suser_output (_PL_streams()[1])
#define Suser_error (_PL_streams()[2])
#endif
#define PL_WRT_QUOTED 0x01 /* quote atoms */
#define PL_WRT_IGNOREOPS 0x02 /* ignore list/operators */
#define PL_WRT_NUMBERVARS 0x04 /* print $VAR(N) as a variable */
#define PL_WRT_PORTRAY 0x08 /* call portray */
#define PL_WRT_CHARESCAPES 0x10 /* Output ISO escape sequences */
#define PL_WRT_BACKQUOTED_STRING 0x20 /* Write strings as `...` */
/* Write attributed variables */
#define PL_WRT_ATTVAR_IGNORE 0x040 /* Default: just write the var */
#define PL_WRT_ATTVAR_DOTS 0x080 /* Write as Var{...} */
#define PL_WRT_ATTVAR_WRITE 0x100 /* Write as Var{Attributes} */
#define PL_WRT_ATTVAR_PORTRAY 0x200 /* Use Module:portray_attrs/2 */
#define PL_WRT_ATTVAR_MASK \
(PL_WRT_ATTVAR_IGNORE | \
PL_WRT_ATTVAR_DOTS | \
PL_WRT_ATTVAR_WRITE | \
PL_WRT_ATTVAR_PORTRAY)
#define PL_WRT_BLOB_PORTRAY 0x400 /* Use portray to emit non-text blobs */
PL_EXPORT(int) PL_write_term(IOSTREAM *s,
term_t term,
int precedence,
int flags);
/* PL_ttymode() results */
#define PL_NOTTY 0 /* -tty in effect */
#define PL_RAWTTY 1 /* get_single_char/1 */
#define PL_COOKEDTTY 2 /* normal input */
PL_EXPORT(int) PL_ttymode(IOSTREAM *s);
#endif /*SIO_MAGIC*/
PL_EXPORT(int) PL_chars_to_term(const char *chars,
term_t term);
/*******************************
* CALL-BACK *
*******************************/
@@ -465,6 +542,7 @@ extern X_API int PL_call(term_t, module_t);
extern X_API void PL_register_foreign(const char *, int, pl_function_t, int);
extern X_API void PL_register_foreign_in_module(const char *, const char *, int, pl_function_t, int);
extern X_API void PL_register_extensions(const PL_extension *);
extern X_API void PL_register_extensions_in_module(const char *module, const PL_extension *);
extern X_API void PL_load_extensions(const PL_extension *);
extern X_API int PL_handle_signals(void);
extern X_API int PL_thread_self(void);
@@ -521,9 +599,34 @@ readline overhead.
#define PL_DISPATCH_INSTALLED 2 /* dispatch function installed? */
extern X_API int PL_dispatch(int fd, int wait);
PL_EXPORT(void) PL_add_to_protocol(const char *buf, size_t count);
PL_EXPORT(char *) PL_prompt_string(int fd);
PL_EXPORT(void) PL_write_prompt(int dowrite);
PL_EXPORT(void) PL_prompt_next(int fd);
PL_EXPORT(char *) PL_atom_generator(const char *prefix, int state);
PL_EXPORT(pl_wchar_t*) PL_atom_generator_w(const pl_wchar_t *pref,
pl_wchar_t *buffer,
size_t buflen,
int state);
typedef int (*PL_dispatch_hook_t)(int fd);
/*******************************
* WINDOWS MESSAGES *
*******************************/
#ifdef _WINDOWS_ /* <windows.h> is included */
#define PL_MSG_EXCEPTION_RAISED -1
#define PL_MSG_IGNORED 0
#define PL_MSG_HANDLED 1
PL_EXPORT(LRESULT) PL_win_message_proc(HWND hwnd,
UINT message,
WPARAM wParam,
LPARAM lParam);
#endif /*_WINDOWS_*/
/********************************
* QUERY PROLOG *
*********************************/
@@ -545,54 +648,6 @@ typedef int (*PL_dispatch_hook_t)(int fd);
X_API intptr_t PL_query(int); /* get information from Prolog */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Output representation for PL_get_chars() and friends. The
prepresentation type REP_FN is for PL_get_file_name() and friends. On
Windows we use UTF-8 which is translated by the `XOS' layer to Windows
UNICODE file functions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define REP_ISO_LATIN_1 0x0000 /* output representation */
#define REP_UTF8 0x1000
#define REP_MB 0x2000
#ifdef __WINDOWS__
#define REP_FN REP_UTF8
#else
#define REP_FN REP_MB
#endif
#define PL_DIFF_LIST 0x20000 /* PL_unify_chars() */
#define PL_WRT_QUOTED 0x01 /* quote atoms */
#define PL_WRT_IGNOREOPS 0x02 /* ignore list/operators */
#define PL_WRT_NUMBERVARS 0x04 /* print $VAR(N) as a variable */
#define PL_WRT_PORTRAY 0x08 /* call portray */
#define PL_WRT_CHARESCAPES 0x10 /* Output ISO escape sequences */
#define PL_WRT_BACKQUOTED_STRING 0x20 /* Write strings as `...` */
/* Write attributed variables */
#define PL_WRT_ATTVAR_IGNORE 0x040 /* Default: just write the var */
#define PL_WRT_ATTVAR_DOTS 0x080 /* Write as Var{...} */
#define PL_WRT_ATTVAR_WRITE 0x100 /* Write as Var{Attributes} */
#define PL_WRT_ATTVAR_PORTRAY 0x200 /* Use Module:portray_attrs/2 */
#define PL_WRT_ATTVAR_MASK \
(PL_WRT_ATTVAR_IGNORE | \
PL_WRT_ATTVAR_DOTS | \
PL_WRT_ATTVAR_WRITE | \
PL_WRT_ATTVAR_PORTRAY)
#ifdef SIO_MAGIC /* defined from <SWI-Stream.h> */
/* Make IOSTREAM known to Prolog */
PL_EXPORT(int) PL_open_stream(term_t t, IOSTREAM *s);
PL_EXPORT(int) PL_unify_stream(term_t t, IOSTREAM *s);
#define PL_open_stream PL_unify_stream
PL_EXPORT(int) PL_get_stream_handle(term_t t, IOSTREAM **s);
PL_EXPORT(int) PL_release_stream(IOSTREAM *s);
PL_EXPORT(int) PL_write_term(IOSTREAM *s,term_t term,int precedence,int flags);
#endif
/*******************************
* BLOBS *
*******************************/

2
include/YapInterface.h
View File

@@ -516,6 +516,8 @@ extern X_API int PROTO(YAP_Variant,(YAP_Term,YAP_Term));
extern X_API int PROTO(YAP_ExactlyEqual,(YAP_Term,YAP_Term));
extern X_API YAP_Int PROTO(YAP_TermHash,(YAP_Term, YAP_Int, YAP_Int, int));
extern X_API void PROTO(YAP_signal,(int));
/* stack expansion control */
extern X_API int PROTO(YAP_SetYAPFlag,(yap_flag_t,int));

25
library/dialect/swi/fli/swi.c
View File

@@ -2722,9 +2722,23 @@ X_API void PL_register_foreign_in_module(const char *module, const char *name, i
X_API void PL_register_extensions(const PL_extension *ptr)
{
// implemented as register foreign
// may cause problems during initialization?
PL_load_extensions(ptr);
}
X_API void
PL_register_extensions_in_module(const char *module, const PL_extension *e)
{
// implemented as register foreign
/* ignore flags for now */
while(e->predicate_name != NULL) {
PL_register_foreign_in_module(module, e->predicate_name, e->arity, e->function, e->flags);
e++;
}
}
X_API void PL_register_foreign(const char *name, int arity, pl_function_t function, int flags)
{
PL_register_foreign_in_module(NULL, name, arity, function, flags);
@@ -3163,6 +3177,17 @@ X_API void PL_on_halt(void (*f)(int, void *), void *closure)
Yap_HaltRegisterHook((HaltHookFunc)f,closure);
}
X_API char *PL_atom_generator(const char *prefix, int state)
{
return NULL;
}
X_API pl_wchar_t *PL_atom_generator_w(const pl_wchar_t *pref, pl_wchar_t *buffer, size_t buflen, int state)
{
return NULL;
}
void
Yap_swi_install(void)
{

108
packages/PLStream/pl-incl.h
View File

@@ -7,6 +7,11 @@
#define O_XOS 1
#endif
#ifdef THREADS
#define O_PLMT 1
#endif
#include <SWI-Stream.h>
#include <SWI-Prolog.h>
typedef int bool;
@@ -46,7 +51,28 @@ typedef int bool;
#endif
#if __YAP_PROLOG__
#include "pl-yap.h"
#if _WIN32
typedef int pthread_t;
#define __WINDOWS__ 1
#else
#include <pthread.h>
#endif
#endif
#define MAXSIGNAL 64
#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 O_PLMT
#define SIG_THREAD_SIGNAL (SIG_PROLOG_OFFSET+3)
#endif
#define SIG_FREECLAUSES (SIG_PROLOG_OFFSET+4)
#define SIG_PLABORT (SIG_PROLOG_OFFSET+5)
/********************************
@@ -59,7 +85,6 @@ typedef int bool;
*********************************/
#include "pl-table.h"
#include "SWI-Stream.h"
#include "pl-os.h"
#include "pl-error.h"
@@ -81,6 +106,19 @@ typedef int bool;
#include "pl-privitf.h"
typedef int simpleMutex;
typedef struct counting_mutex
{ simpleMutex mutex; /* mutex itself */
const char *name; /* name of the mutex */
long count; /* # times locked */
long unlocked; /* # times unlocked */
#ifdef O_CONTENTION_STATISTICS
long collisions; /* # contentions */
#endif
struct counting_mutex *next; /* next of allocated chain */
} counting_mutex;
// numbers
typedef enum
@@ -113,6 +151,54 @@ typedef enum
CLN_DATA /* Remaining data */
} cleanup_status;
typedef struct
{ char *state; /* system's boot file */
char *startup; /* default user startup file */
int local; /* default local stack size (K) */
int global; /* default global stack size (K) */
int trail; /* default trail stack size (K) */
char *goal; /* default initialisation goal */
char *toplevel; /* default top level goal */
bool notty; /* use tty? */
char *arch; /* machine/OS we are using */
char *home; /* systems home directory */
} pl_defaults_t;
typedef enum
{ LDATA_IDLE = 0,
LDATA_SIGNALLED,
LDATA_ANSWERING,
LDATA_ANSWERED
} ldata_status_t;
typedef struct _PL_thread_info_t
{ int pl_tid; /* Prolog thread id */
size_t local_size; /* Stack sizes */
size_t global_size;
size_t trail_size;
size_t stack_size; /* system (C-) stack */
int (*cancel)(int id); /* cancel function */
int open_count; /* for PL_thread_detach_engine() */
bool detached; /* detached thread */
int status; /* PL_THREAD_* */
pthread_t tid; /* Thread identifier */
int has_tid; /* TRUE: tid = valid */
#ifdef __linux__
pid_t pid; /* for identifying */
#endif
#ifdef __WINDOWS__
unsigned long w32id; /* Win32 thread HANDLE */
#endif
struct PL_local_data *thread_data; /* The thread-local data */
module_t module; /* Module for starting goal */
record_t goal; /* Goal to start thread */
record_t return_value; /* Value (term) returned */
atom_t name; /* Name of the thread */
ldata_status_t ldata_status; /* status of forThreadLocalData() */
} PL_thread_info_t;
typedef struct tempfile * TempFile; /* pl-os.c */
typedef struct canonical_dir * CanonicalDir; /* pl-os.c */
typedef struct on_halt * OnHalt; /* pl-os.c */
@@ -124,6 +210,8 @@ typedef struct {
int io_initialised;
cleanup_status cleaning; /* Inside PL_cleanup() */
pl_defaults_t defaults; /* system default settings */
struct
{ Table table; /* global (read-only) features */
} prolog_flag;
@@ -184,6 +272,24 @@ typedef struct {
int _loaded; /* system extensions are loaded */
} foreign;
#ifdef O_PLMT
FreeChunk left_over_pool; /* Left-over from threads */
struct
{ struct _at_exit_goal *exit_goals; /* Global thread_at_exit/1 goals */
int enabled; /* threads are enabled */
Table mutexTable; /* Name --> mutex table */
int mutex_next_id; /* next id for anonymous mutexes */
struct pl_mutex* MUTEX_load; /* The $load mutex */
#ifdef __WINDOWS__
HINSTANCE instance; /* Win32 process instance */
#endif
counting_mutex *mutexes; /* Registered mutexes */
int thread_max; /* Maximum # threads */
PL_thread_info_t **threads; /* Pointers to thread-info */
} thread;
#endif /*O_PLMT*/
} gds_t;
extern gds_t gds;

84
packages/PLStream/pl-yap.c Normal file → Executable file
View File

@@ -653,6 +653,28 @@ X_API int PL_handle_signals(void)
return 0;
}
X_API int
PL_ttymode(IOSTREAM *s)
{ GET_LD
if ( s == Suser_input )
{ if ( !truePrologFlag(PLFLAG_TTY_CONTROL) ) /* -tty in effect */
return PL_NOTTY;
if ( ttymode == TTY_RAW ) /* get_single_char/1 and friends */
return PL_RAWTTY;
return PL_COOKEDTTY; /* cooked (readline) input */
} else
return PL_NOTTY;
}
X_API void
PL_prompt_next(int fd)
{ GET_LD
if ( fd == 0 )
LD->prompt.next = TRUE;
}
/* just a stub for now */
int
warning(const char *fm, ...)
@@ -711,6 +733,68 @@ PL_dispatch(int fd, int wait)
return TRUE;
}
#ifdef _WIN32
#include <windows.h>
#if O_PLMT
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PL_w32thread_raise(DWORD id, int sig)
Sets the signalled mask for a specific Win32 thread. This is a
partial work-around for the lack of proper asynchronous signal
handling in the Win32 platform.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int thread_highest_id = 1;
X_API int
PL_w32thread_raise(DWORD id, int sig)
{ int i;
if ( sig < 0 || sig > MAXSIGNAL )
return FALSE; /* illegal signal */
LOCK();
for(i = 1; i <= thread_highest_id; i++)
{ PL_thread_info_t *info = GD->thread.threads[i];
if ( info && info->w32id == id && info->thread_data )
{ raiseSignal(info->thread_data, sig);
if ( info->w32id )
PostThreadMessage(info->w32id, WM_SIGNALLED, 0, 0L);
UNLOCK();
DEBUG(1, Sdprintf("Signalled %d to thread %d\n", sig, i));
return TRUE;
}
}
UNLOCK();
return FALSE; /* can't find thread */
}
#else
int
PL_w32thread_raise(DWORD id, int sig)
{ return PL_raise(sig);
}
#endif
#endif /*__WINDOWS__*/
int
PL_raise(int sig)
{ GET_LD
if (sig == SIG_PLABORT) {
YAP_signal(0x40); /* YAP_INT_SIGNAL */
return 1;
} else {
return 0;
}
}
extern size_t PL_utf8_strlen(const char *s, size_t len);
X_API size_t

2
packages/meld/meldi.yap
View File

@@ -95,6 +95,7 @@ max(Skel,Arg,Goal) :-
arg(Arg, Skel, A0),
arg(Arg, Goal, AN),
AN =< A0, !,
delete(Skel),
cache(Goal).
max(Skel,_,Goal) :-
clean(Skel),
@@ -106,6 +107,7 @@ min(Skel,Arg,Goal) :-
arg(Arg, Skel, A0),
arg(Arg, Goal, AN),
AN >= A0, !,
delete(Skel),
cache(Goal).
min(Skel,_,Goal) :-
clean(Skel),