Merge commit 'erg/master'

release
Slava Pestov 2007-09-27 16:29:17 -04:00
commit bcd1d6b66e
23 changed files with 269 additions and 148 deletions

View File

@ -360,20 +360,25 @@ cell 8 = [
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
[ t ] [ "b" get >boolean ] unit-test
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test "b" get [
[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ ] [ "b" get free ] unit-test [ ] [ "b" get free ] unit-test
] when
[ ] [ "hello world" malloc-char-string "s" set ] unit-test [ t ] [ "hello world" malloc-char-string "s" set ] unit-test
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test "s" get [
[ "hello world" ] [ "s" get <void*> [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
[ ] [ "s" get free ] unit-test [ ] [ "s" get free ] unit-test
] when
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare <void*> ] compile-1 *void* ] unit-test [ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare <void*> ] compile-1 *void* ] unit-test [ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare <void*> ] compile-1 *void* ] unit-test

View File

@ -1,6 +1,7 @@
USING: alien alien.c-types destructors io.windows libc USING: alien alien.c-types destructors io.windows libc
io.nonblocking io.streams.duplex windows.types math io.nonblocking io.streams.duplex windows.types math
windows.kernel32 windows namespaces io.launcher kernel ; windows.kernel32 windows namespaces io.launcher kernel
io.windows.nt.backend ;
IN: io.windows.launcher IN: io.windows.launcher
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed." ! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."

View File

@ -1,9 +1,36 @@
USING: alien alien.c-types arrays assocs combinators continuations USING: alien alien.c-types arrays assocs combinators continuations
destructors io io.backend io.nonblocking io.windows io.windows.nt libc destructors io io.backend io.nonblocking io.windows libc
kernel math namespaces sequences threads tuples.lib windows kernel math namespaces sequences threads tuples.lib windows
windows.errors windows.kernel32 prettyprint ; windows.errors windows.kernel32 prettyprint strings splitting
io.files windows.winsock ;
IN: io.windows.nt.backend IN: io.windows.nt.backend
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "pathname must be a string" throw ] unless
"/" split "\\" join
{
! empty
{ [ dup empty? ] [ "empty path" throw ] }
! .\\foo
{ [ dup ".\\" head? ] [
>r unicode-prefix cwd r> 1 tail 3append
] }
! c:\\
{ [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
! \\\\?\\c:\\foo
{ [ dup unicode-prefix head? ] [ ] }
! foo.txt ..\\foo.txt
{ [ t ] [
[
unicode-prefix % cwd %
dup first CHAR: \\ = [ CHAR: \\ , ] unless %
] "" make
] }
} cond [ "/\\." member? ] rtrim ;
SYMBOL: io-hash SYMBOL: io-hash
TUPLE: io-callback port continuation ; TUPLE: io-callback port continuation ;
@ -63,9 +90,9 @@ C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
GetQueuedCompletionStatus GetQueuedCompletionStatus
] keep swap ; ] keep swap ;
: lookup-callback ( GetQueuedCompletion-args -- callback ? ) : lookup-callback ( GetQueuedCompletion-args -- callback )
GetQueuedCompletionStatusParams-lpOverlapped* *void* GetQueuedCompletionStatusParams-lpOverlapped* *void*
\ io-hash get-global delete-at* ; \ io-hash get-global delete-at drop ;
: wait-for-io ( timeout -- continuation/f ) : wait-for-io ( timeout -- continuation/f )
wait-for-overlapped wait-for-overlapped
@ -73,15 +100,18 @@ C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams
GetLastError dup (expected-io-error?) [ GetLastError dup (expected-io-error?) [
2drop f 2drop f
] [ ] [
(win32-error-string) swap lookup-callback [ dup ERROR_HANDLE_EOF = [
drop lookup-callback [
io-callback-port t swap set-port-eof?
] keep io-callback-continuation
] [
(win32-error-string) swap lookup-callback
[ io-callback-port set-port-error ] keep [ io-callback-port set-port-error ] keep
io-callback-continuation io-callback-continuation
] [
drop "No callback found" 2array throw
] if ] if
] if ] if
] [ ] [
lookup-callback [ io-callback-continuation ] when lookup-callback io-callback-continuation
] if ; ] if ;
: maybe-expire ( io-callbck -- ) : maybe-expire ( io-callbck -- )
@ -99,3 +129,12 @@ M: windows-nt-io io-multiplex ( ms -- )
cancel-timedout cancel-timedout
[ wait-for-io ] [ global [ "error: " write . flush ] bind drop f ] recover [ wait-for-io ] [ global [ "error: " write . flush ] bind drop f ] recover
[ schedule-thread ] when* ; [ schedule-thread ] when* ;
M: windows-nt-io init-io ( -- )
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
master-completion-port \ master-completion-port set
H{ } clone \ io-hash set
init-winsock
] bind ;

