Merge branch 'master' of git://github.com/slavapestov/factor

Nmakefile

@@ -1,15 +1,27 @@
-!IF DEFINED(DEBUG)
+!IF DEFINED(PLATFORM)
-LINK_FLAGS = /nologo /DEBUG shell32.lib
+
-CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
+LINK_FLAGS = /nologo shell32.lib
-!ELSE
-LINK_FLAGS = /nologo /safeseh:no 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

basis/cpu/x86/32/bootstrap.factor

@@ -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

basis/cpu/x86/32/unix/bootstrap.factor

@@ -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
+USING: kernel parser sequences ;
-layouts parser sequences ;
 IN: bootstrap.x86
 
-: jit-save-tib ( -- ) ;
+<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
-: jit-restore-tib ( -- ) ;
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
-: jit-update-tib ( ctx-reg -- ) drop ;
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call
-: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
-: jit-update-seh ( ctx-reg -- ) drop ;
-
-<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
-call

basis/cpu/x86/32/winnt/bootstrap.factor

@@ -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-segment ( -- ) FS ;
-: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
+: tib-temp ( -- reg ) EAX ;
-: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
 
-: jit-save-tib ( -- )
+<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call
-    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 ;
 
 : 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.
+    ! created from the bottom of the callstack.
-    EAX ctx-reg context-callstack-bottom-offset [+] MOV
+    ! Clobbers tib-temp.
-    EAX bootstrap-cell ADD
+    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! >>
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
-call
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call

basis/cpu/x86/64/bootstrap.factor

@@ -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

basis/cpu/x86/64/unix/bootstrap.factor

@@ -12,5 +12,6 @@ IN: bootstrap.x86
 : arg3 ( -- reg ) RDX ;
 : arg4 ( -- reg ) RCX ;
 
-<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
+<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
-call
+<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call

basis/cpu/x86/64/winnt/bootstrap.factor

@@ -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! >>
+: tib-segment ( -- ) GS ;
-call
+: 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

basis/cpu/x86/unix/bootstrap.factor

@@ -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 ;

basis/cpu/x86/winnt/bootstrap.factor

@@ -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 ;

basis/debugger/debugger.factor

@@ -270,20 +270,20 @@ M: no-current-vocab summary
 
 M: no-word-error summary
     name>>
-    "No word named ``"
+    "No word named “"
-    "'' found in current vocabulary search path" surround ;
+    "” 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" ;

basis/io/monitors/recursive/recursive.factor

@@ -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? [
+    receive {
-        drop stop-pump
+        { [ dup +stop+ eq? ] [ drop stop-pump ] }
-    ] [
+        { [ dup monitor-disposed eq? ] [ drop ] }
-        [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
+        [
-        pump-loop
+            [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
-    ] if ;
+            pump-loop
+        ]
+    } cond ;
 
 : monitor-ready ( error/t -- )
     monitor tget ready>> fulfill ;

basis/ui/gadgets/grids/grids-docs.factor

@@ -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> }

basis/windows/directx/d3d9types/d3d9types.factor

@@ -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
+CONSTANT: D3DVS_X_X $[ 0 16 shift ]
-: D3DVS_X_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT shift ; inline
+CONSTANT: D3DVS_X_Y $[ 1 16 shift ]
-: D3DVS_X_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT shift ; inline
+CONSTANT: D3DVS_X_Z $[ 2 16 shift ]
-: D3DVS_X_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT shift ; inline
+CONSTANT: D3DVS_X_W $[ 3 16 shift ]
 
-: D3DVS_Y_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_X $[ 0 16 2 + shift ]
-: D3DVS_Y_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_Y $[ 1 16 2 + shift ]
-: D3DVS_Y_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_Z $[ 2 16 2 + shift ]
-: D3DVS_Y_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_W $[ 3 16 2 + shift ]
 
-: D3DVS_Z_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_X $[ 0 16 4 + shift ]
-: D3DVS_Z_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_Y $[ 1 16 4 + shift ]
-: D3DVS_Z_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_Z $[ 2 16 4 + shift ]
-: D3DVS_Z_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_W $[ 3 16 4 + shift ]
 
-: D3DVS_W_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+CONSTANT: D3DVS_W_X $[ 0 16 6 + shift ]
-: D3DVS_W_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+CONSTANT: D3DVS_W_Y $[ 1 16 6 + shift ]
-: D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+CONSTANT: D3DVS_W_Z $[ 2 16 6 + shift ]
-: D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+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
+CONSTANT: D3DSPSM_NONE    $[ 0 24 shift ]
-: D3DSPSM_NEG     ( -- n ) 1 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_NEG     $[ 1 24 shift ]
-: D3DSPSM_BIAS    ( -- n ) 2 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_BIAS    $[ 2 24 shift ]
-: D3DSPSM_BIASNEG ( -- n ) 3 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_BIASNEG $[ 3 24 shift ]
-: D3DSPSM_SIGN    ( -- n ) 4 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_SIGN    $[ 4 24 shift ]
-: D3DSPSM_SIGNNEG ( -- n ) 5 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_SIGNNEG $[ 5 24 shift ]
-: D3DSPSM_COMP    ( -- n ) 6 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_COMP    $[ 6 24 shift ]
-: D3DSPSM_X2      ( -- n ) 7 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_X2      $[ 7 24 shift ]
-: D3DSPSM_X2NEG   ( -- n ) 8 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_X2NEG   $[ 8 24 shift ]
-: D3DSPSM_DZ      ( -- n ) 9 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_DZ      $[ 9 24 shift ]
-: D3DSPSM_DW      ( -- n ) 10 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_DW      $[ 10 24 shift ]
-: D3DSPSM_ABS     ( -- n ) 11 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_ABS     $[ 11 24 shift ]
-: D3DSPSM_ABSNEG  ( -- n ) 12 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_ABSNEG  $[ 12 24 shift ]
-: D3DSPSM_NOT     ( -- n ) 13 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_NOT     $[ 13 24 shift ]
 CONSTANT: D3DSPSM_FORCE_DWORD HEX: 7fffffff
 
 : D3DPS_VERSION ( major minor -- n )

basis/windows/winsock/winsock.factor

@@ -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
 

core/bootstrap/syntax.factor

@@ -89,6 +89,12 @@ IN: bootstrap.syntax
         "read-only"
         "call("
         "execute("
+        "<<<<<<"
+        "======"
+        ">>>>>>"
+        "<<<<<<<"
+        "======="
+        ">>>>>>>"
     } [ "syntax" create drop ] each
 
     "t" "syntax" lookup define-symbol

