Merge branch 'master' of git://github.com/slavapestov/factor
Erik Charlebois
commit
e1849518ec
48
Nmakefile
48
Nmakefile
|
|
@ -1,15 +1,27 @@
|
|||
!IF DEFINED(DEBUG)
|
||||
LINK_FLAGS = /nologo /DEBUG shell32.lib
|
||||
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
|
||||
!ELSE
|
||||
LINK_FLAGS = /nologo /safeseh:no shell32.lib
|
||||
!IF DEFINED(PLATFORM)
|
||||
|
||||
LINK_FLAGS = /nologo shell32.lib
|
||||
CL_FLAGS = /nologo /O2 /W3
|
||||
|
||||
!IF DEFINED(DEBUG)
|
||||
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
|
||||
CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
|
||||
!ENDIF
|
||||
|
||||
!IF "$(PLATFORM)" == "x86-32"
|
||||
LINK_FLAGS = $(LINK_FLAGS) /safeseh
|
||||
PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
|
||||
!ELSEIF "$(PLATFORM)" == "x86-64"
|
||||
PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
|
||||
!ENDIF
|
||||
|
||||
ML_FLAGS = /nologo /safeseh
|
||||
|
||||
EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
|
||||
|
||||
DLL_OBJS = vm\os-windows-nt.obj \
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm\os-windows.obj \
|
||||
vm\os-windows-nt.obj \
|
||||
vm\aging_collector.obj \
|
||||
vm\alien.obj \
|
||||
vm\arrays.obj \
|
||||
|
|
@ -60,11 +72,12 @@ DLL_OBJS = vm\os-windows-nt.obj \
|
|||
.c.obj:
|
||||
cl $(CL_FLAGS) /Fo$@ /c $<
|
||||
|
||||
.asm.obj:
|
||||
ml $(ML_FLAGS) /Fo$@ /c $<
|
||||
|
||||
.rs.res:
|
||||
rc $<
|
||||
|
||||
all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
|
||||
|
||||
libfactor-ffi-test.dll: vm/ffi_test.obj
|
||||
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
|
||||
|
||||
|
|
@ -77,6 +90,23 @@ factor.com: $(EXE_OBJS) $(DLL_OBJS)
|
|||
factor.exe: $(EXE_OBJS) $(DLL_OBJS)
|
||||
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
|
||||
|
||||
all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
|
||||
|
||||
!ENDIF
|
||||
|
||||
default:
|
||||
@echo Usage: nmake /f Nmakefile platform
|
||||
@echo Where platform is one of:
|
||||
@echo x86-32
|
||||
@echo x86-64
|
||||
@exit 1
|
||||
|
||||
x86-32:
|
||||
nmake PLATFORM=x86-32 /f Nmakefile all
|
||||
|
||||
x86-64:
|
||||
nmake PLATFORM=x86-64 /f Nmakefile all
|
||||
|
||||
clean:
|
||||
del vm\*.obj
|
||||
del factor.lib
|
||||
|
|
@ -85,6 +115,6 @@ clean:
|
|||
del factor.dll
|
||||
del factor.dll.lib
|
||||
|
||||
.PHONY: all clean
|
||||
.PHONY: all default x86-32 x86-64 clean
|
||||
|
||||
.SUFFIXES: .rs
|
||||
|
|
|
|||
|
|
@ -330,6 +330,3 @@ IN: bootstrap.x86
|
|||
jit-delete-current-context
|
||||
jit-start-context
|
||||
] \ (start-context-and-delete) define-sub-primitive
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -1,14 +1,8 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
|
||||
layouts parser sequences ;
|
||||
USING: kernel parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
|
||||
: jit-update-seh ( ctx-reg -- ) drop ;
|
||||
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -5,50 +5,32 @@ cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
|
|||
locals parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
|
||||
: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
|
||||
: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
|
||||
: tib-segment ( -- ) FS ;
|
||||
: tib-temp ( -- reg ) EAX ;
|
||||
|
||||
: jit-save-tib ( -- )
|
||||
tib-exception-list-offset [] FS PUSH
|
||||
tib-stack-base-offset [] FS PUSH
|
||||
tib-stack-limit-offset [] FS PUSH ;
|
||||
|
||||
: jit-restore-tib ( -- )
|
||||
tib-stack-limit-offset [] FS POP
|
||||
tib-stack-base-offset [] FS POP
|
||||
tib-exception-list-offset [] FS POP ;
|
||||
|
||||
:: jit-update-tib ( ctx-reg -- )
|
||||
! There's a redundant load here because we're not allowed
|
||||
! to clobber ctx-reg. Clobbers EAX.
|
||||
! Save callstack base in TIB
|
||||
EAX ctx-reg context-callstack-seg-offset [+] MOV
|
||||
EAX EAX segment-end-offset [+] MOV
|
||||
tib-stack-base-offset [] EAX FS MOV
|
||||
! Save callstack limit in TIB
|
||||
EAX ctx-reg context-callstack-seg-offset [+] MOV
|
||||
EAX EAX segment-start-offset [+] MOV
|
||||
tib-stack-limit-offset [] EAX FS MOV ;
|
||||
<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call
|
||||
|
||||
: jit-install-seh ( -- )
|
||||
! Create a new exception record and store it in the TIB.
|
||||
! Clobbers tib-temp.
|
||||
! Align stack
|
||||
ESP 3 bootstrap-cells ADD
|
||||
! Exception handler address filled in by callback.cpp
|
||||
0 PUSH rc-absolute-cell rt-exception-handler jit-rel
|
||||
tib-temp 0 MOV rc-absolute-cell rt-exception-handler jit-rel
|
||||
tib-temp PUSH
|
||||
! No next handler
|
||||
0 PUSH
|
||||
! This is the new exception handler
|
||||
tib-exception-list-offset [] ESP FS MOV ;
|
||||
tib-exception-list-offset [] ESP tib-segment MOV ;
|
||||
|
||||
:: jit-update-seh ( ctx-reg -- )
|
||||
! Load exception record structure that jit-install-seh
|
||||
! created from the bottom of the callstack. Clobbers EAX.
|
||||
EAX ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
EAX bootstrap-cell ADD
|
||||
! created from the bottom of the callstack.
|
||||
! Clobbers tib-temp.
|
||||
tib-temp ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
tib-temp bootstrap-cell ADD
|
||||
! Store exception record in TIB.
|
||||
tib-exception-list-offset [] EAX FS MOV ;
|
||||
tib-exception-list-offset [] tib-temp tib-segment MOV ;
|
||||
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -26,11 +26,6 @@ IN: bootstrap.x86
|
|||
: fixnum>slot@ ( -- ) temp0 1 SAR ;
|
||||
: rex-length ( -- n ) 1 ;
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
|
||||
|
||||
: jit-call ( name -- )
|
||||
RAX 0 MOV rc-absolute-cell jit-dlsym
|
||||
RAX CALL ;
|
||||
|
|
@ -238,7 +233,9 @@ IN: bootstrap.x86
|
|||
RSP ctx-reg context-callstack-top-offset [+] MOV
|
||||
|
||||
! Load new ds, rs registers
|
||||
jit-restore-context ;
|
||||
jit-restore-context
|
||||
|
||||
ctx-reg jit-update-tib ;
|
||||
|
||||
: jit-pop-context-and-param ( -- )
|
||||
arg1 ds-reg [] MOV
|
||||
|
|
@ -293,6 +290,3 @@ IN: bootstrap.x86
|
|||
jit-delete-current-context
|
||||
jit-start-context
|
||||
] \ (start-context-and-delete) define-sub-primitive
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -12,5 +12,6 @@ IN: bootstrap.x86
|
|||
: arg3 ( -- reg ) RDX ;
|
||||
: arg4 ( -- reg ) RCX ;
|
||||
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ vocabs sequences cpu.x86.assembler parser
|
|||
cpu.x86.assembler.operands ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
DEFER: stack-reg
|
||||
|
||||
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
|
||||
: nv-regs ( -- seq ) { RBX RSI RDI R12 R13 R14 R15 } ;
|
||||
: arg1 ( -- reg ) RCX ;
|
||||
|
|
@ -12,5 +14,12 @@ IN: bootstrap.x86
|
|||
: arg3 ( -- reg ) R8 ;
|
||||
: arg4 ( -- reg ) R9 ;
|
||||
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
: tib-segment ( -- ) GS ;
|
||||
: tib-temp ( -- reg ) R11 ;
|
||||
|
||||
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
|
||||
: jit-update-seh ( ctx-reg -- ) drop ;
|
||||
|
||||
<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
|
||||
layouts ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
DEFER: stack-reg
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
|
||||
: jit-update-seh ( ctx-reg -- ) drop ;
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private compiler.constants
|
||||
cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
|
||||
locals parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
|
||||
: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
|
||||
: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
|
||||
|
||||
: jit-save-tib ( -- )
|
||||
tib-exception-list-offset [] tib-segment PUSH
|
||||
tib-stack-base-offset [] tib-segment PUSH
|
||||
tib-stack-limit-offset [] tib-segment PUSH ;
|
||||
|
||||
: jit-restore-tib ( -- )
|
||||
tib-stack-limit-offset [] tib-segment POP
|
||||
tib-stack-base-offset [] tib-segment POP
|
||||
tib-exception-list-offset [] tib-segment POP ;
|
||||
|
||||
:: jit-update-tib ( ctx-reg -- )
|
||||
! There's a redundant load here because we're not allowed
|
||||
! to clobber ctx-reg. Clobbers tib-temp.
|
||||
! Save callstack base in TIB
|
||||
tib-temp ctx-reg context-callstack-seg-offset [+] MOV
|
||||
tib-temp tib-temp segment-end-offset [+] MOV
|
||||
tib-stack-base-offset [] tib-temp tib-segment MOV
|
||||
! Save callstack limit in TIB
|
||||
tib-temp ctx-reg context-callstack-seg-offset [+] MOV
|
||||
tib-temp tib-temp segment-start-offset [+] MOV
|
||||
tib-stack-limit-offset [] tib-temp tib-segment MOV ;
|
||||
|
|
@ -270,20 +270,20 @@ M: no-current-vocab summary
|
|||
|
||||
M: no-word-error summary
|
||||
name>>
|
||||
"No word named ``"
|
||||
"'' found in current vocabulary search path" surround ;
|
||||
"No word named “"
|
||||
"” found in current vocabulary search path" surround ;
|
||||
|
||||
M: no-word-error error. summary print ;
|
||||
|
||||
M: no-word-in-vocab summary
|
||||
[ vocab>> ] [ word>> ] bi
|
||||
[ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ;
|
||||
[ "No word named “" % % "” found in “" % % "” vocabulary" % ] "" make ;
|
||||
|
||||
M: no-word-in-vocab error. summary print ;
|
||||
|
||||
M: ambiguous-use-error summary
|
||||
words>> first name>>
|
||||
"More than one vocabulary defines a word named ``" "''" surround ;
|
||||
"More than one vocabulary defines a word named “" "”" surround ;
|
||||
|
||||
M: ambiguous-use-error error. summary print ;
|
||||
|
||||
|
|
@ -306,6 +306,9 @@ M: bad-inheritance summary
|
|||
M: not-in-a-method-error summary
|
||||
drop "call-next-method can only be called in a method definition" ;
|
||||
|
||||
M: version-control-merge-conflict summary
|
||||
drop "Version control merge conflict in source code" ;
|
||||
|
||||
GENERIC: expected>string ( obj -- str )
|
||||
|
||||
M: f expected>string drop "end of input" ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences assocs arrays continuations
|
||||
destructors combinators kernel threads concurrency.messaging
|
||||
concurrency.mailboxes concurrency.promises io.files io.files.info
|
||||
io.directories io.pathnames io.monitors debugger fry ;
|
||||
io.directories io.pathnames io.monitors io.monitors.private
|
||||
debugger fry ;
|
||||
IN: io.monitors.recursive
|
||||
|
||||
! Simulate recursive monitors on platforms that don't have them
|
||||
|
|
@ -71,12 +72,14 @@ M: recursive-monitor dispose*
|
|||
] with with each ;
|
||||
|
||||
: pump-loop ( -- )
|
||||
receive dup +stop+ eq? [
|
||||
drop stop-pump
|
||||
] [
|
||||
[ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
|
||||
pump-loop
|
||||
] if ;
|
||||
receive {
|
||||
{ [ dup +stop+ eq? ] [ drop stop-pump ] }
|
||||
{ [ dup monitor-disposed eq? ] [ drop ] }
|
||||
[
|
||||
[ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
|
||||
pump-loop
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: monitor-ready ( error/t -- )
|
||||
monitor tget ready>> fulfill ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: ui.gadgets help.markup help.syntax arrays ;
|
|||
IN: ui.gadgets.grids
|
||||
|
||||
ARTICLE: "ui-grid-layout" "Grid layouts"
|
||||
"Grid gadgets layout their children in a rectangular grid."
|
||||
"Grid gadgets layout their children in a rectangular grid. The grid is represented as a sequence of sequences of gadgets. Every child sequence is a row of gadgets. Every row must have an equal number of gadgets in it."
|
||||
{ $subsections grid }
|
||||
"Creating grids from a fixed set of gadgets:"
|
||||
{ $subsections <grid> }
|
||||
|
|
|
|||
|
|
@ -758,25 +758,25 @@ CONSTANT: D3DSHADER_ADDRMODE_FORCE_DWORD HEX: 7fffffff
|
|||
CONSTANT: D3DVS_SWIZZLE_SHIFT 16
|
||||
CONSTANT: D3DVS_SWIZZLE_MASK HEX: 00FF0000
|
||||
|
||||
: D3DVS_X_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT shift ; inline
|
||||
: D3DVS_X_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT shift ; inline
|
||||
: D3DVS_X_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT shift ; inline
|
||||
: D3DVS_X_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT shift ; inline
|
||||
CONSTANT: D3DVS_X_X $[ 0 16 shift ]
|
||||
CONSTANT: D3DVS_X_Y $[ 1 16 shift ]
|
||||
CONSTANT: D3DVS_X_Z $[ 2 16 shift ]
|
||||
CONSTANT: D3DVS_X_W $[ 3 16 shift ]
|
||||
|
||||
: D3DVS_Y_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
|
||||
: D3DVS_Y_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
|
||||
: D3DVS_Y_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
|
||||
: D3DVS_Y_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
|
||||
CONSTANT: D3DVS_Y_X $[ 0 16 2 + shift ]
|
||||
CONSTANT: D3DVS_Y_Y $[ 1 16 2 + shift ]
|
||||
CONSTANT: D3DVS_Y_Z $[ 2 16 2 + shift ]
|
||||
CONSTANT: D3DVS_Y_W $[ 3 16 2 + shift ]
|
||||
|
||||
: D3DVS_Z_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
|
||||
: D3DVS_Z_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
|
||||
: D3DVS_Z_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
|
||||
: D3DVS_Z_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
|
||||
CONSTANT: D3DVS_Z_X $[ 0 16 4 + shift ]
|
||||
CONSTANT: D3DVS_Z_Y $[ 1 16 4 + shift ]
|
||||
CONSTANT: D3DVS_Z_Z $[ 2 16 4 + shift ]
|
||||
CONSTANT: D3DVS_Z_W $[ 3 16 4 + shift ]
|
||||
|
||||
: D3DVS_W_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
|
||||
: D3DVS_W_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
|
||||
: D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
|
||||
: D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
|
||||
CONSTANT: D3DVS_W_X $[ 0 16 6 + shift ]
|
||||
CONSTANT: D3DVS_W_Y $[ 1 16 6 + shift ]
|
||||
CONSTANT: D3DVS_W_Z $[ 2 16 6 + shift ]
|
||||
CONSTANT: D3DVS_W_W $[ 3 16 6 + shift ]
|
||||
|
||||
CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W }
|
||||
|
||||
|
|
@ -786,20 +786,20 @@ CONSTANT: D3DSP_SRCMOD_SHIFT 24
|
|||
CONSTANT: D3DSP_SRCMOD_MASK HEX: 0F000000
|
||||
|
||||
TYPEDEF: int D3DSHADER_PARAM_SRCMOD_TYPE
|
||||
: D3DSPSM_NONE ( -- n ) 0 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_NEG ( -- n ) 1 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_BIAS ( -- n ) 2 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_BIASNEG ( -- n ) 3 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_SIGN ( -- n ) 4 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_SIGNNEG ( -- n ) 5 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_COMP ( -- n ) 6 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_X2 ( -- n ) 7 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_X2NEG ( -- n ) 8 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_DZ ( -- n ) 9 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_DW ( -- n ) 10 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_ABS ( -- n ) 11 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_ABSNEG ( -- n ) 12 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
: D3DSPSM_NOT ( -- n ) 13 D3DSP_SRCMOD_SHIFT shift ; inline
|
||||
CONSTANT: D3DSPSM_NONE $[ 0 24 shift ]
|
||||
CONSTANT: D3DSPSM_NEG $[ 1 24 shift ]
|
||||
CONSTANT: D3DSPSM_BIAS $[ 2 24 shift ]
|
||||
CONSTANT: D3DSPSM_BIASNEG $[ 3 24 shift ]
|
||||
CONSTANT: D3DSPSM_SIGN $[ 4 24 shift ]
|
||||
CONSTANT: D3DSPSM_SIGNNEG $[ 5 24 shift ]
|
||||
CONSTANT: D3DSPSM_COMP $[ 6 24 shift ]
|
||||
CONSTANT: D3DSPSM_X2 $[ 7 24 shift ]
|
||||
CONSTANT: D3DSPSM_X2NEG $[ 8 24 shift ]
|
||||
CONSTANT: D3DSPSM_DZ $[ 9 24 shift ]
|
||||
CONSTANT: D3DSPSM_DW $[ 10 24 shift ]
|
||||
CONSTANT: D3DSPSM_ABS $[ 11 24 shift ]
|
||||
CONSTANT: D3DSPSM_ABSNEG $[ 12 24 shift ]
|
||||
CONSTANT: D3DSPSM_NOT $[ 13 24 shift ]
|
||||
CONSTANT: D3DSPSM_FORCE_DWORD HEX: 7fffffff
|
||||
|
||||
: D3DPS_VERSION ( major minor -- n )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien alien.c-types alien.strings alien.syntax arrays
|
||||
byte-arrays kernel literals math sequences windows.types
|
||||
windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
|
||||
classes.struct windows.com.syntax init literals ;
|
||||
classes.struct windows.com.syntax init ;
|
||||
FROM: alien.c-types => short ;
|
||||
IN: windows.winsock
|
||||
|
||||
|
|
|
|||
|
|
@ -89,6 +89,12 @@ IN: bootstrap.syntax
|
|||
"read-only"
|
||||
"call("
|
||||
"execute("
|
||||
"<<<<<<"
|
||||
"======"
|
||||
">>>>>>"
|
||||
"<<<<<<<"
|
||||
"======="
|
||||
">>>>>>>"
|
||||
} [ "syntax" create drop ] each
|
||||
|
||||
"t" "syntax" lookup define-symbol
|
||||
|
|
|
|||
|
|
@ -35,6 +35,24 @@ IN: combinators.tests
|
|||
[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
|
||||
[ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
|
||||
|
||||
[ [ ] call( -- * ) ] must-fail
|
||||
|
||||
: compile-call(-test-2 ( -- ) [ ] call( -- * ) ;
|
||||
|
||||
[ compile-call(-test-2 ] [ wrong-values? ] must-fail-with
|
||||
|
||||
: compile-call(-test-3 ( quot -- ) call( -- * ) ;
|
||||
|
||||
[ [ ] compile-call(-test-3 ] [ wrong-values? ] must-fail-with
|
||||
|
||||
: compile-execute(-test-3 ( a -- ) \ . execute( value -- * ) ;
|
||||
|
||||
[ 10 compile-execute(-test-3 ] [ wrong-values? ] must-fail-with
|
||||
|
||||
: compile-execute(-test-4 ( a word -- ) execute( value -- * ) ;
|
||||
|
||||
[ 10 \ . compile-execute(-test-4 ] [ wrong-values? ] must-fail-with
|
||||
|
||||
! Compiled
|
||||
: cond-test-1 ( obj -- str )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -26,15 +26,17 @@ ERROR: wrong-values quot call-site ;
|
|||
! We can't USE: effects here so we forward reference slots instead
|
||||
SLOT: in
|
||||
SLOT: out
|
||||
SLOT: terminated?
|
||||
|
||||
: call-effect ( quot effect -- )
|
||||
! Don't use fancy combinators here, since this word always
|
||||
! runs unoptimized
|
||||
[ datastack ] 2dip
|
||||
2dup [
|
||||
[ dip ] dip
|
||||
dup in>> length swap out>> length
|
||||
check-datastack
|
||||
[ [ datastack ] dip dip ] dip
|
||||
dup terminated?>> [ 2drop f ] [
|
||||
dup in>> length swap out>> length
|
||||
check-datastack
|
||||
] if
|
||||
] 2dip rot
|
||||
[ 2drop ] [ wrong-values ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -575,19 +575,51 @@ HELP: if
|
|||
{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
|
||||
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: io kernel math ;"
|
||||
"10 3 < [ \"Math is broken\" print ] [ \"Math is good\" print ] if"
|
||||
"Math is good"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: when
|
||||
{ $values { "?" "a generalized boolean" } { "true" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel math prettyprint ;"
|
||||
"-5 dup 0 < [ 3 + ] when ."
|
||||
"-2"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: unless
|
||||
{ $values { "?" "a generalized boolean" } { "false" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel math prettyprint sequences ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
"CONSTANT: american-cities {"
|
||||
" \"San Francisco\""
|
||||
" \"Los Angeles\""
|
||||
" \"New York\""
|
||||
"}"
|
||||
""
|
||||
": add-tax ( price city -- price' )"
|
||||
" american-cities member? [ 1.1 * ] unless ;"
|
||||
""
|
||||
"123 \"Ottawa\" add-tax ."
|
||||
"135.3"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: if*
|
||||
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..b )" } } { "false" { $quotation "( ..a -- ..b )" } } }
|
||||
|
|
@ -596,7 +628,31 @@ $nl
|
|||
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
|
||||
$nl
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
|
||||
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } }
|
||||
{ $examples
|
||||
"Notice how in this example, the same value is tested by the conditional, and then used in the true branch; the false branch does not need to drop the value because of how " { $link if* } " works:"
|
||||
{ $example
|
||||
"USING: assocs io kernel math.parser ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
": curry-price ( meat -- price )
|
||||
{
|
||||
{ \"Beef\" 10 }
|
||||
{ \"Chicken\" 12 }
|
||||
{ \"Lamb\" 13 }
|
||||
} at ;
|
||||
|
||||
: order-curry ( meat -- )
|
||||
curry-price [
|
||||
\"Your order will be \" write
|
||||
number>string write
|
||||
\" dollars.\" write
|
||||
] [ \"Invalid order.\" print ] if* ;"
|
||||
""
|
||||
"\"Deer\" order-curry"
|
||||
"Invalid order."
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: when*
|
||||
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } }
|
||||
|
|
|
|||
|
|
@ -207,3 +207,5 @@ print-use-hook [ [ ] ] initialize
|
|||
|
||||
: ?run-file ( path -- )
|
||||
dup exists? [ run-file ] [ drop ] if ;
|
||||
|
||||
ERROR: version-control-merge-conflict ;
|
||||
|
|
|
|||
|
|
@ -257,4 +257,12 @@ IN: bootstrap.syntax
|
|||
"call(" [ \ call-effect parse-call( ] define-core-syntax
|
||||
|
||||
"execute(" [ \ execute-effect parse-call( ] define-core-syntax
|
||||
|
||||
"<<<<<<<" [ version-control-merge-conflict ] define-core-syntax
|
||||
"=======" [ version-control-merge-conflict ] define-core-syntax
|
||||
">>>>>>>" [ version-control-merge-conflict ] define-core-syntax
|
||||
|
||||
"<<<<<<" [ version-control-merge-conflict ] define-core-syntax
|
||||
"======" [ version-control-merge-conflict ] define-core-syntax
|
||||
">>>>>>" [ version-control-merge-conflict ] define-core-syntax
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -21,20 +21,6 @@ IN: cursors.tests
|
|||
[ B{ } ] [ [ { } [ , ] each ] B{ } make ] unit-test
|
||||
[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } [ 2 * ] map ] unit-test
|
||||
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[
|
||||
[
|
||||
{ { "roses" "lutefisk" } { "tulips" "lox" } }
|
||||
[ ": " glue , ] assoc-each
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[
|
||||
{ { "roses" "lutefisk" } { "tulips" "lox" } }
|
||||
[ ": " glue ] { } assoc>map
|
||||
] unit-test
|
||||
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[
|
||||
[
|
||||
|
|
@ -65,8 +51,14 @@ IN: cursors.tests
|
|||
[ { 2 4 6 8 10 } ] [ { 1 2 3 4 5 } compile-test-map ] unit-test
|
||||
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[ [ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ] { } make ] unit-test
|
||||
[
|
||||
[ H{ { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc-each ]
|
||||
{ } make natural-sort
|
||||
] unit-test
|
||||
|
||||
[ { "roses: lutefisk" "tulips: lox" } ]
|
||||
[ { { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map ] unit-test
|
||||
[
|
||||
H{ { "roses" "lutefisk" } { "tulips" "lox" } } compile-test-assoc>map
|
||||
natural-sort
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -61,13 +61,19 @@ ERROR: invalid-cursor cursor ;
|
|||
|
||||
MIXIN: input-cursor
|
||||
|
||||
GENERIC: cursor-value ( cursor -- value )
|
||||
GENERIC: cursor-key-value ( cursor -- key value )
|
||||
<PRIVATE
|
||||
GENERIC: cursor-value-unsafe ( cursor -- value )
|
||||
GENERIC: cursor-key-value-unsafe ( cursor -- key value )
|
||||
PRIVATE>
|
||||
M: input-cursor cursor-value-unsafe cursor-value ; inline
|
||||
M: input-cursor cursor-value
|
||||
dup cursor-valid? [ cursor-value-unsafe ] [ invalid-cursor ] if ; inline
|
||||
M: input-cursor cursor-key-value-unsafe cursor-key-value ; inline
|
||||
M: input-cursor cursor-key-value
|
||||
dup cursor-valid? [ cursor-key-value-unsafe ] [ invalid-cursor ] if ; inline
|
||||
|
||||
: cursor-key ( cursor -- key ) cursor-key-value drop ;
|
||||
: cursor-value ( cursor -- key ) cursor-key-value nip ;
|
||||
|
||||
: cursor-key-unsafe ( cursor -- key ) cursor-key-value-unsafe drop ;
|
||||
: cursor-value-unsafe ( cursor -- key ) cursor-key-value-unsafe nip ;
|
||||
|
||||
!
|
||||
! output cursors
|
||||
|
|
@ -155,7 +161,7 @@ M: numeric-cursor cursor>= [ value>> ] bi@ >= ; inline
|
|||
|
||||
INSTANCE: numeric-cursor input-cursor
|
||||
|
||||
M: numeric-cursor cursor-value value>> ; inline
|
||||
M: numeric-cursor cursor-key-value value>> dup ; inline
|
||||
|
||||
!
|
||||
! linear cursor
|
||||
|
|
@ -278,8 +284,8 @@ M: sequence-cursor cursor-distance ( cursor cursor -- n )
|
|||
|
||||
INSTANCE: sequence-cursor input-cursor
|
||||
|
||||
M: sequence-cursor cursor-value-unsafe [ n>> ] [ seq>> ] bi nth-unsafe ; inline
|
||||
M: sequence-cursor cursor-value [ n>> ] [ seq>> ] bi nth ; inline
|
||||
M: sequence-cursor cursor-key-value-unsafe [ n>> dup ] [ seq>> ] bi nth-unsafe ; inline
|
||||
M: sequence-cursor cursor-key-value [ n>> dup ] [ seq>> ] bi nth ; inline
|
||||
|
||||
INSTANCE: sequence-cursor output-cursor
|
||||
|
||||
|
|
@ -362,13 +368,9 @@ M: forward-cursor new-sequence-cursor
|
|||
over map-as ; inline
|
||||
|
||||
!
|
||||
! assoc cursors
|
||||
! assoc combinators
|
||||
!
|
||||
|
||||
MIXIN: assoc-cursor
|
||||
|
||||
GENERIC: cursor-key-value ( cursor -- key value )
|
||||
|
||||
: -assoc- ( quot -- quot' )
|
||||
'[ cursor-key-value @ ] ; inline
|
||||
|
||||
|
|
@ -380,11 +382,6 @@ GENERIC: cursor-key-value ( cursor -- key value )
|
|||
: assoc>map ( ... assoc quot: ( ... k v -- ... newx ) exemplar -- ... newcontainer )
|
||||
[ assoc- ] dip -map-as ; inline
|
||||
|
||||
INSTANCE: input-cursor assoc-cursor
|
||||
|
||||
M: input-cursor cursor-key-value
|
||||
cursor-value-unsafe first2 ; inline
|
||||
|
||||
!
|
||||
! hashtable cursor
|
||||
!
|
||||
|
|
@ -421,16 +418,11 @@ M: hashtable-cursor inc-cursor ( cursor -- cursor' )
|
|||
[ hashtable>> dup array>> ] [ n>> 2 + ] bi
|
||||
(inc-hashtable-cursor) <hashtable-cursor> ; inline
|
||||
|
||||
INSTANCE: hashtable-cursor assoc-cursor
|
||||
|
||||
M: hashtable-cursor cursor-key-value
|
||||
[ n>> ] [ hashtable>> array>> ] bi
|
||||
[ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
|
||||
|
||||
INSTANCE: hashtable-cursor input-cursor
|
||||
|
||||
M: hashtable-cursor cursor-value-unsafe
|
||||
cursor-key-value 2array ; inline
|
||||
M: hashtable-cursor cursor-key-value-unsafe
|
||||
[ n>> ] [ hashtable>> array>> ] bi
|
||||
[ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi ; inline
|
||||
|
||||
INSTANCE: hashtable container
|
||||
|
||||
|
|
@ -472,7 +464,7 @@ M: zip-cursor cursor-distance-hint ( cursor cursor -- n )
|
|||
M: zip-cursor inc-cursor ( cursor -- cursor' )
|
||||
[ keys>> inc-cursor ] [ values>> inc-cursor ] bi <zip-cursor> ; inline
|
||||
|
||||
INSTANCE: zip-cursor assoc-cursor
|
||||
INSTANCE: zip-cursor input-cursor
|
||||
|
||||
M: zip-cursor cursor-key-value
|
||||
[ keys>> cursor-value-unsafe ] [ values>> cursor-value-unsafe ] bi ; inline
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: mason.child.tests
|
||||
USING: mason.child mason.config tools.test namespaces io kernel sequences ;
|
||||
|
||||
[ { "nmake" "/f" "nmakefile" } ] [
|
||||
[ { "nmake" "/f" "nmakefile" "x86-32" } ] [
|
||||
[
|
||||
"winnt" target-os set
|
||||
"x86.32" target-cpu set
|
||||
|
|
|
|||
|
|
@ -4,13 +4,20 @@ USING: accessors arrays calendar combinators.short-circuit fry
|
|||
continuations debugger io.directories io.files io.launcher
|
||||
io.pathnames io.encodings.ascii kernel make mason.common mason.config
|
||||
mason.platform mason.report mason.notify namespaces sequences
|
||||
quotations macros system combinators ;
|
||||
quotations macros system combinators splitting ;
|
||||
IN: mason.child
|
||||
|
||||
: nmake-cmd ( -- args )
|
||||
{ "nmake" "/f" "nmakefile" }
|
||||
target-cpu get "." split "-" join suffix ;
|
||||
|
||||
: gnu-make-cmd ( -- args )
|
||||
gnu-make platform 2array ;
|
||||
|
||||
: make-cmd ( -- args )
|
||||
{
|
||||
{ [ target-os get "winnt" = ] [ { "nmake" "/f" "nmakefile" } ] }
|
||||
[ gnu-make platform 2array ]
|
||||
{ [ target-os get "winnt" = ] [ nmake-cmd ] }
|
||||
[ gnu-make-cmd ]
|
||||
} cond ;
|
||||
|
||||
: make-vm ( -- )
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
PLAF_DLL_OBJS += vm/os-windows-nt-x86.32.o
|
||||
DLL_PATH=http://factorcode.org/dlls
|
||||
WINDRES=windres
|
||||
include vm/Config.windows.nt
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
PLAF_DLL_OBJS += vm/os-windows-nt-x86.64.o
|
||||
DLL_PATH=http://factorcode.org/dlls/64
|
||||
CC=$(WIN64_PATH)-gcc.exe
|
||||
WINDRES=$(WIN64_PATH)-windres.exe
|
||||
|
|
|
|||
|
|
@ -7,8 +7,14 @@ code_heap::code_heap(cell size)
|
|||
{
|
||||
if(size > ((u64)1 << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
|
||||
seg = new segment(align_page(size),true);
|
||||
if(!seg) fatal_error("Out of memory in heap allocator",size);
|
||||
allocator = new free_list_allocator<code_block>(size,seg->start);
|
||||
if(!seg) fatal_error("Out of memory in code_heap constructor",size);
|
||||
|
||||
cell start = seg->start + seh_area_size;
|
||||
|
||||
allocator = new free_list_allocator<code_block>(seg->end - start,start);
|
||||
|
||||
/* See os-windows-nt-x86.64.cpp for seh_area usage */
|
||||
seh_area = (char *)seg->start;
|
||||
}
|
||||
|
||||
code_heap::~code_heap()
|
||||
|
|
|
|||
|
|
@ -1,10 +1,19 @@
|
|||
namespace factor
|
||||
{
|
||||
|
||||
#if defined(WINDOWS) && defined(FACTOR_64)
|
||||
const cell seh_area_size = 1024;
|
||||
#else
|
||||
const cell seh_area_size = 0;
|
||||
#endif
|
||||
|
||||
struct code_heap {
|
||||
/* The actual memory area */
|
||||
segment *seg;
|
||||
|
||||
/* Memory area reserved for SEH. Only used on Windows */
|
||||
char *seh_area;
|
||||
|
||||
/* Memory allocator */
|
||||
free_list_allocator<code_block> *allocator;
|
||||
|
||||
|
|
|
|||
|
|
@ -258,7 +258,7 @@ void factor_vm::load_image(vm_parameters *p)
|
|||
init_objects(&h);
|
||||
|
||||
cell data_offset = data->tenured->start - h.data_relocation_base;
|
||||
cell code_offset = code->seg->start - h.code_relocation_base;
|
||||
cell code_offset = code->allocator->start - h.code_relocation_base;
|
||||
|
||||
fixup_data(data_offset,code_offset);
|
||||
fixup_code(data_offset,code_offset);
|
||||
|
|
@ -285,7 +285,7 @@ bool factor_vm::save_image(const vm_char *saving_filename, const vm_char *filena
|
|||
h.version = image_version;
|
||||
h.data_relocation_base = data->tenured->start;
|
||||
h.data_size = data->tenured->occupied_space();
|
||||
h.code_relocation_base = code->seg->start;
|
||||
h.code_relocation_base = code->allocator->start;
|
||||
h.code_size = code->allocator->occupied_space();
|
||||
|
||||
h.true_object = true_object;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
#include "master.hpp"
|
||||
|
||||
namespace factor
|
||||
{
|
||||
|
||||
void factor_vm::c_to_factor_toplevel(cell quot)
|
||||
{
|
||||
/* 32-bit Windows SEH is set up in basis/cpu/x86/32/winnt/bootstrap.factor */
|
||||
c_to_factor(quot);
|
||||
}
|
||||
|
||||
}
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
#include "master.hpp"
|
||||
|
||||
namespace factor {
|
||||
|
||||
typedef unsigned char UBYTE;
|
||||
|
||||
const UBYTE UNW_FLAG_EHANDLER = 0x1;
|
||||
|
||||
struct UNWIND_INFO {
|
||||
UBYTE Version:3;
|
||||
UBYTE Flags:5;
|
||||
UBYTE SizeOfProlog;
|
||||
UBYTE CountOfCodes;
|
||||
UBYTE FrameRegister:4;
|
||||
UBYTE FrameOffset:4;
|
||||
ULONG ExceptionHandler;
|
||||
ULONG ExceptionData[1];
|
||||
};
|
||||
|
||||
struct seh_data {
|
||||
UNWIND_INFO unwind_info;
|
||||
RUNTIME_FUNCTION func;
|
||||
UBYTE handler[32];
|
||||
};
|
||||
|
||||
void factor_vm::c_to_factor_toplevel(cell quot)
|
||||
{
|
||||
/* The annoying thing about Win64 SEH is that the offsets in
|
||||
* function tables are 32-bit integers, and the exception handler
|
||||
* itself must reside between the start and end pointers, so
|
||||
* we stick everything at the beginning of the code heap and
|
||||
* generate a small trampoline that jumps to the real
|
||||
* exception handler. */
|
||||
|
||||
seh_data *seh_area = (seh_data *)code->seh_area;
|
||||
cell base = code->seg->start;
|
||||
|
||||
/* Should look at generating this with the Factor assembler */
|
||||
|
||||
/* mov rax,0 */
|
||||
seh_area->handler[0] = 0x48;
|
||||
seh_area->handler[1] = 0xb8;
|
||||
seh_area->handler[2] = 0x0;
|
||||
seh_area->handler[3] = 0x0;
|
||||
seh_area->handler[4] = 0x0;
|
||||
seh_area->handler[5] = 0x0;
|
||||
seh_area->handler[6] = 0x0;
|
||||
seh_area->handler[7] = 0x0;
|
||||
seh_area->handler[8] = 0x0;
|
||||
seh_area->handler[9] = 0x0;
|
||||
|
||||
/* jmp rax */
|
||||
seh_area->handler[10] = 0x48;
|
||||
seh_area->handler[11] = 0xff;
|
||||
seh_area->handler[12] = 0xe0;
|
||||
|
||||
/* Store address of exception handler in the operand of the 'mov' */
|
||||
cell handler = (cell)&factor::exception_handler;
|
||||
memcpy(&seh_area->handler[2],&handler,sizeof(cell));
|
||||
|
||||
UNWIND_INFO *unwind_info = &seh_area->unwind_info;
|
||||
unwind_info->Version = 1;
|
||||
unwind_info->Flags = UNW_FLAG_EHANDLER;
|
||||
unwind_info->SizeOfProlog = 0;
|
||||
unwind_info->CountOfCodes = 0;
|
||||
unwind_info->FrameRegister = 0;
|
||||
unwind_info->FrameOffset = 0;
|
||||
unwind_info->ExceptionHandler = (DWORD)((cell)&seh_area->handler[0] - base);
|
||||
unwind_info->ExceptionData[0] = 0;
|
||||
|
||||
RUNTIME_FUNCTION *func = &seh_area->func;
|
||||
func->BeginAddress = 0;
|
||||
func->EndAddress = (DWORD)(code->seg->end - base);
|
||||
func->UnwindData = (DWORD)((cell)&seh_area->unwind_info - base);
|
||||
|
||||
if(!RtlAddFunctionTable(func,1,base))
|
||||
fatal_error("RtlAddFunctionTable() failed",0);
|
||||
|
||||
c_to_factor(quot);
|
||||
|
||||
if(!RtlDeleteFunctionTable(func))
|
||||
fatal_error("RtlDeleteFunctionTable() failed",0);
|
||||
}
|
||||
|
||||
}
|
||||
|
|
@ -84,19 +84,14 @@ LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c,
|
|||
break;
|
||||
}
|
||||
|
||||
return ExceptionContinueExecution;
|
||||
return 0;
|
||||
}
|
||||
|
||||
LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
|
||||
VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
|
||||
{
|
||||
return current_vm()->exception_handler(e,frame,c,dispatch);
|
||||
}
|
||||
|
||||
void factor_vm::c_to_factor_toplevel(cell quot)
|
||||
{
|
||||
c_to_factor(quot);
|
||||
}
|
||||
|
||||
void factor_vm::open_console()
|
||||
{
|
||||
}
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ typedef char symbol_char;
|
|||
|
||||
#define FACTOR_DLL NULL
|
||||
|
||||
LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
|
||||
VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
|
||||
|
||||
// SSE traps raise these exception codes, which are defined in internal NT headers
|
||||
// but not winbase.h
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
#include "os-windows-ce.hpp"
|
||||
#include "os-windows.hpp"
|
||||
#elif defined(WINNT)
|
||||
#include "os-windows-nt.hpp"
|
||||
#include "os-windows.hpp"
|
||||
#include "os-windows-nt.hpp"
|
||||
|
||||
#if defined(FACTOR_AMD64)
|
||||
#include "os-windows-nt.64.hpp"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
.386
|
||||
.model flat
|
||||
exception_handler proto
|
||||
.safeseh exception_handler
|
||||
end
|
||||
Loading…
Reference in New Issue