View File

@ -1,51 +1,10 @@
! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman. ! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types assocs byte-arrays combinators USE: io.windows
io.backend io.files io.nonblocking io.windows
kernel libc math namespaces qualified sequences
splitting strings threads windows windows.errors windows.winsock
windows.kernel32 ;
QUALIFIED: windows.winsock
IN: io.windows.nt
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "pathname must be a string" throw ] unless
"/" split "\\" join
{
! empty
{ [ dup empty? ] [ "empty path" throw ] }
! .\\foo
{ [ dup ".\\" head? ] [
>r unicode-prefix cwd r> 1 tail 3append
] }
! c:\\
{ [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
! \\\\?\\c:\\foo
{ [ dup unicode-prefix head? ] [ ] }
! foo.txt ..\\foo.txt
{ [ t ] [
[
unicode-prefix % cwd %
dup first CHAR: \\ = [ CHAR: \\ , ] unless %
] "" make
] }
} cond [ "/\\." member? ] rtrim ;
USE: io.windows.nt.backend USE: io.windows.nt.backend
USE: io.windows.nt.files USE: io.windows.nt.files
USE: io.windows.nt.sockets USE: io.windows.nt.sockets
USE: io.backend
USE: namespaces
T{ windows-nt-io } io-backend set-global T{ windows-nt-io } io-backend set-global
M: windows-nt-io init-io ( -- )
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
master-completion-port \ master-completion-port set
H{ } clone \ io-hash set
init-winsock
] bind ;

View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax parser namespaces kernel USING: alien alien.c-types alien.syntax parser namespaces kernel
math windows.types windows.types init assocs sequences opengl.gl ; math windows.types windows.types init assocs sequences opengl.gl
libc ;
IN: windows.opengl32 IN: windows.opengl32
! PIXELFORMATDESCRIPTOR flags ! PIXELFORMATDESCRIPTOR flags

110
misc/install.sh Executable file
View File

@ -0,0 +1,110 @@
#!/bin/bash -e
# Programs returning != 0 will not cause script to exit
set +e
# Case insensitive string comparison
shopt -s nocaseglob
shopt -s nocasematch
ensure_program_installed() {
echo -n "Checking for $1..."
result=`type -p $1`
if ! [[ -n $result ]] ; then
echo "not found!"
echo "Install $1 and try again."
exit 1
fi
echo "found!"
}
check_ret() {
RET=$?
if [[ $RET -ne 0 ]] ; then
echo $1 failed
exit 5
fi
}
ensure_program_installed uname
ensure_program_installed git
ensure_program_installed wget
ensure_program_installed gcc
ensure_program_installed make
GCC_VERSION=`gcc --version`
if [[ $GCC_VERSION == *3.3.* ]] ; then
echo "You have a known buggy version of gcc (3.3)"
echo "Install gcc 3.4 or higher and try again."
exit 1
fi
# OS
OS=
uname_s=`uname -s`
case $uname_s in
CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
*CYGWIN_NT*) OS=windows-nt;;
*CYGWIN*) OS=windows-nt;;
*darwin*) OS=macosx;;
*linux*) OS=linux;;
esac
# Architecture
ARCH=
uname_m=`uname -m`
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
*86) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
esac
WORD=
C_WORD=factor-word-size
# Word size
echo "#include <stdio.h>" > $C_WORD.c
echo "int main() { printf(\"%d\", 8*sizeof(long)); return 0; }" >> $C_WORD.c
gcc -o $C_WORD $C_WORD.c
WORD=$(./$C_WORD)
check_ret $C_WORD
rm -f $C_WORD*
case $OS in
windows-nt) FACTOR_BINARY=factor-nt;;
macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
*) FACTOR_BINARY=factor;;
esac
MAKE_TARGET=$OS-$ARCH-$WORD
BOOT_IMAGE=boot.$ARCH.$WORD.image
echo OS=$OS
echo ARCH=$ARCH
echo WORD=$WORD
echo FACTOR_BINARY=$FACTOR_BINARY
echo MAKE_TARGET=$MAKE_TARGET
echo BOOT_IMAGE=$BOOT_IMAGE
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
echo "OS, ARCH, or WORD is empty. Please report this"
exit 4
fi
echo "Downloading the git repository from factorcode.org..."
git clone git://factorcode.org/git/factor.git
check_ret git
cd factor
check_ret cd
make $MAKE_TARGET
check_ret make
echo "Deleting old images..."
rm $BOOT_IMAGE > /dev/null 2>&1
rm $BOOT_IMAGE.* > /dev/null 2>&1
wget http://factorcode.org/images/latest/$BOOT_IMAGE
check_ret wget
./$FACTOR_BINARY -i=$BOOT_IMAGE