core/combinators/combinators-tests.factor

@@ -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 )
     {

core/combinators/combinators.factor

@@ -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
+        [ [ datastack ] dip dip ] dip
-        dup in>> length swap out>> length
+        dup terminated?>> [ 2drop f ] [
-        check-datastack
+            dup in>> length swap out>> length
+            check-datastack
+        ] if
     ] 2dip rot
     [ 2drop ] [ wrong-values ] if ;
 

core/kernel/kernel-docs.factor

@@ -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 -- ... )" } } }

core/parser/parser.factor

@@ -207,3 +207,5 @@ print-use-hook [ [ ] ] initialize
 
 : ?run-file ( path -- )
     dup exists? [ run-file ] [ drop ] if ;
+
+ERROR: version-control-merge-conflict ;

core/syntax/syntax.factor

@@ -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

extra/cursors/cursors-tests.factor

@@ -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
 

extra/cursors/cursors.factor

@@ -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-key-value-unsafe cursor-key-value ; inline
-M: input-cursor cursor-value
+M: input-cursor cursor-key-value
-    dup cursor-valid? [ cursor-value-unsafe ] [ invalid-cursor ] if ; inline
+    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-key-value-unsafe [ n>> dup ] [ seq>> ] bi nth-unsafe ; inline
-M: sequence-cursor cursor-value [ n>> ] [ seq>> ] bi nth ; 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
+M: hashtable-cursor cursor-key-value-unsafe
-    cursor-key-value 2array ; inline
+    [ 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

extra/mason/child/child-tests.factor

@@ -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

extra/mason/child/child.factor

@@ -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" } ] }
+        { [ target-os get "winnt" = ] [ nmake-cmd ] }
-        [ gnu-make platform 2array ]
+        [ gnu-make-cmd ]
     } cond ;
 
 : make-vm ( -- )

vm/Config.windows.nt.x86.32

@@ -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

vm/Config.windows.nt.x86.64

@@ -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

vm/code_heap.cpp

@@ -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);
+	if(!seg) fatal_error("Out of memory in code_heap constructor",size);
-	allocator = new free_list_allocator<code_block>(size,seg->start);
+
+	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()

vm/code_heap.hpp

@@ -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;
 

vm/image.cpp

@@ -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;

vm/os-windows-nt-x86.32.cpp

@@ -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);
+}
+
+}

vm/os-windows-nt-x86.64.cpp

@@ -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);
+}
+
+}

vm/os-windows-nt.cpp

@@ -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()
 {
 }

vm/os-windows-nt.hpp

@@ -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

vm/platform.hpp

@@ -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"

vm/safeseh.asm

@@ -0,0 +1,5 @@
+.386
+.model flat
+exception_handler proto
+.safeseh exception_handler
+end