steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Port FFI to win32

cvs
Mackenzie Straight 2004-12-17 17:22:16 +00:00
parent 2f8d25d9e6
commit d9afca04f8
11 changed files with 207 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -22,7 +22,8 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \
native/unix/socket.o \
native/unix/signal.o \
native/unix/read.o \
native/unix/write.o
native/unix/write.o \
native/unix/ffi.o
default:
@echo "Run 'make' with one of the following parameters:"

36
factor.vcproj
View File

@ -19,7 +19,7 @@
<Tool
Name="VCCLCompilerTool"
Optimization="0"
PreprocessorDefinitions="WIN32;_DEBUG;_CONSOLE"
PreprocessorDefinitions="FFI;WIN32"
MinimalRebuild="TRUE"
BasicRuntimeChecks="3"
RuntimeLibrary="5"
@ -70,7 +70,7 @@
GlobalOptimizations="TRUE"
InlineFunctionExpansion="1"
OmitFramePointers="TRUE"
PreprocessorDefinitions="WIN32;NDEBUG;_CONSOLE"
PreprocessorDefinitions="FFI;WIN32"
StringPooling="TRUE"
RuntimeLibrary="4"
EnableFunctionLevelLinking="TRUE"
@ -204,6 +204,21 @@
<Filter
Name="win32"
Filter="">
<File
RelativePath=".\native\win32\ffi.c">
<FileConfiguration
Name="Debug|Win32">
<Tool
Name="VCCLCompilerTool"
ObjectFile="$(IntDir)/$(InputName)2.obj"/>
</FileConfiguration>
<FileConfiguration
Name="Release|Win32">
<Tool
Name="VCCLCompilerTool"
ObjectFile="$(IntDir)/$(InputName)2.obj"/>
</FileConfiguration>
</File>
<File
RelativePath="native\win32\file.c">
</File>
@ -235,6 +250,23 @@
<Filter
Name="unix"
Filter="">
<File
RelativePath=".\native\unix\ffi.c">
<FileConfiguration
Name="Debug|Win32"
ExcludedFromBuild="TRUE">
<Tool
Name="VCCLCompilerTool"
ObjectFile="$(IntDir)/$(InputName)1.obj"/>
</FileConfiguration>
<FileConfiguration
Name="Release|Win32"
ExcludedFromBuild="TRUE">
<Tool
Name="VCCLCompilerTool"
ObjectFile="$(IntDir)/$(InputName)1.obj"/>
</FileConfiguration>
</File>
<File
RelativePath="native\unix\file.c">
<FileConfiguration

2
native/bignum.h
View File

@ -11,7 +11,7 @@ INLINE F_ARRAY* untag_bignum(CELL tagged)
F_FIXNUM to_integer(CELL x);
void box_integer(F_FIXNUM integer);
void box_cell(CELL cell);
F_FIXNUM unbox_integer(void);
DLLEXPORT F_FIXNUM unbox_integer(void);
CELL unbox_cell(void);
F_ARRAY* to_bignum(CELL tagged);
void primitive_to_bignum(void);

4
native/factor.h
View File

@ -75,7 +75,7 @@ CELL cs;
#include <stdbool.h>
#endif
#ifdef FFI
#if defined(FFI) && !defined(WIN32)
#include <dlfcn.h>
#endif /* FFI */
@ -122,9 +122,9 @@ typedef unsigned char BYTE;
#include "float.h"
#include "complex.h"
#include "arithmetic.h"
#include "string.h"
#include "misc.h"
#include "relocate.h"
#include "string.h"
#include "sbuf.h"
#include "port.h"
#include "io.h"

80
native/ffi.c
View File