View File

@ -1,5 +1,5 @@
#define FACTOR_CPU_STRING "ppc" #define FACTOR_CPU_STRING "ppc"
#define FASTCALL #define F_FASTCALL
register CELL ds asm("r14"); register CELL ds asm("r14");
register CELL rs asm("r15"); register CELL rs asm("r15");

View File

@ -3,4 +3,5 @@
register CELL ds asm("esi"); register CELL ds asm("esi");
register CELL rs asm("edi"); register CELL rs asm("edi");
#define FASTCALL __attribute__ ((regparm (2))) #define F_FASTCALL __attribute__ ((regparm (2)))

View File

@ -3,4 +3,4 @@
register CELL ds asm("r14"); register CELL ds asm("r14");
register CELL rs asm("r15"); register CELL rs asm("r15");
#define FASTCALL #define F_FASTCALL

View File

@ -2,7 +2,7 @@
mov QUOT_XT_OFFSET(ARG0),XT_REG ; /* Load quot-xt */ \ mov QUOT_XT_OFFSET(ARG0),XT_REG ; /* Load quot-xt */ \
jmp *XT_REG /* Jump to quot-xt */ jmp *XT_REG /* Jump to quot-xt */
DEF(FASTCALL void,c_to_factor,(CELL quot)): DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE PUSH_NONVOLATILE
push ARG0 /* Save quot */ push ARG0 /* Save quot */
@ -17,38 +17,38 @@ DEF(FASTCALL void,c_to_factor,(CELL quot)):
POP_NONVOLATILE POP_NONVOLATILE
ret ret
DEF(FASTCALL void,undefined,(CELL word)): DEF(F_FASTCALL void,undefined,(CELL word)):
mov STACK_REG,ARG1 /* Pass callstack pointer */ mov STACK_REG,ARG1 /* Pass callstack pointer */
jmp MANGLE(undefined_error) /* This throws an error */ jmp MANGLE(undefined_error) /* This throws an error */
DEF(FASTCALL void,dosym,(CELL word)): DEF(F_FASTCALL void,dosym,(CELL word)):
add $CELL_SIZE,DS_REG /* Increment stack pointer */ add $CELL_SIZE,DS_REG /* Increment stack pointer */
mov ARG0,(DS_REG) /* Store word on stack */ mov ARG0,(DS_REG) /* Store word on stack */
ret ret
/* Here we have two entry points. The first one is taken when profiling is /* Here we have two entry points. The first one is taken when profiling is
enabled */ enabled */
DEF(FASTCALL void,docol_profiling,(CELL word)): DEF(F_FASTCALL void,docol_profiling,(CELL word)):
add $CELL_SIZE,PROFILING_OFFSET(ARG0) /* Increment profile-count slot */ add $CELL_SIZE,PROFILING_OFFSET(ARG0) /* Increment profile-count slot */
DEF(FASTCALL void,docol,(CELL word)): DEF(F_FASTCALL void,docol,(CELL word)):
mov WORD_DEF_OFFSET(ARG0),ARG0 /* Load word-def slot */ mov WORD_DEF_OFFSET(ARG0),ARG0 /* Load word-def slot */
JUMP_QUOT JUMP_QUOT
/* We must pass the XT to the quotation in ECX. */ /* We must pass the XT to the quotation in ECX. */
DEF(FASTCALL void,primitive_call,(void)): DEF(F_FASTCALL void,primitive_call,(void)):
mov (DS_REG),ARG0 /* Load quotation from data stack */ mov (DS_REG),ARG0 /* Load quotation from data stack */
sub $CELL_SIZE,DS_REG /* Pop data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */
JUMP_QUOT JUMP_QUOT
/* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the /* We pass the word in EAX and the XT in ECX. Don't mess up EDX, it's the
callstack top parameter to primitives. */ callstack top parameter to primitives. */
DEF(FASTCALL void,primitive_execute,(void)): DEF(F_FASTCALL void,primitive_execute,(void)):
mov (DS_REG),ARG0 /* Load word from data stack */ mov (DS_REG),ARG0 /* Load word from data stack */
sub $CELL_SIZE,DS_REG /* Pop data stack */ sub $CELL_SIZE,DS_REG /* Pop data stack */
mov WORD_XT_OFFSET(ARG0),XT_REG /* Load word-xt slot */ mov WORD_XT_OFFSET(ARG0),XT_REG /* Load word-xt slot */
jmp *XT_REG /* Go */ jmp *XT_REG /* Go */
DEF(FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mov ARG1,STACK_REG /* rewind_to */ mov ARG1,STACK_REG /* rewind_to */
JUMP_QUOT JUMP_QUOT

View File

@ -22,12 +22,12 @@ typedef struct _F_STACK_FRAME
INLINE void flush_icache(CELL start, CELL len) {} INLINE void flush_icache(CELL start, CELL len) {}
FASTCALL void c_to_factor(CELL quot); F_FASTCALL void c_to_factor(CELL quot);
FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to); F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
FASTCALL void undefined(CELL word); F_FASTCALL void undefined(CELL word);
FASTCALL void dosym(CELL word); F_FASTCALL void dosym(CELL word);
FASTCALL void docol_profiling(CELL word); F_FASTCALL void docol_profiling(CELL word);
FASTCALL void docol(CELL word); F_FASTCALL void docol(CELL word);
FASTCALL void lazy_jit_compile(CELL quot); F_FASTCALL void lazy_jit_compile(CELL quot);
void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy); void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);

