Merge branch 'master' of git://factorcode.org/git/factor

basis/bit-arrays/bit-arrays-tests.factor

@@ -1,4 +1,4 @@
-USING: sequences sequences.private arrays bit-arrays kernel
+USING: alien sequences sequences.private arrays bit-arrays kernel
 tools.test math random ;
 IN: bit-arrays.tests
 
@@ -79,4 +79,8 @@ IN: bit-arrays.tests
 
 [ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
 
+[ 1 ] [ ?{ f t f t } byte-length ] unit-test
+
+[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test
+
 [ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.data accessors math alien.accessors kernel
+USING: alien alien.data accessors io.binary math math.bitwise
-kernel.private sequences sequences.private byte-arrays
+alien.accessors kernel kernel.private sequences
-parser prettyprint.custom fry ;
+sequences.private byte-arrays parser prettyprint.custom fry
+locals ;
 IN: bit-arrays
 
 TUPLE: bit-array
@@ -13,11 +14,10 @@ TUPLE: bit-array
 
 : n>byte ( m -- n ) -3 shift ; inline
 
-: byte/bit ( n alien -- byte bit )
+: bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
-    over n>byte alien-unsigned-1 swap 7 bitand ; inline
 
-: set-bit ( ? byte bit -- byte )
+: bit-index ( n bit-array -- bit# byte# byte-array )
-    2^ rot [ bitor ] [ bitnot bitand ] if ; inline
+    [ >fixnum bit/byte ] [ underlying>> ] bi* ; inline
 
 : bits>cells ( m -- n ) 31 + -5 shift ; inline
 
@@ -25,7 +25,7 @@ TUPLE: bit-array
 
 : (set-bits) ( bit-array n -- )
     [ [ length bits>cells ] keep ] dip swap underlying>>
-    '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
+    '[ [ _ _ ] dip 4 * set-alien-unsigned-4 ] each-integer ; inline
 
 : clean-up ( bit-array -- )
     ! Zero bits after the end.
@@ -47,12 +47,13 @@ PRIVATE>
 M: bit-array length length>> ; inline
 
 M: bit-array nth-unsafe
-    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
+    bit-index nth-unsafe swap bit? ; inline
+
+:: toggle-bit ( ? n x -- y )
+    x n ? [ set-bit ] [ clear-bit ] if ; inline
 
 M: bit-array set-nth-unsafe
-    [ >fixnum ] [ underlying>> ] bi*
+    bit-index [ toggle-bit ] change-nth-unsafe ; inline
-    [ byte/bit set-bit ] 2keep
-    swap n>byte set-alien-unsigned-1 ; inline
 
 GENERIC: clear-bits ( bit-array -- )
 
@@ -83,25 +84,17 @@ M: bit-array resize
     bit-array boa
     dup clean-up ; inline
 
-M: bit-array byte-length length 7 + -3 shift ; inline
+M: bit-array byte-length length bits>bytes ; inline
 
 SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
 
 : integer>bit-array ( n -- bit-array )
-    dup 0 = [
+    dup 0 =
-        <bit-array>
+    [ <bit-array> ]
-    ] [
+    [ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ;
-        [ log2 1 + <bit-array> 0 ] keep
-        [ dup 0 = ] [
-            [ pick underlying>> pick set-alien-unsigned-1 ] keep
-            [ 1 + ] [ -8 shift ] bi*
-        ] until 2drop
-    ] if ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> dup length iota <reversed> [
+    underlying>> le> ;
-        alien-unsigned-1 swap 8 shift bitor
-    ] with each ;
 
 INSTANCE: bit-array sequence
 

basis/compiler/cfg/registers/registers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel parser assocs sequences ;
+USING: accessors namespaces kernel math parser assocs sequences ;
 IN: compiler.cfg.registers
 
 ! Virtual registers, used by CFG and machine IRs, are just integers
@@ -34,7 +34,7 @@ ERROR: bad-vreg vreg ;
 
 ! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
 ! an ##inc-d 1 becomes D 1 after ##inc-d 1.
-TUPLE: loc { n read-only } ;
+TUPLE: loc { n integer read-only } ;
 
 TUPLE: ds-loc < loc ;
 C: <ds-loc> ds-loc

basis/compiler/cfg/value-numbering/alien/alien.factor

@@ -70,7 +70,10 @@ M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
 ! construct a new ##load-memory or ##store-memory with the
 ! ##add's operand as the displacement
 : fuse-displacement? ( insn -- ? )
-    base>> vreg>insn ##add? ;
+    {
+        [ offset>> 0 = complex-addressing? or ]
+        [ base>> vreg>insn ##add? ]
+    } 1&& ;
 
 GENERIC: alien-insn-value ( insn -- value )
 
@@ -106,12 +109,14 @@ M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
     [ >>displacement ] [ >>scale ] bi* ;
 
 : rewrite-memory-op ( insn -- insn/f )
-    {
+    complex-addressing? [
-        { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
+        {
-        { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
+            { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
-        { [ dup fuse-scale? ] [ fuse-scale ] }
+            { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
-        [ drop f ]
+            { [ dup fuse-scale? ] [ fuse-scale ] }
-    } cond ;
+            [ drop f ]
+        } cond
+    ] [ drop f ] if ;
 
 : rewrite-memory-imm-op ( insn -- insn/f )
     {

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -91,7 +91,7 @@ cpu x86.32? [
     [
         {
             T{ ##load-reference f 0 + }
-            T{ ##replace-imm f 10 D + }
+            T{ ##replace-imm f + D 0 }
         }
     ] [
         {
@@ -2576,7 +2576,8 @@ cpu x86? [
     } value-numbering-step
 ] unit-test
 
-! Base offset fusion on ##load/store-memory
+! Base offset fusion on ##load/store-memory -- only on x86
+cpu x86?
 [
     V{
         T{ ##peek f 0 D 0 }
@@ -2586,7 +2587,18 @@ cpu x86? [
         T{ ##add-imm f 4 2 31337 }
         T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar }
     }
-] [
+]
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 2 31337 }
+        T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
+    }
+] ?
+[
     V{
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
@@ -2597,7 +2609,8 @@ cpu x86? [
     } value-numbering-step
 ] unit-test
 
-! Displacement offset fusion on ##load/store-memory
+! Displacement offset fusion on ##load/store-memory -- only on x86
+cpu x86?
 [
     V{
         T{ ##peek f 0 D 0 }
@@ -2607,7 +2620,18 @@ cpu x86? [
         T{ ##add-imm f 4 3 31337 }
         T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar }
     }
-] [
+]
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 3 31337 }
+        T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
+    }
+] ?
+[
     V{
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
@@ -2632,6 +2656,7 @@ cpu x86? [
 ] unit-test
 
 ! Scale fusion on ##load/store-memory
+cpu x86?
 [
     V{
         T{ ##peek f 0 D 0 }
@@ -2641,7 +2666,18 @@ cpu x86? [
         T{ ##shl-imm f 4 3 2 }
         T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar }
     }
-] [
+]
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##shl-imm f 4 3 2 }
+        T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+    }
+] ?
+[
     V{
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
@@ -2652,26 +2688,28 @@ cpu x86? [
     } value-numbering-step
 ] unit-test
 
-! Don't do scale fusion if there's already a scale
+cpu x86? [
-[ ] [
+    ! Don't do scale fusion if there's already a scale
-    V{
+    [ ] [
-        T{ ##peek f 0 D 0 }
+        V{
-        T{ ##peek f 1 D 1 }
+            T{ ##peek f 0 D 0 }
-        T{ ##tagged>integer f 2 0 }
+            T{ ##peek f 1 D 1 }
-        T{ ##tagged>integer f 3 1 }
+            T{ ##tagged>integer f 2 0 }
-        T{ ##shl-imm f 4 3 2 }
+            T{ ##tagged>integer f 3 1 }
-        T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
+            T{ ##shl-imm f 4 3 2 }
-    } dup value-numbering-step assert=
+            T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
-] unit-test
+        } dup value-numbering-step assert=
+    ] unit-test
 
-! Don't do scale fusion if the scale factor is out of range
+    ! Don't do scale fusion if the scale factor is out of range
-[ ] [
+    [ ] [
-    V{
+        V{
-        T{ ##peek f 0 D 0 }
+            T{ ##peek f 0 D 0 }
-        T{ ##peek f 1 D 1 }
+            T{ ##peek f 1 D 1 }
-        T{ ##tagged>integer f 2 0 }
+            T{ ##tagged>integer f 2 0 }
-        T{ ##tagged>integer f 3 1 }
+            T{ ##tagged>integer f 3 1 }
-        T{ ##shl-imm f 4 3 4 }
+            T{ ##shl-imm f 4 3 4 }
-        T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+            T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
-    } dup value-numbering-step assert=
+        } dup value-numbering-step assert=
-] unit-test
+    ] unit-test
+] when

basis/compiler/tests/codegen.factor

@@ -462,3 +462,13 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
     1 1
     [ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
 ] unit-test
+
+! GC root offsets were computed wrong on x86
+: gc-root-messup ( a -- b )
+    dup [
+        1024 (byte-array) 2array
+        10 void* "libc" "malloc" { ulong } alien-invoke
+        void "libc" "free" { void* } alien-invoke
+    ] when ;
+
+[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test

basis/compiler/tests/float.factor

@@ -99,9 +99,6 @@ IN: compiler.tests.float
 [ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
 [ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
 
-! Ensure that float-min and min, and float-max and max, have
-! consistent behavior with respect to NaNs
-
 : two-floats ( a b -- a b ) { float float } declare ; inline
 
 [ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test
@@ -109,17 +106,7 @@ IN: compiler.tests.float
 [ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test
 [ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test
 
-: check-compiled-binary-op ( a b word -- )
+! Test loops
-    [ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ]
-    [ '[ _ execute ] ]
-    bi 2bi fp-bitwise= ; inline
-
-[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test
-[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
-[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
-[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test
-
-! Test vector ops
 [ 30.0 ] [
     float-array{ 1 2 3 4 } float-array{ 1 2 3 4 }
     [ { float-array float-array } declare [ * ] [ + ] 2map-reduce ] compile-call
@@ -134,3 +121,13 @@ IN: compiler.tests.float
     float-array{ 1 2 3 4 }
     [ { float-array } declare [ dup * ] [ + ] map-reduce ] compile-call
 ] unit-test
+
+[ 4.5 ] [
+    float-array{ 1.0 3.5 }
+    [ { float-array } declare 0.0 [ + ] reduce ] compile-call
+] unit-test
+
+[ float-array{ 2.0 4.5 } ] [
+    float-array{ 1.0 3.5 }
+    [ { float-array } declare [ 1 + ] map ] compile-call
+] unit-test

basis/compression/lzw/lzw.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators io kernel math namespaces
-prettyprint sequences vectors ;
+sequences vectors ;
 QUALIFIED-WITH: bitstreams bs
 IN: compression.lzw
 

basis/cpu/architecture/architecture.factor

@@ -508,8 +508,6 @@ M: stack-params param-reg 2drop ;
 ! objects in %compare-imm?
 HOOK: fused-unboxing? cpu ( -- ? )
 
-M: object fused-unboxing? f ;
-
 ! Can this value be an immediate operand for %add-imm, %sub-imm,
 ! or %mul-imm?
 HOOK: immediate-arithmetic? cpu ( n -- ? )

basis/cpu/ppc/assembler/assembler-tests.factor

@@ -72,6 +72,14 @@ HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
 HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
 HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
 HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
+HEX{ 7c 41 1c 2e } [ 1 2 3 LFSX ] test-assembler
+HEX{ 7c 41 1c 6e } [ 1 2 3 LFSUX ] test-assembler
+HEX{ 7c 41 1c ae } [ 1 2 3 LFDX ] test-assembler
+HEX{ 7c 41 1c ee } [ 1 2 3 LFDUX ] test-assembler
+HEX{ 7c 41 1d 2e } [ 1 2 3 STFSX ] test-assembler
+HEX{ 7c 41 1d 6e } [ 1 2 3 STFSUX ] test-assembler
+HEX{ 7c 41 1d ae } [ 1 2 3 STFDX ] test-assembler
+HEX{ 7c 41 1d ee } [ 1 2 3 STFDUX ] test-assembler
 HEX{ 48 00 00 01 } [ 1 B ] test-assembler
 HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
 HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler

basis/cpu/ppc/assembler/assembler.factor

@@ -66,6 +66,10 @@ X: FCMPO 0 32 63
 X: FCMPU 0 0 63
 X: LBZUX 0 119 31
 X: LBZX 0 87 31
+X: LFDUX 0 631 31
+X: LFDX 0 599 31
+X: LFSUX 0 567 31
+X: LFSX 0 535 31
 X: LHAUX 0 375 31
 X: LHAX 0 343 31
 X: LHZUX 0 311 31
@@ -89,6 +93,10 @@ X: SRW 0 536 31
 X: SRW. 1 536 31
 X: STBUX 0 247 31
 X: STBX 0 215 31
+X: STFDUX 0 759 31
+X: STFDX 0 727 31
+X: STFSUX 0 695 31
+X: STFSX 0 663 31
 X: STHUX 0 439 31
 X: STHX 0 407 31
 X: STWUX 0 183 31

basis/cpu/ppc/bootstrap.factor

@@ -4,7 +4,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.ppc.assembler compiler.units compiler.constants math
 math.private math.ranges layouts words vocabs slots.private
 locals locals.backend generic.single.private fry sequences
-threads.private ;
+threads.private strings.private ;
 FROM: cpu.ppc.assembler => B ;
 IN: bootstrap.ppc
 
@@ -502,7 +502,7 @@ CONSTANT: nv-reg 17
     3 3 4 LBZX
     3 3 tag-bits get SLWI
     ! store character to stack
-    ds-reg ds-reg 4 SUB
+    ds-reg ds-reg 4 SUBI
     3 ds-reg 0 STW
 ] \ string-nth-fast define-sub-primitive
 

basis/cpu/ppc/ppc.factor

@@ -46,6 +46,10 @@ M: ppc machine-registers
 CONSTANT: scratch-reg 30
 CONSTANT: fp-scratch-reg 30
 
+M: ppc complex-addressing? f ;
+
+M: ppc fused-unboxing? f ;
+
 M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 
 M: ppc %load-reference ( reg obj -- )
@@ -139,9 +143,12 @@ M:: ppc %dispatch ( src temp -- )
     temp MTCTR
     BCTR ;
 
-M: ppc %slot ( dst obj slot -- ) swapd LWZX ;
+: (%slot) ( dst obj slot scale tag -- obj dst slot )
+    [ 0 assert= ] bi@ swapd ;
+
+M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
 M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
-M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
+M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
 M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
 
 M: ppc %add     ADD ;
@@ -357,7 +364,7 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
 
         dst displacement base temp
         {
-            { [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] }
+            { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
             { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
             { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
             [ %box-displaced-alien/dynamic ]
@@ -366,7 +373,7 @@ M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
         "end" resolve-label
     ] with-scope ;
 
-M:: ppc %load-memory-imm ( dst base offset rep c-type -- )
+M: ppc %load-memory-imm ( dst base offset rep c-type -- )
     [
         {
             { c:char   [ [ dup ] 2dip LBZ dup EXTSB ] }
@@ -382,7 +389,26 @@ M:: ppc %load-memory-imm ( dst base offset rep c-type -- )
         } case
     ] ?if ;
 
-M:: ppc %store-memory-imm ( src base offset rep c-type -- )
+: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
+    [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
+
+M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
+    (%memory) [
+        {
+            { c:char   [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
+            { c:uchar  [ LBZX ] }
+            { c:short  [ LHAX ] }
+            { c:ushort [ LHZX ] }
+        } case
+    ] [
+        {
+            { int-rep [ LWZX ] }
+            { float-rep [ LFSX ] }
+            { double-rep [ LFDX ] }
+        } case
+    ] ?if ;
+
+M: ppc %store-memory-imm ( src base offset rep c-type -- )
     [
         {
             { c:char   [ STB ] }
@@ -398,6 +424,22 @@ M:: ppc %store-memory-imm ( src base offset rep c-type -- )
         } case
     ] ?if ;
 
+M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
+    (%memory) [
+        {
+            { c:char   [ STBX ] }
+            { c:uchar  [ STBX ] }
+            { c:short  [ STHX ] }
+            { c:ushort [ STHX ] }
+        } case
+    ] [
+        {
+            { int-rep [ STWX ] }
+            { float-rep [ STFSX ] }
+            { double-rep [ STFDX ] }
+        } case
+    ] ?if ;
+
 : load-zone-ptr ( reg -- )
     vm-reg "nursery" vm-field-offset ADDI ;
 
@@ -440,18 +482,18 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
     temp2 load-decks-offset
     temp1 scratch-reg temp2 STBX ;
 
-M:: ppc %write-barrier ( src slot temp1 temp2 -- )
+M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
+    scale 0 assert= tag 0 assert=
     temp1 src slot ADD
     temp1 temp2 (%write-barrier) ;
 
-M:: ppc %write-barrier-imm ( src slot temp1 temp2 -- )
+M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
-    temp1 src slot ADDI
+    temp1 src slot tag slot-offset ADDI
     temp1 temp2 (%write-barrier) ;
 
 M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
-    temp2 load-zone-ptr
+    temp1 vm-reg "nursery" vm-field-offset LWZ
-    temp1 temp2 0 LWZ
+    temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
-    temp2 temp2 2 cells LWZ
     temp1 temp1 size ADDI
     ! is here >= end?
     temp1 0 temp2 CMP
@@ -460,8 +502,11 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
         { cc/<= [ label BGT ] }
     } case ;
 
+: gc-root-offsets ( seq -- seq' )
+    [ n>> spill@ ] map f like ;
+
 M: ppc %call-gc ( gc-roots -- )
-    3 swap %load-reference
+    3 swap gc-root-offsets %load-reference
     4 %load-vm-addr
     "inline_gc" f %alien-invoke ;
 
@@ -586,6 +631,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
 : load-from-frame ( dst n rep -- )
     {
         { int-rep [ [ 1 ] dip LWZ ] }
+        { tagged-rep [ [ 1 ] dip LWZ ] }
         { float-rep [ [ 1 ] dip LFS ] }
         { double-rep [ [ 1 ] dip LFD ] }
         { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
@@ -597,6 +643,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
 : store-to-frame ( src n rep -- )
     {
         { int-rep [ [ 1 ] dip STW ] }
+        { tagged-rep [ [ 1 ] dip STW ] }
         { float-rep [ [ 1 ] dip STFS ] }
         { double-rep [ [ 1 ] dip STFD ] }
         { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }

basis/cpu/x86/assembler/assembler-tests.factor

@@ -3,7 +3,12 @@ kernel tools.test namespaces make layouts ;
 IN: cpu.x86.assembler.tests
 
 ! immediate operands
-[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+cell 4 = [
+    [ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+] [
+    [ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+] if
+
 [ { HEX: 83 HEX: c1 HEX: 01 } ] [ [ ECX 1 ADD ] { } make ] unit-test
 [ { HEX: 81 HEX: c1 HEX: 96 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 150 ADD ] { } make ] unit-test
 [ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test

basis/cpu/x86/x86.factor

@@ -45,7 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
 : gc-root-offsets ( seq -- seq' )
-    [ n>> special-offset ] map f like ;
+    [ n>> spill-offset special-offset cell + ] map f like ;
 
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
@@ -70,9 +70,9 @@ HOOK: pic-tail-reg cpu ( -- reg )
 
 M: x86 complex-addressing? t ;
 
-M: x86 fused-unboxing? ( -- ? ) t ;
+M: x86 fused-unboxing? t ;
 
-M: x86 immediate-store? ( obj -- ? ) immediate-comparand? ;
+M: x86 immediate-store? immediate-comparand? ;
 
 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
 

basis/images/ppm/ppm.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors ascii combinators images images.loader io
 io.encodings.ascii io.encodings.string kernel locals make math
-math.parser prettyprint sequences ;
+math.parser sequences ;
 IN: images.ppm
 
 SINGLETON: ppm-image

basis/images/tiff/tiff.factor

@@ -4,7 +4,7 @@ USING: accessors arrays assocs byte-arrays classes combinators
 compression.lzw endian fry grouping images io
 io.binary io.encodings.ascii io.encodings.binary
 io.encodings.string io.encodings.utf8 io.files kernel math
-math.bitwise math.order math.parser pack prettyprint sequences
+math.bitwise math.order math.parser pack sequences
 strings math.vectors specialized-arrays locals
 images.loader ;
 FROM: alien.c-types => float ;

basis/peg/ebnf/ebnf-tests.factor

@@ -528,3 +528,17 @@ Tok                = Spaces (Number | Special )
 ] [
     error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
 ] must-fail-with
+
+[
+    { "a" "a" }
+] [
+    EBNF: foo   Bar = "a":a1 "a":a2 => [[ a1 a2 2array ]] ;EBNF
+    "aa" foo
+] unit-test
+
+[
+    { "a" "a" }
+] [
+    EBNF: foo2   Bar = "a":a-1 "a":a-2 => [[ a-1 a-2 2array ]] ;EBNF
+    "aa" foo2
+] unit-test

basis/peg/ebnf/ebnf.factor

@@ -230,7 +230,11 @@ DEFER: 'action'
 
 : 'element' ( -- parser )
   [
-    [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
+    [
+      ('element') , ":" syntax ,
+      "a-zA-Z_" range-pattern
+      "a-zA-Z0-9_-" range-pattern repeat1 2seq [ first2 swap prefix >string ] action ,
+    ] seq* [ first2 <ebnf-var> ] action ,
     ('element') ,
   ] choice* ;
 

basis/tools/deploy/shaker/shaker.factor

@@ -1,13 +1,15 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays alien.libraries accessors io.backend io.encodings.utf8 io.files
+USING: arrays alien.libraries accessors io.backend
-io.streams.c init fry namespaces math make assocs kernel parser
+io.encodings.utf8 io.files io.streams.c init fry namespaces math
-parser.notes lexer strings.parser vocabs sequences sequences.deep
+make assocs kernel parser parser.notes lexer strings.parser
-sequences.private words memory kernel.private continuations io
+vocabs sequences sequences.deep sequences.private words memory
-vocabs.loader system strings sets vectors quotations byte-arrays
+kernel.private continuations io vocabs.loader system strings
-sorting compiler.units definitions generic generic.standard
+sets vectors quotations byte-arrays sorting compiler.units
-generic.single tools.deploy.config combinators classes vocabs.loader.private
+definitions generic generic.standard generic.single
-classes.builtin slots.private grouping command-line io.pathnames ;
+tools.deploy.config combinators combinators.private classes
+vocabs.loader.private classes.builtin slots.private grouping
+command-line io.pathnames ;
 QUALIFIED: bootstrap.stage2
 QUALIFIED: classes.private
 QUALIFIED: compiler.crossref
@@ -548,10 +550,18 @@ SYMBOL: deploy-vocab
     strip-words
     clear-megamorphic-caches ;
 
+: die-with ( error original-error -- * )
+    #! We don't want DCE to drop the error before the die call!
+    [ die 1 exit ] (( a -- * )) call-effect-unsafe ;
+
+: die-with2 ( error original-error -- * )
+    #! We don't want DCE to drop the error before the die call!
+    [ die 1 exit ] (( a b -- * )) call-effect-unsafe ;
+
 : deploy-error-handler ( quot -- )
     [
         strip-debugger?
-        [ error-continuation get call>> callstack>array die 1 exit ]
+        [ original-error get die-with2 ]
         ! Don't reference these words literally, if we're stripping the
         ! debugger out we don't want to load the prettyprinter at all
         [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if

basis/tools/deploy/shaker/strip-debugger.factor

@@ -1,17 +1,14 @@
-USING: compiler.units words vocabs kernel threads.private ;
+USING: compiler.units continuations kernel namespaces
+threads.private words vocabs tools.deploy.shaker ;
 IN: debugger
 
-: consume ( error -- )
+: error. ( error -- ) original-error get die-with2 ;
-    #! We don't want DCE to drop the error before the die call!
-    drop ;
 
-: print-error ( error -- ) die consume ;
+: print-error ( error -- ) error. ;
-
-: error. ( error -- ) die consume ;
 
 "threads" vocab [
     [
         "error-in-thread" "threads" lookup
-        [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi
+        [ [ drop error. ] define ] [ f "combination" set-word-prop ] bi
     ] with-compilation-unit
 ] when

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

@@ -25,13 +25,11 @@ ARTICLE: "ui.gadgets.tables.selection" "Table row selection"
   { { $slot "selection" } { " - if set to a model, the values of the currently selected row or rows, as determined by a " { $link row-value } " call to the renderer, is stored in this model. See " { $link "models" } "." } }
   { { $slot "selection-index" } { " - if set to a model, the indices of the currently selected rows." } }
   { { $slot "selection-required?" } { " - if set to a true value, the table ensures that some row is always selected, if the model is non-empty. If set to " { $link f } ", a state where nothing is selected is permitted to occur. The default is " { $link f } "." } }
-  { { $slot "multiple-selection?" } { " - if set to a true value, users are allowed to select more than one value." } }
 }
 "Some words for row selection:"
 { $subsections
-    selected-rows
+    selected-row
-    (selected-rows)
+    (selected-row)
-    selected
 } ;
 
 ARTICLE: "ui.gadgets.tables.actions" "Table row actions"

basis/ui/gadgets/tables/tables.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs hashtables arrays colors colors.constants fry
 kernel math math.functions math.ranges math.rectangles math.order
@@ -18,6 +18,7 @@ GENERIC: column-titles ( renderer -- strings )
 GENERIC: row-columns ( row renderer -- columns )
 GENERIC: row-value ( row renderer -- object )
 GENERIC: row-color ( row renderer -- color )
+GENERIC: row-value? ( value row renderer -- ? )
 
 SINGLETON: trivial-renderer
 
@@ -29,6 +30,7 @@ M: object column-titles drop f ;
 M: trivial-renderer row-columns drop ;
 M: object row-value drop ;
 M: object row-color 2drop f ;
+M: object row-value? drop eq? ;
 
 TUPLE: table < line-gadget
 { renderer initial: trivial-renderer }
@@ -41,33 +43,11 @@ focus-border-color
 { mouse-color initial: COLOR: black }
 column-line-color
 selection-required?
-selection
 selection-index
-selected-indices
+selection
 mouse-index
 { takes-focus? initial: t }
-focused?
+focused? ;
-multiple-selection? ;
-
-<PRIVATE
-
-: add-selected-index ( table n -- table )
-    over selected-indices>> conjoin ;
-
-: multiple>single ( values -- value/f ? )
-    dup assoc-empty? [ drop f f ] [ values first t ] if ;
-
-: selected-index ( table -- n )
-    selected-indices>> multiple>single drop ;
-
-: set-selected-index ( table n -- table )
-    dup associate >>selected-indices ;
-
-PRIVATE>
-
-: selected ( table -- index/indices )
-    [ selected-indices>> ] [ multiple-selection?>> ] bi
-    [ multiple>single drop ] unless ;
 
 : new-table ( rows renderer class -- table )
     new-line-gadget
@@ -77,8 +57,7 @@ PRIVATE>
         focus-border-color >>focus-border-color
         transparent >>column-line-color
         f <model> >>selection-index
-        f <model> >>selection
+        f <model> >>selection ;
-        H{ } clone >>selected-indices ;
 
 : <table> ( rows renderer -- table ) table new-table ;
 
@@ -156,30 +135,23 @@ M: table layout*
 : row-bounds ( table row -- loc dim )
     row-rect rect-bounds ; inline
 
-: draw-selected-rows ( table -- )
+: draw-selected-row ( table -- )
-    {
+    dup selection-index>> value>> [
-        { [ dup selected-indices>> assoc-empty? ] [ drop ] }
+        dup selection-color>> gl-color
-        [
+        dup selection-index>> value>> row-bounds gl-fill-rect
-            [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri
+    ] [ drop ] if ;
-            [ swap row-bounds gl-fill-rect ] curry each
-        ]
-    } cond ;
 
 : draw-focused-row ( table -- )
-    {
+    dup { [ focused?>> ] [ selection-index>> value>> ] } 1&& [
-        { [ dup focused?>> not ] [ drop ] }
+        dup focus-border-color>> gl-color
-        { [ dup selected-index not ] [ drop ] }
+        dup selection-index>> value>> row-bounds gl-rect
-        [
+    ] [ drop ] if ;
-            [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri
-            row-bounds gl-rect
-        ]
-    } cond ;
 
 : draw-moused-row ( table -- )
-    dup mouse-index>> dup [
+    dup mouse-index>> [
-        over mouse-color>> gl-color
+        dup mouse-color>> gl-color
-        row-bounds gl-rect
+        dup mouse-index>> row-bounds gl-rect
-    ] [ 2drop ] if ;
+    ] [ drop ] if ;
 
 : column-line-offsets ( table -- xs )
     [ column-widths>> ] [ gap>> ] bi
@@ -217,7 +189,7 @@ M: table layout*
 :: row-font ( row ind table -- font )
     table font>> clone
     row table renderer>> row-color [ >>foreground ] when*
-    ind table selected-indices>> key?
+    ind table selection-index>> value>> =
     [ table selection-color>> >>background ] when ;
 
 : draw-columns ( columns widths alignment font gap -- )
@@ -239,7 +211,7 @@ M: table draw-gadget*
     dup control-value empty? [ drop ] [
         dup line-height \ line-height [
             {
-                [ draw-selected-rows ]
+                [ draw-selected-row ]
                 [ draw-lines ]
                 [ draw-column-lines ]
                 [ draw-focused-row ]
@@ -262,37 +234,15 @@ M: table pref-dim*
 
 PRIVATE>
 
-: (selected-rows) ( table -- assoc )
+: (selected-row) ( table -- value/f ? )
-    [ selected-indices>> ] keep
+    [ selection-index>> value>> ] keep nth-row ;
-    '[ _ nth-row drop ] assoc-map ;
 
-: selected-rows ( table -- assoc )
+: selected-row ( table -- value/f ? )
-    [ selected-indices>> ] [ ] [ renderer>> ] tri
+    [ (selected-row) ] [ renderer>> ] bi
-    '[ _ nth-row drop _ row-value ] assoc-map ;
+    swap [ row-value t ] [ 2drop f f ] if ;
-
-: (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
-
-: selected-row ( table -- value/f ? ) selected-rows multiple>single ;
 
 <PRIVATE
 
-: set-table-model ( model value multiple? -- )
-    [ values ] [ multiple>single drop ] if swap set-model ;
-
-: update-selected ( table -- )
-    [
-        [ selection>> ]
-        [ selected-rows ]
-        [ multiple-selection?>> ] tri
-        set-table-model
-    ]
-    [
-        [ selection-index>> ]
-        [ selected-indices>> ]
-        [ multiple-selection?>> ] tri
-        set-table-model
-    ] bi ;
-
 : show-row-summary ( table n -- )
     over nth-row
     [ swap [ renderer>> row-value ] keep show-summary ]
@@ -302,34 +252,45 @@ PRIVATE>
 : hide-mouse-help ( table -- )
     f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
 
-: find-row-index ( value table -- n/f )
+: ((select-row)) ( n table -- )
-    [ model>> value>> ] [ renderer>> ] bi
+    [ selection-index>> set-model ]
-    '[ _ row-value eq? ] with find drop ;
+    [ [ selected-row drop ] keep selection>> set-model ]
+    bi ;
 
-: (update-selected-indices) ( table -- set )
+: update-mouse-index ( table -- )
-    [ selection>> value>> dup { [ array? not ] [ ] } 1&& [ 1array ] when ] keep
+    dup [ model>> value>> ] [ mouse-index>> ] bi
-    '[ _ find-row-index ] map sift unique f assoc-like ;
+    dup [ swap length [ drop f ] [ 1 - min ] if-zero ] [ 2drop f ] if
+    >>mouse-index drop ;
 
-: initial-selected-indices ( table -- set )
+: initial-selection-index ( table -- n/f )
     {
         [ model>> value>> empty? not ]
         [ selection-required?>> ]
-        [ drop { 0 } unique ]
+        [ drop 0 ]
     } 1&& ;
 
-: update-selected-indices ( table -- set )
+: find-row-index ( value table -- n/f )
-    {
+    [ model>> value>> ] [ renderer>> ] bi
-        [ (update-selected-indices) ]
+    '[ _ row-value? ] with find drop ;
-        [ initial-selected-indices ]
+
-    } 1|| ;
+: update-selection ( table -- )
+    [
+        {
+            [ [ selection>> value>> ] keep find-row-index ]
+            [ initial-selection-index ]
+        } 1||
+    ] keep
+    over [ ((select-row)) ] [
+        [ selection-index>> set-model ]
+        [ selection>> set-model ]
+        2bi
+    ] if ;
 
 M: table model-changed
-    nip dup update-selected-indices {
+    nip
-        [ >>selected-indices f >>mouse-index drop ]
+        dup update-selection
-        [ multiple>single drop show-row-summary ]
+        dup update-mouse-index
-        [ drop update-selected ]
+    [ dup mouse-index>> show-row-summary ] [ relayout ] bi ;
-        [ drop relayout ]
-    } 2cleave ;
 
 : thin-row-rect ( table row -- rect )
     row-rect [ { 0 1 } v* ] change-dim ;
@@ -337,14 +298,11 @@ M: table model-changed
 : scroll-to-row ( table n -- )
     dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
 
-: add-selected-row ( table n -- )
-    [ scroll-to-row ]
-    [ add-selected-index relayout-1 ] 2bi ;
-
 : (select-row) ( table n -- )
     [ scroll-to-row ]
-    [ set-selected-index relayout-1 ]
+    [ swap ((select-row)) ]
-    2bi ;
+    [ drop relayout-1 ]
+    2tri ;
 
 : mouse-row ( table -- n )
     [ hand-rel second ] keep y>line ;
@@ -353,23 +311,9 @@ M: table model-changed
     [ [ mouse-row ] keep 2dup valid-line? ]
     [ ] [ '[ nip @ ] ] tri* if ; inline
 
-: (table-button-down) ( quot table -- )
-    dup takes-focus?>> [ dup request-focus ] when swap
-   '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
-
 : table-button-down ( table -- )
-    [ (select-row) ] swap (table-button-down) ;
+    dup takes-focus?>> [ dup request-focus ] when
-
+    [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; inline
-: continued-button-down ( table -- )
-    dup multiple-selection?>>
-    [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
-
-: thru-button-down ( table -- )
-    dup multiple-selection?>> [
-      [ 2dup over selected-index (a,b) swap
-      [ swap add-selected-index drop ] curry each add-selected-row ]
-      swap (table-button-down)
-    ] [ table-button-down ] if ;
 
 PRIVATE>
 
@@ -386,22 +330,20 @@ PRIVATE>
 
 : table-button-up ( table -- )
     dup [ mouse-row ] keep valid-line? [
-        dup row-action? [ row-action ] [ update-selected ] if
+        dup row-action? [ row-action ] [ drop ] if
     ] [ drop ] if ;
 
 PRIVATE>
 
 : select-row ( table n -- )
     over validate-line
-    [ (select-row) ]
+    [ (select-row) ] [ show-row-summary ] 2bi ;
-    [ drop update-selected ]
-    [ show-row-summary ]
-    2tri ;
 
 <PRIVATE
 
 : prev/next-row ( table n -- )
-    [ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ;
+    [ dup selection-index>> value>> ] dip
+    '[ _ + ] [ 0 ] if* select-row ;
     
 : previous-row ( table -- )
     -1 prev/next-row ;
@@ -453,8 +395,6 @@ table "sundry" f {
     { mouse-enter show-mouse-help }
     { mouse-leave hide-mouse-help }
     { motion show-mouse-help }
-    { T{ button-down f { S+ } 1 } thru-button-down }
-    { T{ button-down f { A+ } 1 } continued-button-down }
     { T{ button-up } table-button-up }
     { T{ button-up f { S+ } } table-button-up }
     { T{ button-down } table-button-down }

basis/ui/tools/error-list/error-list.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays sequences sorting assocs colors.constants fry
 combinators combinators.smart combinators.short-circuit editors make
@@ -49,6 +49,8 @@ M: source-file-renderer prototype-row
 M: source-file-renderer row-value
     drop dup [ first [ <pathname> ] [ f ] if* ] when ;
 
+M: source-file-renderer row-value? row-value = ;
+
 M: source-file-renderer column-titles
     drop { "" "File" "Errors" } ;
 
@@ -152,7 +154,7 @@ error-display "toolbar" f {
     [ swap '[ error-type _ at ] filter ] <smart-arrow> ;
 
 :: <error-list-gadget> ( model -- gadget )
-    vertical error-list-gadget new-track
+    vertical \ error-list-gadget new-track
         <error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
         dup visible-errors>> model <error-model> >>model 
         f <model> >>source-file
@@ -176,16 +178,16 @@ M: error-list-gadget focusable-child*
 
 \ error-list-help H{ { +nullary+ t } } define-command
 
-error-list-gadget "toolbar" f {
+\ error-list-gadget "toolbar" f {
     { T{ key-down f f "F1" } error-list-help }
 } define-command-map
 
-: error-list-window ( -- )
+MEMO: error-list-gadget ( -- gadget )
-    error-list-model get [ drop all-errors ] <arrow>
+    error-list-model get-global [ drop all-errors ] <arrow>
-    <error-list-gadget> "Errors" open-status-window ;
+    <error-list-gadget> ;
 
 : show-error-list ( -- )
-    [ error-list-gadget? ] find-window
+    [ error-list-gadget eq? ] find-window
-    [ raise-window ] [ error-list-window ] if* ;
+    [ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ;
 
 \ show-error-list H{ { +nullary+ t } } define-command

basis/windows/directx/dinput/constants/constants.factor

@@ -1,8 +1,8 @@
-USING: windows.directx.dinput windows.kernel32 windows.ole32 windows.com
+USING: windows.directx.dinput windows.kernel32 windows.ole32
-windows.com.syntax alien alien.c-types alien.data alien.syntax
+windows.com windows.com.syntax alien alien.c-types alien.data
-kernel system namespaces combinators sequences fry math accessors
+alien.syntax kernel system namespaces combinators sequences fry
-macros words quotations libc continuations generalizations
+math accessors macros words quotations libc continuations
-splitting locals assocs init specialized-arrays memoize
+generalizations splitting locals assocs init specialized-arrays
 classes.struct strings arrays literals ;
 SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
 IN: windows.directx.dinput.constants
@@ -20,21 +20,21 @@ SYMBOLS:
 
 <PRIVATE
 
-<<
+: initialize ( variable quot -- )
+    call swap set-global ; inline
 
-MEMO: c-type* ( name -- c-type ) c-type ;
+<<
-MEMO: heap-size* ( c-type -- n ) heap-size ;
 
 GENERIC: array-base-type ( c-type -- c-type' )
 M: object array-base-type ;
 M: array array-base-type first ;
 
 : (field-spec-of) ( field struct -- field-spec )
-    c-type* fields>> [ name>> = ] with find nip ;
+    c-type fields>> [ name>> = ] with find nip ;
 : (offsetof) ( field struct -- offset )
     [ (field-spec-of) offset>> ] [ drop 0 ] if* ;
 : (sizeof) ( field struct -- size )
-    [ (field-spec-of) type>> array-base-type heap-size* ] [ drop 1 ] if* ;
+    [ (field-spec-of) type>> array-base-type heap-size ] [ drop 1 ] if* ;
 
 : (flag) ( thing -- integer )
     {
@@ -56,14 +56,17 @@ M: array array-base-type first ;
         [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
     } cleave
     [ DIOBJECTDATAFORMAT <struct-boa> ] dip
-    '[ _ clone @ >>pguid ] ;
+    curry ;
+
+: set-DIOBJECTDATAFORMAT ( array struct pguid n -- array )
+    [ [ clone ] dip >>pguid ] dip pick set-nth ;
 
 :: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
     array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]
     array [| args i |
         struct args <DIOBJECTDATAFORMAT>-quot
-        i '[ _ pick set-nth ] compose compose
+        i '[ @ _ set-DIOBJECTDATAFORMAT ]
-    ] each-index ;
+    ] map-index [ ] join compose ;
 
 >>
 
@@ -832,8 +835,7 @@ MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
 [ define-constants ] "windows.directx.dinput.constants" add-startup-hook
 
 : uninitialize ( variable quot -- )
-    [ '[ _ when* f ] change-global ]
+    [ [ get-global ] dip when* ] [ drop global delete-at ] 2bi ; inline
-    [ drop global delete-at ] 2bi ; inline
 
 : free-dinput-constants ( -- )
     {

build-support/cleanup

@@ -8,3 +8,9 @@ Nmakefile
 unmaintained
 build-support
 images
+factor.dll.exp
+factor.dll.lib
+factor.exp
+factor.lib
+libfactor-ffi-test.exp
+libfactor-ffi-test.lib

vm/gc.cpp

@@ -217,7 +217,7 @@ void factor_vm::primitive_compact_gc()
 
 void factor_vm::inline_gc(cell gc_roots_)
 {
-	cell stack_pointer = (cell)ctx->callstack_top + sizeof(cell);
+	cell stack_pointer = (cell)ctx->callstack_top;
 
 	if(to_boolean(gc_roots_))
 	{