klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

commit 9ff76bef82f9fb4dd120f3e74697e9a87af12f52
parent 0cad9cd9407592834a01d4a7f43479382d96e2e4
Author: Oto Havle <havleoto@gmail.com>
Date:   Sat,  5 Nov 2011 19:59:18 +0100

Added FFI for win32

Diffstat:
Msrc/Makefile | 12+++++++++---
Asrc/examples/ffi-win32.k | 81+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msrc/kgffi.c | 76+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----
3 files changed, 161 insertions(+), 8 deletions(-)

diff --git a/src/Makefile b/src/Makefile @@ -18,6 +18,8 @@ LIBS= -lm $(MYLIBS) # Set USE_LIBFFI=1 (or other nonempty string) to enable libffi-dependent # code. USE_LIBFFI= +MINGW_LIBFFI_CFLAGS = -I/usr/local/lib/libffi-3.0.10/include +MINGW_LIBFFI_LDFLAGS = -L/usr/local/lib/ MYCFLAGS= MYLDFLAGS= @@ -60,7 +62,7 @@ o: $(ALL_O) a: $(ALL_A) $(KRN_A): $(CORE_O) $(LIB_O) - $(AR) $@ $? + $(AR) $@ $? $(MINGW_LDFLAGS) $(RANLIB) $@ $(KRN_T): $(KRN_O) $(KRN_A) @@ -94,8 +96,12 @@ generic: mingw: $(MAKE) "KRN_A=klisp01.dll" "KRN_T=klisp.exe" \ - "AR=$(CC) -shared -o" "RANLIB=strip --strip-unneeded" \ - "MYCFLAGS=-DKLISP_BUILD_AS_DLL" "MYLIBS=" "MYLDFLAGS=-s" klisp.exe + "AR=$(CC) -shared -o" \ + "RANLIB=strip --strip-unneeded" \ + "MYCFLAGS=-DKLISP_BUILD_AS_DLL $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1 $(MINGW_LIBFFI_CFLAGS))" \ + "MYLIBS=$(if $(USE_LIBFFI), $(MINGW_LIBFFI_LDFLAGS) -lffi.dll)" \ + "MINGW_LDFLAGS=$(if $(USE_LIBFFI), $(MINGW_LIBFFI_LDFLAGS) -lffi.dll)" \ + "MYLDFLAGS=-s" klisp.exe #lisp_use_posix isn't used right now... # TEMP: rename read() and write() here to avoid name conflicts with foreign code posix: diff --git a/src/examples/ffi-win32.k b/src/examples/ffi-win32.k @@ -0,0 +1,81 @@ +;; +;; Windows API FFI example +;; See ffi.k for general info. +;; +;; usage: +;; 1) compile and install libffi 3.0.10 +;; 2) set PATH correctly so libffi-5.dll can be found +;; 3) compile klisp: make mingw USE_LIBFFI=1 +;; 4) run test script: ....\src> klisp examples/ffi-win32.k +;; + +($define! kernel32 (ffi-load-library "kernel32")) +($define! abi "FFI_STDCALL") + +($define! DWORD "uint32") +($define! BOOL "sint") + +($define! dword-void (ffi-make-call-interface abi DWORD ())) +($define! u64-void (ffi-make-call-interface abi "uint64" ())) + +($define! GetLastError (ffi-make-applicative kernel32 "GetLastError" dword-void)) +($define! GetTickCount (ffi-make-applicative kernel32 "GetTickCount" dword-void)) +($define! GetTickCount64 (ffi-make-applicative kernel32 "GetTickCount64" u64-void)) + +(display "Testing GetTickCount(), GetTickCount64() ... ") +(write (list (GetTickCount) (GetTickCount64))) +(newline) + +($define! (DWORD-size DWORD-alignment DWORD-ref DWORD-set!) + (ffi-type-suite DWORD)) + +($define! (charptr-size charptr-alignment charptr-ref charptr-set!) + (ffi-type-suite "string")) + +($define! blob->list + ($lambda (blob index len) + ($if (>? len 0) + (cons + (blob-u8-ref blob index) + (blob->list blob (+ 1 index) (- len 1))) + ()))) + +($define! blob->string + ($lambda (blob offset len) + (list->string (map integer->char (blob->list blob offset len))))) + +($define! advapi32 (ffi-load-library "advapi32")) + +($define! GetUserName + ($let + ( (win32-GetUserName (ffi-make-applicative advapi32 "GetUserNameA" + (ffi-make-call-interface abi BOOL (list "pointer" "pointer")))) + ((DWORD-size DWORD-alignment DWORD-ref DWORD-set!) + (ffi-type-suite DWORD))) + ($lambda () + ($let ((buffer (make-blob 256)) (lenbuf (make-blob 4))) + (DWORD-set! lenbuf (blob-length buffer)) + (win32-GetUserName buffer lenbuf) + (blob->string buffer 0 (- (DWORD-ref lenbuf) 1)))))) + +(display "Testing GetUserName()...") +(write (GetUserName)) +(newline) + +($define! user32 (ffi-load-library "user32")) + +($define! HWND "pointer") +($define! UINT "uint32") +($define! MB_OK 0) + +($define! MessageBox + ($let + ( (win32-MessageBox (ffi-make-applicative user32 "MessageBoxA" + (ffi-make-call-interface abi "sint" (list HWND "string" "string" UINT))))) + ($lambda (text caption) + (win32-MessageBox () text caption MB_OK)))) + +(display "Testing MessageBox()...") +(MessageBox "FFI test" "klisp") +(display "done.") +(newline) diff --git a/src/kgffi.c b/src/kgffi.c @@ -4,13 +4,30 @@ ** See Copyright Notice in klisp.h */ +/* + * Detect dynamic linking facilities. + * + */ +#if !defined(KLISP_USE_POSIX) && defined(_WIN32) +# define KGFFI_WIN32 true +#else +# define KGFFI_DLFCN true +#endif + #include <assert.h> #include <stdlib.h> #include <stdbool.h> #include <stdint.h> #include <string.h> -#include <dlfcn.h> +#if KGFFI_DLFCN +# include <dlfcn.h> +#elif KGFFI_WIN32 +# include <windows.h> +#else +# error +#endif + #include <ffi.h> #include "imath.h" @@ -341,6 +358,24 @@ static ffi_codec_t ffi_codecs[] = { #undef SIMPLE_TYPE }; +#ifdef KGFFI_WIN32 +static TValue ffi_win32_error_message(klisp_State *K, DWORD dwMessageId) +{ + LPTSTR s; + if (0 == FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, + NULL, + dwMessageId, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + &s, 0, NULL)) { + return kstring_new_b_imm(K, "Unknown error"); + } else { + TValue v = kstring_new_b_imm(K, s); + LocalFree(s); + return v; + } +} +#endif + void ffi_load_library(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) { @@ -354,6 +389,7 @@ void ffi_load_library(klisp_State *K, TValue *xparams, get_opt_tpar(K, "ffi-load-library", K_TSTRING, &filename) ? kstring_buf(filename) : NULL; +#if KGFFI_DLFCN void *handle = dlopen(filename_c, RTLD_LAZY | RTLD_GLOBAL); if (handle == NULL) { krooted_tvs_push(K, filename); @@ -363,7 +399,19 @@ void ffi_load_library(klisp_State *K, TValue *xparams, 2, filename, err); return; } - +#elif KGFFI_WIN32 + /* TODO: unicode and wide character issues ??? */ + HMODULE handle = LoadLibrary(filename_c); + if (handle == NULL) { + krooted_tvs_push(K, filename); + TValue err = ffi_win32_error_message(K, GetLastError()); + klispE_throw_simple_with_irritants(K, "couldn't load dynamic library", + 2, filename, err); + return; + } +#else +# error +#endif TValue key = xparams[0]; krooted_tvs_push(K, key); @@ -384,6 +432,12 @@ static ffi_abi tv2ffi_abi(klisp_State *K, TValue v) { if (!strcmp("FFI_DEFAULT_ABI", kstring_buf(v))) { return FFI_DEFAULT_ABI; + } else if (!strcmp("FFI_SYSV", kstring_buf(v))) { + return FFI_SYSV; +#if KGFFI_WIN32 + } else if (!strcmp("FFI_STDCALL", kstring_buf(v))) { + return FFI_STDCALL; +#endif } else { klispE_throw_simple_with_irritants(K, "unsupported FFI ABI", 1, v); return 0; @@ -516,7 +570,7 @@ void do_ffi_call(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) } assert(offset == p->buffer_size); if (!ttisnil(tail)) { - klispE_throw_simple(K, "too much arguments"); + klispE_throw_simple(K, "too many arguments"); return; } @@ -548,14 +602,14 @@ void ffi_make_applicative(klisp_State *K, TValue *xparams, return; } - void *handle = pvalue(kcar(kget_enc_val(lib_tv))); TValue lib_name = kcdr(kget_enc_val(lib_tv)); assert(ttisstring(lib_name)); +#if KGFFI_DLFCN + void *handle = pvalue(kcar(kget_enc_val(lib_tv))); (void) dlerror(); void *funptr = dlsym(handle, kstring_buf(name_tv)); const char *err_c = dlerror(); - if (err_c) { krooted_tvs_push(K, name_tv); krooted_tvs_push(K, lib_name); @@ -568,6 +622,18 @@ void ffi_make_applicative(klisp_State *K, TValue *xparams, klispE_throw_simple_with_irritants(K, "symbol is NULL", 2, lib_name, name_tv); } +#elif KGFFI_WIN32 + HMODULE handle = pvalue(kcar(kget_enc_val(lib_tv))); + void *funptr = GetProcAddress(handle, kstring_buf(name_tv)); + if (NULL == funptr) { + TValue err = ffi_win32_error_message(K, GetLastError()); + klispE_throw_simple_with_irritants(K, "couldn't find symbol", + 3, lib_name, name_tv, err); + return; + } +#else +# error +#endif TValue app = kmake_applicative(K, do_ffi_call, 2, p2tv(funptr), cif_tv);