View File

@ -34,7 +34,7 @@ bool jit_stack_frame_p(F_ARRAY *array)
return false; return false;
} }
FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack) F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack)
{ {
stack_chain->callstack_top = stack; stack_chain->callstack_top = stack;

View File

@ -1,2 +1,2 @@
DLLEXPORT FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack); DLLEXPORT F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack);
XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset); XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);

View File

@ -179,11 +179,6 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
return NULL; return NULL;
} }
void memory_signal_handler_impl(void)
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{ {
signal_fault_addr = (CELL)siginfo->si_addr; signal_fault_addr = (CELL)siginfo->si_addr;
@ -191,11 +186,6 @@ void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl; UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl;
} }
void misc_signal_handler_impl(void)
{
signal_error(signal_number,signal_callstack_top);
}
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{ {
signal_number = signal; signal_number = signal;

View File

@ -23,31 +23,39 @@ DEFINE_PRIMITIVE(cd)
SetCurrentDirectory(unbox_u16_string()); SetCurrentDirectory(unbox_u16_string());
} }
void seh_call(void (*func)(), exception_handler_t *handler) long exception_handler(PEXCEPTION_POINTERS pe)
{ {
exception_record_t record; PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
asm volatile("mov %%fs:0, %0" : "=r" (record.next_handler)); CONTEXT *c = (CONTEXT*)pe->ContextRecord;
asm volatile("mov %0, %%fs:0" : : "r" (&record));
record.handler_func = handler;
func();
asm volatile("mov %0, %%fs:0" : "=r" (record.next_handler));
}
long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch) if(in_code_heap_p(c->Eip))
{ signal_callstack_top = (void*)c->Esp;
if(rec->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
memory_protection_error(
rec->ExceptionInformation[1],
native_stack_pointer());
else if(rec->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO
|| rec->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
general_error(ERROR_DIVIDE_BY_ZERO,F,F,false,(void*)rec->ExceptionInformation[1]);
else else
signal_error(11,(void*)rec->ExceptionInformation[1]); signal_callstack_top = NULL;
return -1; /* unreachable */
if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
{
signal_fault_addr = e->ExceptionInformation[1];
c->Eip = (CELL)memory_signal_handler_impl;
}
else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO
|| e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
{
signal_number = ERROR_DIVIDE_BY_ZERO;
c->Eip = (CELL)divide_by_zero_signal_handler_impl;
}
else
{
signal_number = 11;
c->Eip = (CELL)misc_signal_handler_impl;
}
return EXCEPTION_CONTINUE_EXECUTION;
} }
void run_toplevel(void) void c_to_factor_toplevel(CELL quot)
{ {
seh_call(run, exception_handler); AddVectoredExceptionHandler(0, (void*)exception_handler);
c_to_factor(quot);
RemoveVectoredExceptionHandler((void*)exception_handler);
} }

View File

@ -1,3 +1,6 @@
#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
#ifndef UNICODE #ifndef UNICODE
#define UNICODE #define UNICODE
#endif #endif
@ -10,3 +13,13 @@ typedef char F_SYMBOL;
#define FACTOR_OS_STRING "windows" #define FACTOR_OS_STRING "windows"
#define FACTOR_DLL L"factor-nt.dll" #define FACTOR_DLL L"factor-nt.dll"
#define FACTOR_DLL_NAME "factor-nt.dll" #define FACTOR_DLL_NAME "factor-nt.dll"
void c_to_factor_toplevel(CELL quot);
CELL signal_number;
CELL signal_fault_addr;
void *signal_callstack_top;
void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);