@ -9,86 +9,6 @@ DLL* untag_dll(CELL tagged)
return (DLL*)UNTAG(tagged);
}
void primitive_dlopen(void)
{
#ifdef FFI
char* path;
void* dllptr;
DLL* dll;
maybe_garbage_collection();
path = unbox_c_string();
dllptr = dlopen(path,RTLD_LAZY);
if(dllptr == NULL)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->dll = dllptr;
dpush(tag_object(dll));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_dlsym(void)
{
#ifdef FFI
DLL* dll = untag_dll(dpop());
void* sym = dlsym(dll->dll,unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dpush(tag_cell((CELL)sym));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_dlsym_self(void)
{
#if defined(FFI)
void* sym = dlsym(NULL,unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dpush(tag_cell((CELL)sym));
#elif defined(WIN32)
void *sym = GetProcAddress(GetModuleHandle(NULL), unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI, tag_object(
from_c_string("bad symbol")));
}
dpush(tag_cell((CELL)sym));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_dlclose(void)
{
#ifdef FFI
DLL* dll = untag_dll(dpop());
if(dlclose(dll->dll) == -1)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dll->dll = NULL;
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
#ifdef FFI
CELL unbox_alien(void)
{

23
native/misc.c
View File

@ -57,3 +57,26 @@ void primitive_random_int(void)
maybe_garbage_collection();
dpush(tag_object(s48_long_to_bignum(rand())));
}
#ifdef WIN32
F_STRING *last_error()
{
char *buffer;
F_STRING *error;
DWORD dw = GetLastError();
FormatMessage(
FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_FROM_SYSTEM,
NULL,
dw,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPTSTR) &buffer,
0, NULL);
error = from_c_string(buffer);
LocalFree(buffer);
return error;
}
#endif

4
native/misc.h
View File

@ -5,3 +5,7 @@ int64_t current_millis(void);
void primitive_millis(void);
void primitive_init_random(void);
void primitive_random_int(void);
#ifdef WIN32
F_STRING *last_error();
#endif

17
native/port.c
View File

@ -67,24 +67,9 @@ void collect_port(F_PORT* port)
#ifdef WIN32
CELL make_io_error(const char* func)
{
char *buffer;
F_STRING *function = from_c_string(func);
F_STRING *error;
DWORD dw = GetLastError();
FormatMessage(
FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_FROM_SYSTEM,
NULL,
dw,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPTSTR) &buffer,
0, NULL);
error = from_c_string(buffer);
LocalFree(buffer);
return cons(tag_object(function),cons(tag_object(error),F));
return cons(tag_object(function),cons(tag_object(last_error()),F));
}
#else
CELL make_io_error(const char* func)

73
native/unix/ffi.c Normal file
View File

@ -0,0 +1,73 @@
#include "../factor.h"
void primitive_dlopen(void)
{
#ifdef FFI
char* path;
void* dllptr;
DLL* dll;
maybe_garbage_collection();
path = unbox_c_string();
dllptr = dlopen(path,RTLD_LAZY);
if(dllptr == NULL)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->dll = dllptr;
dpush(tag_object(dll));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_dlsym(void)
{
#ifdef FFI
DLL* dll = untag_dll(dpop());
void* sym = dlsym(dll->dll,unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dpush(tag_cell((CELL)sym));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_dlsym_self(void)
{
#if defined(FFI)
void* sym = dlsym(NULL,unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dpush(tag_cell((CELL)sym));
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}
void primitive_dlclose(void)
{
#ifdef FFI
DLL* dll = untag_dll(dpop());
if(dlclose(dll->dll) == -1)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())));
}
dll->dll = NULL;
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
}

66
native/win32/ffi.c Normal file
View File

@ -0,0 +1,66 @@
#include "../factor.h"
void primitive_dlopen (void)
{
#ifdef FFI
char *path;
HMODULE module;
DLL *dll;
maybe_garbage_collection();
path = unbox_c_string();
module = LoadLibrary(path);
if (!module)
general_error(ERROR_FFI, tag_object(last_error()));
dll = allot_object(DLL_TYPE, sizeof(DLL));
dll->dll = module;
dpush(tag_object(dll));
#else
general_error(ERROR_FFI_DISABLED, F);
#endif
}
void primitive_dlsym (void)
{
#ifdef FFI
DLL *dll = untag_dll(dpop());
void *sym = GetProcAddress((HMODULE)dll->dll, unbox_c_string());
if (!sym)
general_error(ERROR_FFI, tag_object(last_error()));
dpush(tag_cell((CELL)sym));
#else
general_error(ERROR_FFI_DISABLED, F);
#endif
}
void primitive_dlclose (void)
{
#ifdef FFI
DLL *dll = untag_dll(dpop());
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
#else
general_error(ERROR_FFI_DISABLED, F);
#endif
}
void primitive_dlsym_self (void)
{
#ifdef FFI
void *sym = GetProcAddress(GetModuleHandle(NULL), unbox_c_string());
if(sym == NULL)
{
general_error(ERROR_FFI, tag_object(last_error()));
}
dpush(tag_cell((CELL)sym));
#else
general_error(ERROR_FFI_DISABLED, F);
#endif
}

1
native/win32/io.c
View File

@ -17,6 +17,7 @@ void primitive_add_copy_io_task (void)
void primitive_close (void)
{
F_PORT *port = untag_port(dpop());
CloseHandle((HANDLE)port->fd);
port->closed = true;
}