diff --git a/C/c_interface.c b/C/c_interface.c index 928cd8138..1f5c46422 100755 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -3253,7 +3253,6 @@ YAP_signal(int sig) Yap_signal(sig); } - X_API int YAP_SetYAPFlag(yap_flag_t flag, int val) { diff --git a/Makefile.in b/Makefile.in index 305987761..d414e9916 100755 --- a/Makefile.in +++ b/Makefile.in @@ -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) diff --git a/console/LGPL/pl-nt.c b/console/LGPL/pl-nt.c new file mode 100755 index 000000000..e903ca6a1 --- /dev/null +++ b/console/LGPL/pl-nt.c @@ -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 /* Needed on VC8 */ +#include +#else +#include /* Needed for MSVC 5&6 */ +#include +#endif + +#include "pl-incl.h" +#include "pl-utf8.h" +#include +#include +#include "pl-ctype.h" +#include +#include +#include "SWI-Stream.h" +#include +#include + + + /******************************* + * 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 + +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__*/ + diff --git a/console/LGPL/pl-ntcon.c b/console/LGPL/pl-ntcon.c new file mode 100755 index 000000000..3e55b78fa --- /dev/null +++ b/console/LGPL/pl-ntcon.c @@ -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 +#include +#include "SWI-Stream.h" +#include "SWI-Prolog.h" +#include + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +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; +} + + diff --git a/console/LGPL/pl-ntconsole.c b/console/LGPL/pl-ntconsole.c new file mode 100755 index 000000000..3a8137933 --- /dev/null +++ b/console/LGPL/pl-ntconsole.c @@ -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 /* Needed on VC8 */ +#include +#else +#include /* Needed for MSVC 5&6 */ +#include +#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( ; smagic == 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; +} diff --git a/console/LGPL/pl-ntmain.c b/console/LGPL/pl-ntmain.c new file mode 100755 index 000000000..3bdf34ab5 --- /dev/null +++ b/console/LGPL/pl-ntmain.c @@ -0,0 +1,1061 @@ +/* $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 +*/ + +#define _UNICODE 1 +#define UNICODE 1 + +#include +#include +#include +#include +#include "SWI-Stream.h" +#include "SWI-Prolog.h" +#include +#ifdef _YAP_NOT_INSTALLED_ +#include "LGPL/swi_console/console.h" +#else +#include "win32/console/console.h" +#endif +#include +#ifdef O_PLMT +#include +#endif + +#include "pl-utf8.c" /* we're not in the libpl.dll module */ + +#ifndef streq +#define streq(s,q) (strcmp((s), (q)) == 0) +#endif + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Main program for running SWI-Prolog from a window. The window provides +X11-xterm like features: scrollback for a predefined number of lines, +cut/paste and the GNU readline library for command-line editing. + +This module combines libpl.dll and plterm.dll with some glue to produce +the final executable swipl-win.exe. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +__declspec(dllexport) rlc_console PL_current_console(); +static int type_error(term_t actual, const char *expected); +static int domain_error(term_t actual, const char *expected); +static HWND create_prolog_hidden_window(rlc_console c); +static int get_chars_arg_ex(int a, term_t t, TCHAR **v); + +#define RLC_PROLOG_WINDOW RLC_VALUE(0) /* GetCurrentThreadID() */ +#define RLC_PROLOG_INPUT RLC_VALUE(1) /* Input stream (IOSTREAM*) */ +#define RLC_PROLOG_OUTPUT RLC_VALUE(2) /* Output stream (IOSTREAM*) */ +#define RLC_PROLOG_ERROR RLC_VALUE(3) /* Error stream (IOSTREAM*) */ +#define RLC_REGISTER RLC_VALUE(4) /* Trap destruction */ + + /******************************* + * CONSOLE ADM * + *******************************/ + +CRITICAL_SECTION mutex; +#define LOCK() EnterCriticalSection(&mutex) +#define UNLOCK() LeaveCriticalSection(&mutex) + +static rlc_console *consoles; /* array of consoles */ +static int consoles_length; /* size of this array */ + +static void +unregisterConsole(uintptr_t data) +{ rlc_console c = (rlc_console)data; + rlc_console *p; + int n; + + LOCK(); + for(p=consoles, n=0; n++handle == c && + PL_ttymode(Suser_input) == PL_RAWTTY ) + { int chr = getkey(c); + TCHAR *tbuf = (TCHAR*)buffer; + + if ( chr == 04 || chr == 26 || chr == -1 ) + { bytes = 0; + } else + { tbuf[0] = chr; + bytes = sizeof(TCHAR); + } + } else + { bytes = rlc_read(c, (TCHAR*)buffer, size/sizeof(TCHAR)); + bytes *= sizeof(TCHAR); + } + + if ( bytes == 0 || buffer[bytes-1] == '\n' ) + PL_prompt_next(0); + + return bytes; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +The user streams for swipl-win.exe run using the 'wchar' encoding. This +means size must be a multiple of sizeof(wchar_t), but not if the user +cheats and either switches the encoding or uses put_byte/1 or similar. +The flushing code will remember `half' characters and re-send them as +more data comes ready. This means however that after a put_byte(X), the +wchar_t stream is out-of-sync and produces unreadable output. We will +therefore pad it with '?' characters to re-sync the stream. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static ssize_t +Srlc_write(void *handle, char *buffer, size_t size) +{ rlc_console c = handle; + ssize_t n; + + n = rlc_write(c, (TCHAR*)buffer, size/sizeof(TCHAR)); + n *= sizeof(TCHAR); + + if ( n < (ssize_t)size && size-n < sizeof(TCHAR) ) + { char buf[sizeof(TCHAR)]; /* Pad to TCHAR */ + size_t i = sizeof(TCHAR) - (size-n); + + memcpy(buf, buffer+n, i); + for(; iflags && SIO_CLOSING ) + { rlc_set(handle, RLC_PROLOG_INPUT, 0L, NULL); + closed++; + } else if ( rlc_get(handle, RLC_PROLOG_OUTPUT, &v) && v && + ((IOSTREAM *)v)->flags && SIO_CLOSING ) + { rlc_set(handle, RLC_PROLOG_OUTPUT, 0L, NULL); + closed++; + } else if ( rlc_get(handle, RLC_PROLOG_ERROR, &v) && v && + ((IOSTREAM *)v)->flags && SIO_CLOSING ) + { rlc_set(handle, RLC_PROLOG_ERROR, 0L, NULL); + } + + if ( closed && + rlc_get(handle, RLC_PROLOG_INPUT, &v) && v == 0L && + rlc_get(handle, RLC_PROLOG_OUTPUT, &v) && v == 0L ) + rlc_close(c); + + return 0; +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +The role of this function is to stop changing the encoding of the plwin +output. We must return -1 for SIO_SETENCODING for this. As we do not +implement any of the other control operations we simply return -1 for +all commands we may be requested to handle. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static int +Srlc_control(void *handle, int cmd, void *closure) +{ return -1; +} + + +static IOFUNCTIONS rlc_functions; + +static void +rlc_bind_terminal(rlc_console c) +{ rlc_functions = *Sinput->functions; + rlc_functions.read = Srlc_read; + rlc_functions.write = Srlc_write; + rlc_functions.close = Srlc_close; + rlc_functions.control = Srlc_control; + + Sinput->functions = &rlc_functions; + Soutput->functions = &rlc_functions; + Serror->functions = &rlc_functions; + + Sinput->handle = c; + Soutput->handle = c; + Serror->handle = c; + + Sinput->encoding = ENC_WCHAR; + Soutput->encoding = ENC_WCHAR; + Serror->encoding = ENC_WCHAR; +} + + +static int +process_console_options(rlc_console_attr *attr, term_t options) +{ term_t tail = PL_copy_term_ref(options); + term_t opt = PL_new_term_ref(); + + while(PL_get_list(tail, opt, tail)) + { atom_t name; + const char *s; + int arity; + + if ( !PL_get_name_arity(opt, &name, &arity) ) + return type_error(opt, "compound"); + s = PL_atom_chars(name); + if ( streq(s, "registry_key") && arity == 1 ) + { TCHAR *key; + + if ( !get_chars_arg_ex(1, opt, &key) ) + return FALSE; + + attr->key = key; + } else + return domain_error(opt, "window_option"); + } + if ( !PL_get_nil(tail) ) + return type_error(tail, "list"); + + return TRUE; +} + + +static void /* handle console destruction */ +free_stream(uintptr_t handle) +{ IOSTREAM *s = (IOSTREAM*) handle; + + Sclose(s); +} + + +static foreign_t +pl_win_open_console(term_t title, term_t input, term_t output, term_t error, + term_t options) +{ rlc_console_attr attr; + rlc_console c; + IOSTREAM *in, *out, *err; + TCHAR *s; + size_t len; + + memset(&attr, 0, sizeof(attr)); + if ( !PL_get_wchars(title, &len, &s, CVT_ALL|BUF_RING) ) + return type_error(title, "text"); + attr.title = (const TCHAR*) s; + + if ( !process_console_options(&attr, options) ) + return FALSE; + + c = rlc_create_console(&attr); + create_prolog_hidden_window(c); /* for sending messages */ + registerConsole(c); + +#define STREAM_COMMON (SIO_TEXT| /* text-stream */ \ + SIO_NOCLOSE| /* do no close on abort */ \ + SIO_ISATTY| /* terminal */ \ + SIO_NOFEOF) /* reset on end-of-file */ + + in = Snew(c, SIO_INPUT|SIO_LBUF|STREAM_COMMON, &rlc_functions); + out = Snew(c, SIO_OUTPUT|SIO_LBUF|STREAM_COMMON, &rlc_functions); + err = Snew(c, SIO_OUTPUT|SIO_NBUF|STREAM_COMMON, &rlc_functions); + + in->position = &in->posbuf; /* record position on same stream */ + out->position = &in->posbuf; + err->position = &in->posbuf; + + in->encoding = ENC_WCHAR; + out->encoding = ENC_WCHAR; + err->encoding = ENC_WCHAR; + + if ( !PL_unify_stream(input, in) || + !PL_unify_stream(output, out) || + !PL_unify_stream(error, err) ) + { Sclose(in); + Sclose(out); + Sclose(err); + rlc_close(c); + + return FALSE; + } + + rlc_set(c, RLC_PROLOG_INPUT, (uintptr_t)in, NULL); + rlc_set(c, RLC_PROLOG_OUTPUT, (uintptr_t)out, NULL); + rlc_set(c, RLC_PROLOG_ERROR, (uintptr_t)err, free_stream); + + return TRUE; +} + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Note: actually rlc_add_history() removes duplicates and empty lines. +Also, read_line() already updates the history. Maybe this should just +return TRUE? This however would not allow for programmatically inserting +things in the history. This shouldn't matter. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static foreign_t +pl_rl_add_history(term_t text) +{ atom_t a; + static atom_t last = 0; + + if ( PL_get_atom(text, &a) ) + { if ( a != last ) + { TCHAR *s; + + if ( last ) + PL_unregister_atom(last); + last = a; + PL_register_atom(last); + + PL_get_wchars(text, NULL, &s, CVT_ATOM); + + rlc_add_history(PL_current_console(), s); + } + + return TRUE; + } + + return FALSE; +} + + +static foreign_t +pl_rl_read_init_file(term_t file) +{ PL_succeed; +} + + + /******************************* + * COMPLETION * + *******************************/ + +static RlcCompleteFunc file_completer; + +static int +prolog_complete(RlcCompleteData data) +{ Line ln = data->line; + + switch(data->call_type) + { case COMPLETE_INIT: + { size_t start = ln->point; + wint_t c; + + if ( !ln->data ) /* we donot want to complete on all atoms */ + return FALSE; + + while(start > 0 && (_istalnum((c=ln->data[start-1])) || c == '_') ) + start--; + if ( start > 0 ) + { _TINT cs = ln->data[start-1]; + + if ( _tcschr(_T("'/\\.~"), cs) ) + return FALSE; /* treat as a filename */ + } + if ( _istlower(ln->data[start]) ) /* Lower, Aplha ...: an atom */ + { size_t patlen = ln->point - start; + + _tcsncpy(data->buf_handle, &ln->data[start], patlen); + data->buf_handle[patlen] = '\0'; + + if ( PL_atom_generator_w(data->buf_handle, + data->candidate, + sizeof(data->candidate)/sizeof(TCHAR), + FALSE) ) + { data->replace_from = (int)start; + data->function = prolog_complete; + return TRUE; + } + } + + return FALSE; + } + case COMPLETE_ENUMERATE: + { if ( PL_atom_generator_w(data->buf_handle, + data->candidate, + sizeof(data->candidate)/sizeof(TCHAR), + TRUE) ) + return TRUE; + + return FALSE; + } + case COMPLETE_CLOSE: + return TRUE; + default: + return FALSE; + } +} + + +static int +do_complete(RlcCompleteData data) +{ if ( prolog_complete(data) ) + return TRUE; + + if ( file_completer ) + return (*file_completer)(data); + return FALSE; +} + + + /******************************* + * CONSOLE STUFF * + *******************************/ + +rlc_console +PL_current_console() +{ if ( Suser_input->functions->read == Srlc_read ) + return Suser_input->handle; + + return NULL; +} + + +foreign_t +pl_window_title(term_t old, term_t new) +{ TCHAR buf[256]; + TCHAR *n; + + if ( !PL_get_wchars(new, NULL, &n, CVT_ALL) ) + return type_error(new, "atom"); + + rlc_title(PL_current_console(), n, buf, sizeof(buf)/sizeof(TCHAR)); + + return PL_unify_wchars(old, PL_ATOM, _tcslen(buf), buf); +} + + +static int +type_error(term_t actual, const char *expected) +{ term_t ex = PL_new_term_ref(); + + PL_unify_term(ex, PL_FUNCTOR_CHARS, "error", 2, + PL_FUNCTOR_CHARS, "type_error", 2, + PL_CHARS, expected, + PL_TERM, actual, + PL_VARIABLE); + + return PL_raise_exception(ex); +} + +static int +domain_error(term_t actual, const char *expected) +{ term_t ex = PL_new_term_ref(); + + PL_unify_term(ex, PL_FUNCTOR_CHARS, "error", 2, + PL_FUNCTOR_CHARS, "domain_error", 2, + PL_CHARS, expected, + PL_TERM, actual, + PL_VARIABLE); + + return PL_raise_exception(ex); +} + +static int +get_chars_arg_ex(int a, term_t t, TCHAR **v) +{ term_t arg = PL_new_term_ref(); + + if ( PL_get_arg(a, t, arg) && + PL_get_wchars(arg, NULL, v, CVT_ALL|BUF_RING) ) + return TRUE; + + return type_error(arg, "text"); +} + + +static int +get_int_arg_ex(int a, term_t t, int *v) +{ term_t arg = PL_new_term_ref(); + + PL_get_arg(a, t, arg); + if ( PL_get_integer(arg, v) ) + return TRUE; + + return type_error(arg, "integer"); +} + + +static int +get_bool_arg_ex(int a, term_t t, int *v) +{ term_t arg = PL_new_term_ref(); + + PL_get_arg(a, t, arg); + if ( PL_get_bool(arg, v) ) + return TRUE; + + return type_error(arg, "boolean"); +} + + +foreign_t +pl_window_pos(term_t options) +{ int x = 0, y = 0, w = 0, h = 0; + HWND z = HWND_TOP; + UINT flags = SWP_NOACTIVATE|SWP_NOZORDER|SWP_NOSIZE|SWP_NOMOVE; + term_t opt = PL_new_term_ref(); + term_t tail = PL_copy_term_ref(options); + + while(PL_get_list(tail, opt, tail)) + { atom_t name; + const char *s; + int arity; + + if ( !PL_get_name_arity(opt, &name, &arity) ) + return type_error(opt, "compound"); + s = PL_atom_chars(name); + if ( streq(s, "position") && arity == 2 ) + { if ( !get_int_arg_ex(1, opt, &x) || + !get_int_arg_ex(2, opt, &y) ) + return FALSE; + flags &= ~SWP_NOMOVE; + } else if ( streq(s, "size") && arity == 2 ) + { if ( !get_int_arg_ex(1, opt, &w) || + !get_int_arg_ex(2, opt, &h) ) + return FALSE; + flags &= ~SWP_NOSIZE; + } else if ( streq(s, "zorder") && arity == 1 ) + { term_t t = PL_new_term_ref(); + char *v; + + PL_get_arg(1, opt, t); + if ( !PL_get_atom_chars(t, &v) ) + return type_error(t, "atom"); + if ( streq(v, "top") ) + z = HWND_TOP; + else if ( streq(v, "bottom") ) + z = HWND_BOTTOM; + else if ( streq(v, "topmost") ) + z = HWND_TOPMOST; + else if ( streq(v, "notopmost") ) + z = HWND_NOTOPMOST; + else + return domain_error(t, "hwnd_insert_after"); + + flags &= ~SWP_NOZORDER; + } else if ( streq(s, "show") && arity == 1 ) + { int v; + + if ( !get_bool_arg_ex(1, opt, &v) ) + return FALSE; + flags &= ~(SWP_SHOWWINDOW|SWP_HIDEWINDOW); + if ( v ) + flags |= SWP_SHOWWINDOW; + else + flags |= SWP_HIDEWINDOW; + } else if ( streq(s, "activate") && arity == 0 ) + { flags &= ~SWP_NOACTIVATE; + } else + return domain_error(opt, "window_option"); + } + if ( !PL_get_nil(tail) ) + return type_error(tail, "list"); + + rlc_window_pos(PL_current_console(), z, x, y, w, h, flags); + + return TRUE; +} + + +static void +call_menu(const TCHAR *name) +{ fid_t fid = PL_open_foreign_frame(); + predicate_t pred = PL_predicate("on_menu", 1, "prolog"); + module_t m = PL_new_module(PL_new_atom("prolog")); + term_t a0 = PL_new_term_ref(); + size_t len = _tcslen(name); + + PL_unify_wchars(a0, PL_ATOM, len, name); + PL_call_predicate(m, PL_Q_NORMAL, pred, a0); + + PL_discard_foreign_frame(fid); +} + + +foreign_t +pl_win_insert_menu_item(foreign_t menu, foreign_t label, foreign_t before) +{ TCHAR *m, *l, *b; + + if ( !PL_get_wchars(menu, NULL, &m, CVT_ATOM) || + !PL_get_wchars(label, NULL, &l, CVT_ATOM) || + !PL_get_wchars(before, NULL, &b, CVT_ATOM) ) + return FALSE; + + if ( _tcscmp(b, _T("-")) == 0 ) + b = NULL; + if ( _tcscmp(l, _T("--")) == 0 ) + l = NULL; /* insert a separator */ + + return rlc_insert_menu_item(PL_current_console(), m, l, b); +} + + +foreign_t +pl_win_insert_menu(foreign_t label, foreign_t before) +{ TCHAR *l, *b; + + if ( !PL_get_wchars(label, NULL, &l, CVT_ATOM) || + !PL_get_wchars(before, NULL, &b, CVT_ATOM) ) + return FALSE; + + if ( _tcscmp(b, _T("-")) == 0 ) + b = NULL; + + return rlc_insert_menu(PL_current_console(), l, b); +} + + /******************************* + * THREADS * + *******************************/ + +#ifdef O_PLMT + +static void +free_interactor(void *closure) +{ PL_thread_destroy_engine(); +} + + +static void * +run_interactor(void *closure) +{ predicate_t pred; + + PL_thread_attach_engine(NULL); + pthread_cleanup_push(free_interactor, NULL); + + + pred = PL_predicate("thread_run_interactor", 0, "user"); + PL_call_predicate(NULL, PL_Q_NORMAL, pred, 0); + + pthread_cleanup_pop(1); + + return NULL; +} + + +static void +create_interactor() +{ pthread_attr_t attr; + pthread_t child; + + pthread_attr_init(&attr); + pthread_create(&child, &attr, run_interactor, NULL); +} + +#endif /*O_PLMT*/ + + /******************************* + * SIGNALS * + *******************************/ + +#define WM_SIGNALLED (WM_USER+1) +#define WM_MENU (WM_USER+2) + +static LRESULT WINAPI +pl_wnd_proc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam) +{ switch(message) + { case WM_SIGNALLED: + PL_handle_signals(); + return 0; + case WM_MENU: + { const TCHAR *name = (const TCHAR *)lParam; + + call_menu(name); + + return 0; + } + } + + return DefWindowProc(hwnd, message, wParam, lParam); +} + + +static TCHAR * +HiddenFrameClass() +{ static TCHAR winclassname[32]; + static WNDCLASS wndClass; + HINSTANCE instance = rlc_hinstance(); + + if ( !winclassname[0] ) + { _stprintf(winclassname, _T("SWI-Prolog-hidden-win%d"), instance); + + wndClass.style = 0; + wndClass.lpfnWndProc = (LPVOID) pl_wnd_proc; + wndClass.cbClsExtra = 0; + wndClass.cbWndExtra = 0; + wndClass.hInstance = instance; + wndClass.hIcon = NULL; + wndClass.hCursor = NULL; + // wndClass.hbrBackground = GetStockObject(WHITE_BRUSH); + wndClass.lpszMenuName = NULL; + wndClass.lpszClassName = winclassname; + + RegisterClass(&wndClass); + } + + return winclassname; +} + + +static void +destroy_hidden_window(uintptr_t hwnd) +{ DestroyWindow((HWND)hwnd); +} + + +static HWND +create_prolog_hidden_window(rlc_console c) +{ uintptr_t hwnd; + + if ( rlc_get(c, RLC_PROLOG_WINDOW, &hwnd) && hwnd ) + return (HWND)hwnd; + + hwnd = (uintptr_t)CreateWindow(HiddenFrameClass(), + _T("SWI-Prolog hidden window"), + 0, + 0, 0, 32, 32, + NULL, NULL, rlc_hinstance(), NULL); + + rlc_set(c, RLC_PROLOG_WINDOW, hwnd, destroy_hidden_window); + + return (HWND)hwnd; +} + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Capturing fatal signals doesn't appear to work inside a DLL, hence we +capture them in the application and tell Prolog to print the stack and +abort. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static void +fatalSignal(int sig) +{ char *name; + + switch(sig) + { case SIGABRT: name = "abort"; break; + case SIGFPE: name = "floating point exeception"; break; + case SIGILL: name = "illegal instruction"; break; + case SIGSEGV: name = "general protection fault"; break; + default: name = "(unknown)"; break; + } + + PL_warning("Trapped signal %d (%s), aborting ...", sig, name); + + PL_action(PL_ACTION_BACKTRACE, (void *)10); + signal(sig, fatalSignal); + PL_action(PL_ACTION_ABORT, NULL); +} + + +static void +initSignals() +{ signal(SIGABRT, fatalSignal); + signal(SIGFPE, fatalSignal); + signal(SIGILL, fatalSignal); + signal(SIGSEGV, fatalSignal); +} + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Callbacks from the console. Trouble is that these routines are called in +the thread updating the console rather than the thread running Prolog. +We can inform Prolog using the hidden window which is in Prolog's +thread. For the interrupt to work if Prolog is working we need to set +the signalled mask in the proper thread. This is accomplished using +PL_w32thread_raise(ID, sig). In the single-threaded version this call +simply calls PL_raise(sig). +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static void +interrupt(rlc_console c, int sig) +{ uintptr_t val; + + if ( rlc_get(c, RLC_APPLICATION_THREAD_ID, &val) ) + { DWORD tid = (DWORD)val; + + PL_w32thread_raise(tid, sig); + if ( rlc_get(c, RLC_PROLOG_WINDOW, &val) ) + { HWND hwnd = (HWND)val; + + PostMessage((HWND)hwnd, WM_SIGNALLED, 0, 0); + } + } +} + + +static void +menu_select(rlc_console c, const TCHAR *name) +{ +#ifdef O_PLMT + if ( _tcscmp(name, _T("&New thread")) == 0 ) + { create_interactor(); + } else +#endif /*O_PLMT*/ + { uintptr_t hwnd; + + if ( rlc_get(c, RLC_PROLOG_WINDOW, &hwnd) ) + PostMessage((HWND)hwnd, WM_MENU, 0, (LONG)name); + } +} + +static LRESULT +message_proc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam) +{ switch( PL_win_message_proc(hwnd, message, wParam, lParam) ) + { case PL_MSG_HANDLED: + return TRUE; + default: + return FALSE; + } +} + + /******************************* + * MAIN * + *******************************/ + + +static void +set_window_title(rlc_console c) +{ TCHAR title[256]; + int v = (int)PL_query(PL_QUERY_VERSION); + int major = v / 10000; + int minor = (v / 100) % 100; + int patch = v % 100; +#ifdef O_PLMT + TCHAR *mt = _T("Multi-threaded, "); +#else + TCHAR *mt = _T(""); +#endif +#ifdef WIN64 + TCHAR *w64 = _T("AMD64, "); /* TBD: IA64 */ +#else + TCHAR *w64 = _T(""); +#endif + + _stprintf(title, _T("SWI-Prolog (%s%sversion %d.%d.%d)"), + w64, mt, major, minor, patch); + + rlc_title(c, title, NULL, 0); +} + + +PL_extension extensions[] = +{ +/*{ "name", arity, function, PL_FA_ },*/ + + { "window_title", 2, pl_window_title, 0 }, + { "$win_insert_menu_item", 3, pl_win_insert_menu_item, 0 }, + { "win_insert_menu", 2, pl_win_insert_menu, 0 }, + { "win_window_pos", 1, pl_window_pos, 0 }, + { NULL, 0, NULL, 0 } +}; + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +win32main() is called back from the plterm.dll main loop to provide the +main for the application. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +static void +install_readline(rlc_console c) +{ rlc_init_history(c, 50); + file_completer = rlc_complete_hook(do_complete); + + PL_register_foreign_in_module("system", "rl_add_history", 1, pl_rl_add_history, 0); + PL_register_foreign_in_module("system", "rl_read_init_file", 1, pl_rl_read_init_file, 0); + + PL_set_prolog_flag("tty_control", PL_BOOL, TRUE); + PL_set_prolog_flag("readline", PL_BOOL, TRUE); +} + +/* destroy the console on exit. Using PL_on_halt() is the clean, but somewhat + uncertain way. using atexit() is more reliable, but we must be sure we don't + do it twice. +*/ + +static rlc_console main_console; + +static void +closeWin(int s, void *a) +{ rlc_console c = a; + +// closeConsoles(); + + if ( c == main_console ) + { main_console = NULL; + rlc_close(c); + } +} + +#define MAX_ARGC 100 + +static size_t +utf8_required_len(const wchar_t *s) +{ size_t l = 0; + char tmp[6]; + char *q; + + for( ; *s; s++) + { q = utf8_put_char(tmp, *s); + l += q-tmp; + } + + return l; +} + + +int +win32main(rlc_console c, int argc, TCHAR **argv) +{ char *av[MAX_ARGC+1]; + int i; + + set_window_title(c); + rlc_bind_terminal(c); + + PL_register_extensions_in_module("system", extensions); + install_readline(c); + PL_action(PL_ACTION_GUIAPP, TRUE); + main_console = c; + PL_on_halt(closeWin, c); + + create_prolog_hidden_window(c); + PL_set_prolog_flag("hwnd", PL_INTEGER, (intptr_t)rlc_hwnd(c)); + rlc_interrupt_hook(interrupt); + rlc_menu_hook(menu_select); + rlc_message_hook(message_proc); + PL_set_prolog_flag("console_menu", PL_BOOL, TRUE); +#ifdef O_PLMT + rlc_insert_menu_item(c, _T("&Run"), _T("&New thread"), NULL); +#endif +#if !defined(O_DEBUG) && !defined(_DEBUG) + initSignals(); +#endif + PL_register_foreign_in_module("system", "win_open_console", 5, + pl_win_open_console, 0); + + if ( argc > MAX_ARGC ) + argc = MAX_ARGC; + for(i=0; i */ + + /******************************* + * 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_ /* 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 */ - /* 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 * *******************************/ diff --git a/include/YapInterface.h b/include/YapInterface.h index f4849c504..eb207f669 100755 --- a/include/YapInterface.h +++ b/include/YapInterface.h @@ -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)); diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index 01552dd8d..3bed29705 100755 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -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) { diff --git a/packages/PLStream/pl-incl.h b/packages/PLStream/pl-incl.h index aa7b99cca..ea1b2b9c4 100755 --- a/packages/PLStream/pl-incl.h +++ b/packages/PLStream/pl-incl.h @@ -7,6 +7,11 @@ #define O_XOS 1 #endif +#ifdef THREADS +#define O_PLMT 1 +#endif + +#include #include 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 #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; diff --git a/packages/PLStream/pl-yap.c b/packages/PLStream/pl-yap.c old mode 100644 new mode 100755 index 7e98fdb0a..620baea9e --- a/packages/PLStream/pl-yap.c +++ b/packages/PLStream/pl-yap.c @@ -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 + +#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 diff --git a/packages/meld/meldi.yap b/packages/meld/meldi.yap index f0ae2d543..98ca6f2a5 100644 --- a/packages/meld/meldi.yap +++ b/packages/meld/meldi.yap @@ -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),