View File

@ -51,8 +51,8 @@ void ffi_dlopen (F_DLL *dll, bool error)
{ {
dll->dll = NULL; dll->dll = NULL;
if(error) if(error)
general_error(ERROR_FFI,F, general_error(ERROR_FFI,F,F,
tag_object(get_error_message())); (void*)tag_object(get_error_message()));
else else
return; return;
} }
@ -204,9 +204,3 @@ void sleep_millis(DWORD msec)
{ {
Sleep(msec); Sleep(msec);
} }
void run(void)
{
interpreter();
}

View File

@ -49,20 +49,5 @@ s64 current_millis(void);
INLINE void reset_stdio(void) {} INLINE void reset_stdio(void) {}
/* SEH support. Proceed with caution. */ long exception_handler(PEXCEPTION_POINTERS pe);
typedef long exception_handler_t(
PEXCEPTION_RECORD rec, void *frame, void *context, void *dispatch);
typedef struct exception_record
{
struct exception_record *next_handler;
void *handler_func;
} exception_record_t;
long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch);
DECLARE_PRIMITIVE(open_file);
DECLARE_PRIMITIVE(stat);
DECLARE_PRIMITIVE(read_dir);
DECLARE_PRIMITIVE(cwd);
DECLARE_PRIMITIVE(cd);

View File

@ -14,19 +14,19 @@ DEFINE_PRIMITIVE(name)
Becomes Becomes
FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top)
{ {
stack_chain->callstack_top = callstack_top; stack_chain->callstack_top = callstack_top;
... CODE ... ... CODE ...
} }
On x86, FASTCALL expands into a GCC declaration which forces the two parameters On x86, F_FASTCALL expands into a GCC declaration which forces the two
to be passed in registers. This simplifies the quotation compiler and support parameters to be passed in registers. This simplifies the quotation compiler
code in cpu-x86.S. */ and support code in cpu-x86.S. */
#define DEFINE_PRIMITIVE(name) \ #define DEFINE_PRIMITIVE(name) \
INLINE void primitive_##name##_impl(void); \ INLINE void primitive_##name##_impl(void); \
\ \
FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \
{ \ { \
stack_chain->callstack_top = callstack_top; \ stack_chain->callstack_top = callstack_top; \
primitive_##name##_impl(); \ primitive_##name##_impl(); \
@ -36,4 +36,4 @@ code in cpu-x86.S. */
/* Prototype for header files */ /* Prototype for header files */
#define DECLARE_PRIMITIVE(name) \ #define DECLARE_PRIMITIVE(name) \
FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top)

View File

@ -197,7 +197,7 @@ void not_implemented_error(void)
} }
/* This function is called from the undefined function in cpu_*.S */ /* This function is called from the undefined function in cpu_*.S */
FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top) F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top)
{ {
stack_chain->callstack_top = callstack_top; stack_chain->callstack_top = callstack_top;
general_error(ERROR_UNDEFINED_WORD,word,F,NULL); general_error(ERROR_UNDEFINED_WORD,word,F,NULL);
@ -244,6 +244,21 @@ void divide_by_zero_error(F_STACK_FRAME *native_stack)
general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack); general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack);
} }
void memory_signal_handler_impl(void)
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
void divide_by_zero_signal_handler_impl(void)
{
divide_by_zero_error(signal_callstack_top);
}
void misc_signal_handler_impl(void)
{
signal_error(signal_number,signal_callstack_top);
}
DEFINE_PRIMITIVE(throw) DEFINE_PRIMITIVE(throw)
{ {
uncurry(dpop()); uncurry(dpop());

View File

@ -197,7 +197,7 @@ void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged); void type_error(CELL type, CELL tagged);
void not_implemented_error(void); void not_implemented_error(void);
FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
DECLARE_PRIMITIVE(throw); DECLARE_PRIMITIVE(throw);

View File

@ -19,7 +19,7 @@ void fix_stacks(void)
} }
/* called before entry into Factor code. */ /* called before entry into Factor code. */
FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
{ {
stack_chain->callstack_bottom = callstack_bottom; stack_chain->callstack_bottom = callstack_bottom;
} }

View File

@ -48,7 +48,7 @@ CELL ds_size, rs_size;
void reset_datastack(void); void reset_datastack(void);
void reset_retainstack(void); void reset_retainstack(void);
void fix_stacks(void); void fix_stacks(void);
FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
DLLEXPORT void save_stacks(void); DLLEXPORT void save_stacks(void);
DLLEXPORT void nest_stacks(void); DLLEXPORT void nest_stacks(void);
DLLEXPORT void unnest_stacks(void); DLLEXPORT void unnest_stacks(void);