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

Makefile

@@ -170,7 +170,7 @@ vm/resources.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
 
 .S.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
+	$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
 
 .m.o:
 	$(CC) -c $(CFLAGS) -o $@ $<

basis/alien/c-types/c-types.factor

@@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- )
         [ >float ] >>unboxer-quot
     "double" define-primitive-type
 
-    os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
+    "long" "ptrdiff_t" typedef
 
     "ulong" "size_t" typedef
 ] with-compilation-unit

basis/bootstrap/image/image.factor

@@ -12,9 +12,15 @@ io.encodings.binary math.order math.private accessors
 slots.private compiler.units ;
 IN: bootstrap.image
 
+: arch ( os cpu -- arch )
+    {
+        { "ppc" [ "-ppc" append ] }
+        { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+        [ nip ]
+    } case ;
+
 : my-arch ( -- arch )
-    cpu name>> 
+    os name>> cpu name>> arch ;
-    dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
 
 : boot-image-name ( arch -- string )
     "boot." swap ".image" 3append ;
@@ -25,7 +31,7 @@ IN: bootstrap.image
 : images ( -- seq )
     {
         "x86.32"
-        "x86.64"
+        "winnt-x86.64" "unix-x86.64"
         "linux-ppc" "macosx-ppc"
     } ;
 

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-combinators make cpu.architecture compiler.cfg.instructions
+combinators make classes words cpu.architecture
-compiler.cfg.registers ;
+compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
 SYMBOL: frame-required?
@@ -24,16 +24,16 @@ M: ##stack-frame compute-stack-frame*
 M: ##call compute-stack-frame*
     word>> sub-primitive>> [ frame-required? on ] unless ;
 
-M: _gc compute-stack-frame*
-    drop frame-required? on ;
-
-M: _spill compute-stack-frame*
-    drop frame-required? on ;
-
 M: _spill-counts compute-stack-frame*
     counts>> stack-frame get (>>spill-counts) ;
 
-M: insn compute-stack-frame* drop ;
+M: insn compute-stack-frame*
+    class frame-required? word-prop [
+        frame-required? on
+    ] when ;
+
+\ _gc t frame-required? set-word-prop
+\ _spill t frame-required? set-word-prop
 
 : compute-stack-frame ( insns -- )
     frame-required? off

basis/compiler/codegen/codegen.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make math math.parser sequences accessors
+USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
 alien.strings alien.arrays sets threads libc continuations.private
@@ -234,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ;
 
 GENERIC: inc-reg-class ( register-class -- )
 
-M: reg-class inc-reg-class
+: ?dummy-stack-params ( reg-class -- )
-    dup reg-class-variable inc
+    dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
-    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+: ?dummy-int-params ( reg-class -- )
+    dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+
+: ?dummy-fp-params ( reg-class -- )
+    drop dummy-fp-params? [ float-regs inc ] when ;
+
+M: int-regs inc-reg-class
+    [ reg-class-variable inc ]
+    [ ?dummy-stack-params ]
+    [ ?dummy-fp-params ]
+    tri ;
 
 M: float-regs inc-reg-class
-    dup call-next-method
+    [ reg-class-variable inc ]
-    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+    [ ?dummy-stack-params ]
+    [ ?dummy-int-params ]
+    tri ;
 
 GENERIC: reg-class-full? ( class -- ? )
 

basis/compiler/tests/spilling.factor

@@ -0,0 +1,343 @@
+USING: math.private kernel combinators accessors arrays
+generalizations float-arrays tools.test ;
+IN: compiler.tests
+
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
+    {
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+    } cleave ;
+
+[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
+[ 1.0 float-spill-bug ] unit-test
+
+[ t ] [ \ float-spill-bug compiled>> ] unit-test
+
+: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
+    {
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+    } cleave ;
+
+[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
+[ 1.0 float-fixnum-spill-bug ] unit-test
+
+[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+
+: resolve-spill-bug ( a b -- c )
+    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
+        nip 2 fixnum+fast
+    ] [
+        drop {
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+        } cleave
+        16 narray
+    ] if ;
+
+[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+
+[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
+
+! The above don't really test spilling...
+: spill-test-1 ( a -- b )
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast fixnum>float
+    3array
+    3array [ 8 narray ] dip 2array
+    [ 8 narray [ 8 narray ] dip 2array ] dip 2array
+    2array ;
+
+[
+    {
+        1
+        {
+            { { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
+            {
+                { 18 19 20 21 22 23 24 25 }
+                { 26 27 { 28 29 30.0 } }
+            }
+        }
+    }
+] [ 1 spill-test-1 ] unit-test
+
+: spill-test-2 ( a -- b )
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float* ;
+
+[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test

basis/compiler/tests/templates.factor

@@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
 sequences sequences.private tools.test namespaces.private
 slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors ;
+combinators vectors float-arrays ;
 IN: compiler.tests
 
 ! Originally, this file did black box testing of templating
@@ -206,167 +206,6 @@ TUPLE: my-tuple ;
     ] compile-call
 ] unit-test
 
-: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
-    {
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-    } cleave ;
-
-[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
-[ 1.0 float-spill-bug ] unit-test
-
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
-
-: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
-    {
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-    } cleave ;
-
-[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
-[ 1.0 float-fixnum-spill-bug ] unit-test
-
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
-
-: resolve-spill-bug ( a b -- c )
-    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
-        nip 2 fixnum+fast
-    ] [
-        drop {
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-        } cleave
-        16 narray
-    ] if ;
-
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
-
-[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
-
 ! Regression
 : dispatch-alignment-regression ( -- c )
     { tuple vector } 3 slot { word } declare

basis/cpu/architecture/architecture.factor

@@ -146,8 +146,14 @@ HOOK: struct-small-enough? cpu ( heap-size -- ? )
 ! Do we pass value structs by value or hidden reference?
 HOOK: value-structs? cpu ( -- ? )
 
-! If t, fp parameters are shadowed by dummy int parameters
+! If t, all parameters are shadowed by dummy stack parameters
-HOOK: fp-shadows-int? cpu ( -- ? )
+HOOK: dummy-stack-params? cpu ( -- ? )
+
+! If t, all FP parameters are shadowed by dummy int parameters
+HOOK: dummy-int-params? cpu ( -- ? )
+
+! If t, all int parameters are shadowed by dummy FP parameters
+HOOK: dummy-fp-params? cpu ( -- ? )
 
 HOOK: %prepare-unbox cpu ( -- )
 

basis/cpu/ppc/linux/linux.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.linux
+
+<<
+t "longlong" c-type (>>stack-align?)
+t "ulonglong" c-type (>>stack-align?)
+>>
+
+M: linux reserved-area-size 2 cells ;
+
+M: linux lr-save 1 cells ;
+
+M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
+
+M: ppc value-structs? f ;
+
+M: ppc dummy-stack-params? f ;
+
+M: ppc dummy-int-params? f ;
+
+M: ppc dummy-fp-params? f ;

basis/cpu/ppc/linux/tags.txt

@@ -0,0 +1 @@
+unportable

basis/cpu/ppc/macosx/macosx.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.macosx
+
+<<
+4 "longlong" c-type (>>align)
+4 "ulonglong" c-type (>>align)
+4 "double" c-type (>>align)
+>>
+
+M: macosx reserved-area-size 6 cells ;
+
+M: macosx lr-save 2 cells ;
+
+M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
+
+M: ppc value-structs? t ;
+
+M: ppc dummy-stack-params? t ;
+
+M: ppc dummy-int-params? t ;
+
+M: ppc dummy-fp-params? f ;

basis/cpu/ppc/macosx/tags.txt

@@ -0,0 +1 @@
+unportable

basis/cpu/ppc/ppc.factor

@@ -15,18 +15,6 @@ IN: cpu.ppc
 ! f0-f29: float vregs
 ! f30, f31: float scratch
 
-<< {
-    { [ os macosx? ] [
-        4 "longlong" c-type (>>align)
-        4 "ulonglong" c-type (>>align)
-        4 "double" c-type (>>align)
-    ] }
-    { [ os linux? ] [
-        t "longlong" c-type (>>stack-align?)
-        t "ulonglong" c-type (>>stack-align?)
-    ] }
-} cond >>
-
 M: ppc machine-registers
     {
         { int-regs T{ range f 2 26 1 } }
@@ -65,17 +53,8 @@ M: ppc %replace loc>operand STW ;
 M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
 M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 
-: reserved-area-size ( -- n )
+HOOK: reserved-area-size os ( -- n )
-    os {
+HOOK: lr-save os ( -- n )
-        { linux [ 2 ] }
-        { macosx [ 6 ] }
-    } case cells ; foldable
-
-: lr-save ( -- n )
-    os {
-        { linux [ 1 ] }
-        { macosx [ 2 ] }
-    } case cells ; foldable
 
 : param@ ( n -- x ) reserved-area-size + ; inline
 
@@ -370,12 +349,17 @@ M: ppc %gc
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
-    0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
+    #! We use a volatile register (r11) here for scratch. Because
+    #! callback bodies have a prologue too, we cannot assume
+    #! that c_to_factor saved all non-volatile registers, so
+    #! we have to respect the C calling convention. Also, we
+    #! cannot touch any param-regs either.
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
     0 MFLR
     1 1 pick neg ADDI
-    scratch-reg 1 pick xt-save STW
+    11 1 pick xt-save STW
-    dup scratch-reg LI
+    dup 11 LI
-    scratch-reg 1 pick next-save STW
+    11 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
 M: ppc %epilogue ( n -- )
@@ -458,11 +442,6 @@ M: ppc %loop-entry ;
 M: int-regs return-reg drop 3 ;
 M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
 M: float-regs return-reg drop 1 ;
-M: float-regs param-regs 
-    drop os H{
-        { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
-        { linux { 1 2 3 4 5 6 7 8 } }
-    } at ;
 
 M: int-regs %save-param-reg drop 1 rot local@ STW ;
 M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
@@ -585,13 +564,6 @@ M: ppc %callback-value ( ctype -- )
     ! Unbox former top of data stack to return registers
     unbox-return ;
 
-M: ppc value-structs?
-    #! On Linux/PPC, value structs are passed in the same way
-    #! as reference structs, we just have to make a copy first.
-    os linux? not ;
-
-M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
-
 M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
 
 M: ppc struct-small-enough? ( size -- ? ) drop f ;
@@ -601,3 +573,10 @@ M: ppc %box-small-struct
 
 M: ppc %unbox-small-struct
     drop "No small structs" throw ;
+
+USE: vocabs.loader
+
+{
+    { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
+    { [ os linux? ] [ "cpu.ppc.linux" require ] }
+} cond

basis/cpu/x86/32/32.factor

@@ -26,6 +26,8 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 EAX ;
 M: x86.32 temp-reg-2 ECX ;
 
+M: x86.32 reserved-area-size 0 ;
+
 M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
 
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
@@ -272,6 +274,12 @@ M: x86.32 %callback-return ( n -- )
         [ drop 0 ]
     } cond RET ;
 
+M: x86.32 dummy-stack-params? f ;
+
+M: x86.32 dummy-int-params? f ;
+
+M: x86.32 dummy-fp-params? f ;
+
 os windows? [
     cell "longlong" c-type (>>align)
     cell "ulonglong" c-type (>>align)

basis/cpu/x86/32/bootstrap.factor

@@ -6,6 +6,7 @@ IN: bootstrap.x86
 
 4 \ cell set
 
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
 : shift-arg ( -- reg ) ECX ;
 : div-arg ( -- reg ) EAX ;
 : mod-arg ( -- reg ) EDX ;

basis/cpu/x86/64/64.factor

@@ -24,14 +24,13 @@ M: x86.64 stack-reg RSP ;
 M: x86.64 temp-reg-1 RAX ;
 M: x86.64 temp-reg-2 RCX ;
 
+: param-reg-1 int-regs param-regs first ; inline
+: param-reg-2 int-regs param-regs second ; inline
+: param-reg-3 int-regs param-regs third ; inline
+
 M: int-regs return-reg drop RAX ;
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
-
 M: float-regs return-reg drop XMM0 ;
 
-M: float-regs param-regs
-    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-
 M: x86.64 rel-literal-x86 rc-relative rel-literal ;
 
 M: x86.64 %prologue ( n -- )
@@ -42,13 +41,13 @@ M: x86.64 %prologue ( n -- )
 
 M: stack-params %load-param-reg
     drop
-    >r R11 swap stack@ MOV
+    >r R11 swap param@ MOV
-    r> stack@ R11 MOV ;
+    r> param@ R11 MOV ;
 
 M: stack-params %save-param-reg
     drop
     R11 swap next-stack@ MOV
-    stack@ R11 MOV ;
+    param@ R11 MOV ;
 
 : with-return-regs ( quot -- )
     [
@@ -57,40 +56,9 @@ M: stack-params %save-param-reg
         call
     ] with-scope ; inline
 
-! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
-
-: struct-types&offset ( struct-type -- pairs )
-    fields>> [
-        [ type>> ] [ offset>> ] bi 2array
-    ] map ;
-
-: split-struct ( pairs -- seq )
-    [
-        [ 8 mod zero? [ t , ] when , ] assoc-each
-    ] { } make { t } split harvest ;
-
-: flatten-small-struct ( c-type -- seq )
-    struct-types&offset split-struct [
-        [ c-type c-type-reg-class ] map
-        int-regs swap member? "void*" "double" ? c-type
-    ] map ;
-
-: flatten-large-struct ( c-type -- seq )
-    heap-size cell align
-    cell /i "__stack_value" c-type <repetition> ;
-
-M: struct-type flatten-value-type ( type -- seq )
-    dup heap-size 16 > [
-        flatten-large-struct
-    ] [
-        flatten-small-struct
-    ] if ;
-
 M: x86.64 %prepare-unbox ( -- )
     ! First parameter is top of stack
-    RDI R14 [] MOV
+    param-reg-1 R14 [] MOV
     R14 cell SUB ;
 
 M: x86.64 %unbox ( n reg-class func -- )
@@ -103,29 +71,29 @@ M: x86.64 %unbox-long-long ( n func -- )
     int-regs swap %unbox ;
 
 : %unbox-struct-field ( c-type i -- )
-    ! Alien must be in RDI.
+    ! Alien must be in param-reg-1.
-    RDI swap cells [+] swap reg-class>> {
+    R11 swap cells [+] swap reg-class>> {
         { int-regs [ int-regs get pop swap MOV ] }
         { double-float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
 
 M: x86.64 %unbox-small-struct ( c-type -- )
-    ! Alien must be in RDI.
+    ! Alien must be in param-reg-1.
     "alien_offset" f %alien-invoke
-    ! Move alien_offset() return value to RDI so that we don't
+    ! Move alien_offset() return value to R11 so that we don't
     ! clobber it.
-    RDI RAX MOV
+    R11 RAX MOV
     [
-        flatten-small-struct [ %unbox-struct-field ] each-index
+        flatten-value-type [ %unbox-struct-field ] each-index
     ] with-return-regs ;
 
 M: x86.64 %unbox-large-struct ( n c-type -- )
-    ! Source is in RDI
+    ! Source is in param-reg-1
     heap-size
     ! Load destination address
-    RSI rot stack@ LEA
+    param-reg-2 rot param@ LEA
     ! Load structure size
-    RDX swap MOV
+    param-reg-3 swap MOV
     ! Copy the struct to the C stack
     "to_value_struct" f %alien-invoke ;
 
@@ -144,10 +112,7 @@ M: x86.64 %box ( n reg-class func -- )
 M: x86.64 %box-long-long ( n func -- )
     int-regs swap %box ;
 
-M: x86.64 struct-small-enough? ( size -- ? )
+: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
-    heap-size 2 cells <= ;
-
-: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
 
 : %box-struct-field ( c-type i -- )
     box-struct-field@ swap reg-class>> {
@@ -158,21 +123,21 @@ M: x86.64 struct-small-enough? ( size -- ? )
 M: x86.64 %box-small-struct ( c-type -- )
     #! Box a <= 16-byte struct.
     [
-        [ flatten-small-struct [ %box-struct-field ] each-index ]
+        [ flatten-value-type [ %box-struct-field ] each-index ]
-        [ RDX swap heap-size MOV ] bi
+        [ param-reg-3 swap heap-size MOV ] bi
-        RDI 0 box-struct-field@ MOV
+        param-reg-1 0 box-struct-field@ MOV
-        RSI 1 box-struct-field@ MOV
+        param-reg-2 1 box-struct-field@ MOV
         "box_small_struct" f %alien-invoke
     ] with-return-regs ;
 
 : struct-return@ ( n -- operand )
-    [ stack-frame get params>> ] unless* stack@ ;
+    [ stack-frame get params>> ] unless* param@ ;
 
 M: x86.64 %box-large-struct ( n c-type -- )
     ! Struct size is parameter 2
-    RSI swap heap-size MOV
+    param-reg-2 swap heap-size MOV
     ! Compute destination address
-    RDI swap struct-return@ LEA
+    param-reg-1 swap struct-return@ LEA
     ! Copy the struct from the C stack
     "box_value_struct" f %alien-invoke ;
 
@@ -180,7 +145,7 @@ M: x86.64 %prepare-box-struct ( -- )
     ! Compute target address for value struct return
     RAX f struct-return@ LEA
     ! Store it as the first parameter
-    0 stack@ RAX MOV ;
+    0 param@ RAX MOV ;
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
@@ -200,7 +165,7 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    RDI swap %load-indirect
+    param-reg-1 swap %load-indirect
     "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
@@ -208,11 +173,11 @@ M: x86.64 %callback-value ( ctype -- )
     %prepare-unbox
     ! Save top of data stack
     RSP 8 SUB
-    RDI PUSH
+    param-reg-1 PUSH
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
-    ! Put former top of data stack in RDI
+    ! Put former top of data stack in param-reg-1
-    RDI POP
+    param-reg-1 POP
     RSP 8 ADD
     ! Unbox former top of data stack to return registers
     unbox-return ;
@@ -223,3 +188,10 @@ enable-alien-4-intrinsics
 
 ! SSE2 is always available on x86-64.
 enable-float-intrinsics
+
+USE: vocabs.loader
+
+{
+    { [ os unix? ] [ "cpu.x86.64.unix" require ] }
+    { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
+} cond

basis/cpu/x86/64/bootstrap.factor

@@ -9,8 +9,6 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) RCX ;
 : div-arg ( -- reg ) RAX ;
 : mod-arg ( -- reg ) RDX ;
-: arg0 ( -- reg ) RDI ;
-: arg1 ( -- reg ) RSI ;
 : temp-reg ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : ds-reg ( -- reg ) R14 ;

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

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: arg0 ( -- reg ) RDI ;
+: arg1 ( -- reg ) RSI ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
+call

basis/cpu/x86/64/unix/tags.txt

@@ -0,0 +1 @@
+unportable

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

@@ -0,0 +1,54 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences math splitting make assocs
+kernel layouts system alien.c-types alien.structs
+cpu.architecture cpu.x86.assembler cpu.x86
+compiler.codegen compiler.cfg.registers ;
+IN: cpu.x86.64.unix
+
+M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+
+M: float-regs param-regs
+    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+
+M: x86.64 reserved-area-size 0 ;
+
+! The ABI for passing structs by value is pretty messed up
+<< "void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class) >>
+
+: struct-types&offset ( struct-type -- pairs )
+    fields>> [
+        [ type>> ] [ offset>> ] bi 2array
+    ] map ;
+
+: split-struct ( pairs -- seq )
+    [
+        [ 8 mod zero? [ t , ] when , ] assoc-each
+    ] { } make { t } split harvest ;
+
+: flatten-small-struct ( c-type -- seq )
+    struct-types&offset split-struct [
+        [ c-type c-type-reg-class ] map
+        int-regs swap member? "void*" "double" ? c-type
+    ] map ;
+
+: flatten-large-struct ( c-type -- seq )
+    heap-size cell align
+    cell /i "__stack_value" c-type <repetition> ;
+
+M: struct-type flatten-value-type ( type -- seq )
+    dup heap-size 16 > [
+        flatten-large-struct
+    ] [
+        flatten-small-struct
+    ] if ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+    heap-size 2 cells <= ;
+
+M: x86.64 dummy-stack-params? f ;
+
+M: x86.64 dummy-int-params? f ;
+
+M: x86.64 dummy-fp-params? f ;

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

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 8 bootstrap-cells ;
+: arg0 ( -- reg ) RCX ;
+: arg1 ( -- reg ) RDX ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
+call

basis/cpu/x86/64/winnt/tags.txt

@@ -0,0 +1 @@
+unportable

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

@@ -0,0 +1,26 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel layouts system math alien.c-types
+compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
+IN: cpu.x86.64.winnt
+
+M: int-regs param-regs drop { RCX RDX R8 R9 } ;
+
+M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
+
+M: x86.64 reserved-area-size 4 cells ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+    heap-size cell <= ;
+
+M: x86.64 dummy-stack-params? f ;
+
+M: x86.64 dummy-int-params? t ;
+
+M: x86.64 dummy-fp-params? t ;
+
+<<
+"longlong" "ptrdiff_t" typedef
+"int" "long" typedef
+"uint" "ulong" typedef
+>>

basis/cpu/x86/bootstrap.factor

@@ -10,8 +10,6 @@ big-endian off
 
 1 jit-code-format set
 
-: stack-frame-size ( -- n ) 4 bootstrap-cells ;
-
 [
     ! Load word
     temp-reg 0 MOV
@@ -30,7 +28,7 @@ big-endian off
     temp-reg 0 MOV                             ! load XT
     stack-frame-size PUSH                      ! save stack frame size
     temp-reg PUSH                              ! push XT
-    arg1 PUSH                                  ! alignment
+    stack-reg stack-frame-size 3 bootstrap-cells - SUB   ! alignment
 ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
 
 [
@@ -302,14 +300,14 @@ big-endian off
     shift-arg ds-reg [] MOV                    ! load shift count
     shift-arg tag-bits get SAR                 ! untag shift count
     ds-reg bootstrap-cell SUB                  ! adjust stack pointer
-    arg0 ds-reg [] MOV                         ! load value
+    temp-reg ds-reg [] MOV                     ! load value
-    arg1 arg0 MOV                              ! make a copy
+    arg1 temp-reg MOV                          ! make a copy
     arg1 CL SHL                                ! compute positive shift value in arg1
     shift-arg NEG                              ! compute negative shift value in arg0
-    arg0 CL SAR
+    temp-reg CL SAR
-    arg0 tag-mask get bitnot AND
+    temp-reg tag-mask get bitnot AND
     shift-arg 0 CMP                            ! if shift count was negative, move arg0 to arg1
-    arg1 arg0 CMOVGE
+    arg1 temp-reg CMOVGE
     ds-reg [] arg1 MOV                         ! push to stack
 ] f f f \ fixnum-shift-fast define-sub-primitive
 

basis/cpu/x86/x86.factor

@@ -39,12 +39,15 @@ M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 : align-stack ( n -- n' )
     os macosx? cpu x86.64? or [ 16 align ] when ;
 
+HOOK: reserved-area-size cpu ( -- n )
+
 M: x86 stack-frame-size ( stack-frame -- i )
     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
     [ params>> ]
     [ return>> ]
     tri + +
     3 cells +
+    reserved-area-size +
     align-stack ;
 
 M: x86 %call ( label -- ) CALL ;
@@ -464,8 +467,10 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
+: param@ ( n -- op ) reserved-area-size + stack@ ;
+
 : spill-integer-base ( stack-frame -- n )
-    [ params>> ] [ return>> ] bi + ;
+    [ params>> ] [ return>> ] bi + reserved-area-size + ;
 
 : spill-integer@ ( n -- op )
     cells
@@ -473,10 +478,9 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
     + stack@ ;
 
 : spill-float-base ( stack-frame -- n )
+    [ spill-integer-base ]
     [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    [ params>> ]
+    bi + ;
-    [ return>> ]
-    tri + + ;
 
 : spill-float@ ( n -- op )
     double-float-regs reg-size *
@@ -491,16 +495,16 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
 
 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
-M: int-regs %save-param-reg drop >r stack@ r> MOV ;
+M: int-regs %save-param-reg drop >r param@ r> MOV ;
-M: int-regs %load-param-reg drop swap stack@ MOV ;
+M: int-regs %load-param-reg drop swap param@ MOV ;
 
 GENERIC: MOVSS/D ( dst src reg-class -- )
 
 M: single-float-regs MOVSS/D drop MOVSS ;
 M: double-float-regs MOVSS/D drop MOVSD ;
 
-M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
+M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
-M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
+M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
 
 GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( n reg-class -- )
@@ -516,8 +520,6 @@ M: x86 %prepare-alien-invoke
     temp-reg-1 2 cells [+] ds-reg MOV
     temp-reg-1 3 cells [+] rs-reg MOV ;
 
-M: x86 fp-shadows-int? ( -- ? ) f ;
-
 M: x86 value-structs? t ;
 
 M: x86 small-enough? ( n -- ? )

basis/fry/fry.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences combinators parser splitting math
-quotations arrays make qualified words ;
+quotations arrays make words ;
 IN: fry
 
 : _ ( -- * ) "Only valid inside a fry" throw ;

basis/math/functions/functions-tests.factor

@@ -76,6 +76,25 @@ IN: math.functions.tests
     gcd nip
 ] unit-test
 
+[ 11 ] [
+    13262642990609552931815424
+    159151715887314635181785
+    gcd nip
+] unit-test
+
+[ 3 ] [
+    13262642990609552931
+    1591517158873146351
+    gcd nip
+] unit-test
+
+[ 26525285981219 ] [
+    132626429906095
+    159151715887314
+    gcd nip
+] unit-test
+
+
 : verify-gcd ( a b -- ? )
     2dup gcd
     >r rot * swap rem r> = ; 

basis/qualified/qualified-docs.factor

@@ -32,3 +32,14 @@ HELP: RENAME:
     "RENAME: + math => -"
     "2 3 - ! => 5" } } ;
 
+ARTICLE: "qualified" "Qualified word lookup"
+"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "."
+$nl
+"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
+{ $subsection POSTPONE: QUALIFIED: }
+{ $subsection POSTPONE: QUALIFIED-WITH: }
+{ $subsection POSTPONE: FROM: }
+{ $subsection POSTPONE: EXCLUDE: }
+{ $subsection POSTPONE: RENAME: } ;
+
+ABOUT: "qualified"

basis/qualified/qualified-tests.factor

@@ -1,24 +1,33 @@
-USING: tools.test qualified ;
+USING: tools.test qualified eval accessors parser ;
-IN: foo
+IN: qualified.tests.foo
 : x 1 ;
-IN: bar
+: y 5 ;
+IN: qualified.tests.bar
 : x 2 ;
-IN: baz
+: y 4 ;
+IN: qualified.tests.baz
 : x 3 ;
 
-QUALIFIED: foo
+QUALIFIED: qualified.tests.foo
-QUALIFIED: bar
+QUALIFIED: qualified.tests.bar
-[ 1 2 3 ] [ foo:x bar:x x ] unit-test
+[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
 
-QUALIFIED-WITH: bar p
+QUALIFIED-WITH: qualified.tests.bar p
 [ 2 ] [ p:x ] unit-test
 
-RENAME: x baz => y
+RENAME: x qualified.tests.baz => y
 [ 3 ] [ y ] unit-test
 
-FROM: baz => x ;
+FROM: qualified.tests.baz => x ;
 [ 3 ] [ x ] unit-test
+[ 3 ] [ y ] unit-test
 
-EXCLUDE: bar => x ;
+EXCLUDE: qualified.tests.bar => x ;
 [ 3 ] [ x ] unit-test
+[ 4 ] [ y ] unit-test
 
+[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
+[ error>> no-word-error? ] must-fail-with
+
+[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
+[ error>> no-word-error? ] must-fail-with

basis/qualified/qualified.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2007, 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences assocs hashtables parser lexer
-vocabs words namespaces vocabs.loader debugger sets ;
+vocabs words namespaces vocabs.loader debugger sets fry ;
 IN: qualified
 
 : define-qualified ( vocab-name prefix-name -- )
     [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
-    [ -rot >r append r> ] curry assoc-map
+    '[ [ [ _ ] dip append ] dip ] assoc-map
     use get push ;
 
 : QUALIFIED:
@@ -19,27 +19,27 @@ IN: qualified
 
 : expect=> ( -- ) scan "=>" assert= ;
 
-: partial-vocab ( words name -- assoc )
+: partial-vocab ( words vocab -- assoc )
-    dupd [
+    '[ dup _ lookup [ no-word-error ] unless* ]
-        lookup [ "No such word: " swap append throw ] unless*
+    { } map>assoc ;
-    ] curry map zip ;
-
-: partial-vocab-ignoring ( words name -- assoc )
-    [ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
-
-: EXCLUDE:
-    #! Syntax: EXCLUDE: vocab => words ... ;
-    scan expect=>
-    ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
 
 : FROM:
     #! Syntax: FROM: vocab => words... ;
     scan dup load-vocab drop expect=>
     ";" parse-tokens swap partial-vocab use get push ; parsing
 
+: partial-vocab-excluding ( words vocab -- assoc )
+    [ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
+
+: EXCLUDE:
+    #! Syntax: EXCLUDE: vocab => words ... ;
+    scan expect=>
+    ";" parse-tokens swap partial-vocab-excluding use get push ; parsing
+
 : RENAME:
     #! Syntax: RENAME: word vocab => newname
-    scan scan dup load-vocab drop lookup [ "No such word" throw ] unless*
+    scan scan dup load-vocab drop
+    dupd lookup [ ] [ no-word-error ] ?if
     expect=>
     scan associate use get push ; parsing
 

basis/regexp/parser/parser.factor

@@ -233,15 +233,22 @@ ERROR: invalid-range a b ;
 SINGLETON: beginning-of-input
 SINGLETON: end-of-input
 
-! : beginning-of-input ( -- obj ) 
+: newlines ( -- obj1 obj2 obj3 )
-: handle-front-anchor ( -- ) front-anchor push-stack ;
-: end-of-line ( -- obj )
-    end-of-input
     CHAR: \r <constant>
     CHAR: \n <constant>
-    2dup 2array <concatenation> 4array <alternation> lookahead boa ;
+    2dup 2array <concatenation> ;
 
-: handle-back-anchor ( -- ) end-of-line push-stack ;
+: beginning-of-line ( -- obj )
+    beginning-of-input newlines 4array <alternation> lookbehind boa ;
+
+: end-of-line ( -- obj )
+    end-of-input newlines 4array <alternation> lookahead boa ;
+
+: handle-front-anchor ( -- )
+    get-multiline beginning-of-line beginning-of-input ? push-stack ;
+
+: handle-back-anchor ( -- )
+    get-multiline end-of-line end-of-input ? push-stack ;
 
 ERROR: bad-character-class obj ;
 ERROR: expected-posix-class ;
@@ -412,16 +419,11 @@ DEFER: handle-left-bracket
     [ [ push ] keep current-regexp get (>>stack) ]
     [ finish-regexp-parse push-stack ] bi* ;
 
-
 : parse-regexp-token ( token -- ? )
     {
-! todo: only match these at beginning/end of regexp
+        { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
-        { CHAR: ^ [ handle-front-anchor t ] }
-        { CHAR: $ [ handle-back-anchor t ] }
-
-        { CHAR: . [ handle-dot t ] }
-        { CHAR: ( [ handle-left-parenthesis t ] }
         { CHAR: ) [ handle-right-parenthesis f ] }
+        { CHAR: . [ handle-dot t ] }
         { CHAR: | [ handle-pipe t ] }
         { CHAR: ? [ handle-question t ] }
         { CHAR: * [ handle-star t ] }
@@ -429,16 +431,28 @@ DEFER: handle-left-bracket
         { CHAR: { [ handle-left-brace t ] }
         { CHAR: [ [ handle-left-bracket t ] }
         { CHAR: \ [ handle-escape t ] }
-        [ <constant> push-stack t ]
+        [
+            dup CHAR: $ = peek1 f = and [
+                drop
+                handle-back-anchor f
+            ] [
+                <constant> push-stack t
+            ] if
+        ]
     } case ;
 
 : (parse-regexp) ( -- )
     read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
 
+: parse-regexp-beginning ( -- )
+    peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
+
 : parse-regexp ( regexp -- )
     dup current-regexp [
         raw>> [
-            <string-reader> [ (parse-regexp) ] with-input-stream
+            <string-reader> [
+                parse-regexp-beginning (parse-regexp)
+            ] with-input-stream
         ] unless-empty
         current-regexp get
         stack finish-regexp-parse

basis/regexp/regexp-tests.factor

@@ -331,4 +331,3 @@ IN: regexp-tests
 [ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
 
 [ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-

basis/regexp/regexp.factor

@@ -92,7 +92,6 @@ IN: regexp
     reversed-regexp initial-option
     construct-regexp ;
 
-
 : parsing-regexp ( accum end -- accum )
     lexer get dup skip-blank
     [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
@@ -112,7 +111,6 @@ IN: regexp
 : R{ CHAR: } parsing-regexp ; parsing
 : R| CHAR: | parsing-regexp ; parsing
 
-
 : find-regexp-syntax ( string -- prefix suffix )
     {
         { "R/ "  "/"  }

basis/regexp/traversal/traversal.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators kernel math math.ranges
 quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
+combinators.short-circuit regexp.utils prettyprint regexp.nfa
+shuffle ;
 IN: regexp.traversal
 
 TUPLE: dfa-traverser
@@ -23,8 +24,7 @@ TUPLE: dfa-traverser
     [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
     dfa-traverser new
         swap >>traversal-flags
-        swap [ start-state>> >>current-state ] keep
+        swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
-        >>dfa-table
         swap >>text
         t >>traverse-forward
         0 >>start-index
@@ -116,7 +116,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     V{ } clone >>matches ;
 
 : match-literal ( transition from-state table -- to-state/f )
-    transitions>> at* [ at ] [ 2drop f ] if ;
+    transitions>> at at ;
 
 : match-class ( transition from-state table -- to-state/f )
     transitions>> at* [
@@ -124,8 +124,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     ] [ drop ] if ;
 
 : match-default ( transition from-state table -- to-state/f )
-    [ nip ] dip transitions>> at*
+    nipd transitions>> at t swap at ;
-    [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
 
 : match-transition ( obj from-state dfa -- to-state/f )
     { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;

basis/ui/gadgets/lists/lists.factor

@@ -97,7 +97,7 @@ M: list focusable-child* drop t ;
     ] if ;
 
 : select-gadget ( gadget list -- )
-    swap over children>> index
+    tuck children>> index
     [ swap select-index ] [ drop ] if* ;
 
 : clamp-loc ( point max -- point )

basis/ui/gadgets/scrollers/scrollers.factor

@@ -41,7 +41,7 @@ scroller H{
         dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add
         dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add
 
-        swap over model>> <viewport> >>viewport
+        tuck model>> <viewport> >>viewport
         dup viewport>> @center grid-add ;
 
 : <scroller> ( gadget -- scroller ) scroller new-scroller ;

build-support/factor.sh

@@ -60,10 +60,11 @@ check_gcc_version() {
     GCC_VERSION=`$CC --version`
     check_ret gcc
     if [[ $GCC_VERSION == *3.3.* ]] ; then
-        $ECHO "bad!"
         $ECHO "You have a known buggy version of gcc (3.3)"
         $ECHO "Install gcc 3.4 or higher and try again."
         exit 3
+    elif [[ $GCC_VERSION == *4.3.* ]] ; then
+       MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
     fi
     $ECHO "ok."
 }
@@ -270,19 +271,23 @@ check_os_arch_word() {
 
 set_build_info() {
     check_os_arch_word
-    MAKE_TARGET=$OS-$ARCH-$WORD
-    MAKE_IMAGE_TARGET=$ARCH.$WORD
-    BOOT_IMAGE=boot.$ARCH.$WORD.image
     if [[ $OS == macosx && $ARCH == ppc ]] ; then
-        MAKE_IMAGE_TARGET=$OS-$ARCH
+        MAKE_IMAGE_TARGET=macosx-ppc
-        MAKE_TARGET=$OS-$ARCH
+        MAKE_TARGET=macosx-ppc
-        BOOT_IMAGE=boot.macosx-ppc.image
+    elif [[ $OS == linux && $ARCH == ppc ]] ; then
-    fi
+        MAKE_IMAGE_TARGET=linux-ppc
-    if [[ $OS == linux && $ARCH == ppc ]] ; then
+        MAKE_TARGET=linux-ppc
-        MAKE_IMAGE_TARGET=$OS-$ARCH
+    elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
-        MAKE_TARGET=$OS-$ARCH
+        MAKE_IMAGE_TARGET=winnt-x86.64
-        BOOT_IMAGE=boot.linux-ppc.image
+        MAKE_TARGET=winnt-x86-64
+    elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
+        MAKE_IMAGE_TARGET=unix-x86.64
+        MAKE_TARGET=$OS-x86-64
+    else
+        MAKE_IMAGE_TARGET=$ARCH.$WORD
+        MAKE_TARGET=$OS-$ARCH-$WORD
     fi
+    BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
 }
 
 parse_build_info() {
@@ -335,7 +340,7 @@ cd_factor() {
 }
 
 invoke_make() {
-   $MAKE $*
+   $MAKE $MAKE_OPTS $*
    check_ret $MAKE
 }
 

core/bootstrap/primitives.factor

@@ -20,7 +20,8 @@ H{ } clone sub-primitives set
 
 "resource:basis/cpu/" architecture get {
     { "x86.32" "x86/32" }
-    { "x86.64" "x86/64" }
+    { "winnt-x86.64" "x86/64/winnt" }
+    { "unix-x86.64" "x86/64/unix" }
     { "linux-ppc" "ppc/linux" }
     { "macosx-ppc" "ppc/macosx" }
     { "arm" "arm" }

core/math/integers/integers-tests.factor

@@ -101,8 +101,13 @@ unit-test
 [ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
 [ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
 [ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
+[ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test
 [ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
+[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test
 [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
+[ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test
+[ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test
+[ 530505719624382123 ] [ 13262642990609552931 1591517158873146351 mod ] unit-test
 
 [ -351382792 ] [ -43922849 3 shift ] unit-test
 

core/parser/parser-docs.factor

@@ -69,7 +69,7 @@ $nl
 { $subsection POSTPONE: PRIVATE> }
 { $subsection "vocabulary-search-errors" }
 { $subsection "vocabulary-search-shadow" }
-{ $see-also "words" } ;
+{ $see-also "words" "qualified" } ;
 
 ARTICLE: "reading-ahead" "Reading ahead"
 "Parsing words can consume input:"

core/parser/parser.factor

@@ -71,10 +71,10 @@ ERROR: no-current-vocab ;
         ] keep
     ] { } map>assoc ;
 
-TUPLE: no-word-error name ;
+ERROR: no-word-error name ;
 
 : no-word ( name -- newword )
-    dup no-word-error boa
+    dup \ no-word-error boa
     swap words-named [ forward-reference? not ] filter
     word-restarts throw-restarts
     dup vocabulary>> (use+) ;

extra/graphics/bitmap/bitmap.factor

@@ -5,7 +5,7 @@ USING: alien arrays byte-arrays combinators summary
 io.backend graphics.viewer io io.binary io.files kernel libc
 math math.functions namespaces opengl opengl.gl prettyprint
 sequences strings ui ui.gadgets.panes io.encodings.binary
-accessors ;
+accessors grouping ;
 IN: graphics.bitmap
 
 ! Currently can only handle 24bit bitmaps.
@@ -23,16 +23,25 @@ TUPLE: bitmap magic size reserved offset header-length width
         swap [ >>array ] [ >>color-index ] bi
         24 >>bit-count ;
 
-: raw-bitmap>string ( str n -- str )
+: 8bit>array ( bitmap -- array )
+    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: 4bit>array ( bitmap -- array )
+    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: raw-bitmap>array ( bitmap -- array )
+    dup bit-count>>
     {
         { 32 [ "32bit" throw ] }
-        { 24 [ ] }
+        { 24 [ color-index>> ] }
         { 16 [ "16bit" throw ] }
-        { 8 [ "8bit" throw ] }
+        { 8 [ 8bit>array ] }
-        { 4 [ "4bit" throw ] }
+        { 4 [ 4bit>array ] }
         { 2 [ "2bit" throw ] }
         { 1 [ "1bit" throw ] }
-    } case ;
+    } case >byte-array ;
 
 ERROR: bitmap-magic ;
 
@@ -72,13 +81,12 @@ M: bitmap-magic summary
 
 : load-bitmap ( path -- bitmap )
     normalize-path binary [
-        T{ bitmap } clone
+        bitmap new
             dup parse-file-header
             dup parse-bitmap-header
             dup parse-bitmap
     ] with-file-reader
-    dup color-index>> over bit-count>>
+    dup raw-bitmap>array >>array ;
-    raw-bitmap>string >byte-array >>array ;
 
 : save-bitmap ( bitmap path -- )
     binary [
@@ -118,6 +126,8 @@ M: bitmap draw-image ( bitmap -- )
         bit-count>> {
             ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
             { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+            { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+            { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
         } case
     ] keep array>> glDrawPixels ;
 

extra/hexdump/hexdump-tests.factor

@@ -6,3 +6,6 @@ USING: hexdump kernel sequences tools.test ;
 
 [ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f  !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
 
+
+[
+    "Length: 3, 3h\n00000000h: 01 02 03                                        ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test

extra/hexdump/hexdump.factor

@@ -21,9 +21,9 @@ IN: hexdump
     [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
 
 : >ascii ( bytes -- str )
-    [ [ printable? ] keep CHAR: . ? ] map ;
+    [ [ printable? ] keep CHAR: . ? ] "" map-as ;
 
-: write-hex-line ( str lineno -- )
+: write-hex-line ( bytes lineno -- )
     write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
 
 PRIVATE>

extra/mason/platform/platform.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel system accessors namespaces splitting sequences
-mason.config ;
+mason.config bootstrap.image ;
 IN: mason.platform
 
 : platform ( -- string )
@@ -11,7 +11,7 @@ IN: mason.platform
     target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
 
 : boot-image-arch ( -- string )
-    target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ;
+    target-os get target-cpu get arch ;
 
 : boot-image-name ( -- string )
     "boot." boot-image-arch ".image" 3append ;

extra/mason/release/branch/branch-tests.factor

@@ -12,7 +12,7 @@ USING: mason.release.branch mason.config tools.test namespaces ;
     ] with-scope
 ] unit-test
 
-[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
+[ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
     [
         "joe" image-username set
         "blah.com" image-host set

extra/mason/release/tidy/tidy.factor

@@ -1,16 +1,14 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces continuations debugger sequences fry
-io.files io.launcher mason.common mason.platform
+io.files io.launcher bootstrap.image qualified mason.common
 mason.config ;
+FROM: mason.config => target-os ;
 IN: mason.release.tidy
 
 : common-files ( -- seq )
+    images [ boot-image-name ] map
     {
-        "boot.x86.32.image"
-        "boot.x86.64.image"
-        "boot.macosx-ppc.image"
-        "boot.linux-ppc.image"
         "vm"
         "temp"
         "logs"
@@ -20,7 +18,8 @@ IN: mason.release.tidy
         "unmaintained"
         "unfinished"
         "build-support"
-    } ;
+    }
+    append ;
 
 : remove-common-files ( -- )
     common-files [ delete-tree ] each ;

extra/project-euler/project-euler.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: definitions io io.files kernel math math.parser project-euler.ave-time
-    sequences vocabs vocabs.loader
+    sequences vocabs vocabs.loader prettyprint
     project-euler.001 project-euler.002 project-euler.003 project-euler.004
     project-euler.005 project-euler.006 project-euler.007 project-euler.008
     project-euler.009 project-euler.010 project-euler.011 project-euler.012
@@ -33,7 +33,7 @@ IN: project-euler
 
 : solution-path ( n -- str/f )
     number>euler "project-euler." prepend
-    vocab where dup [ first ] when ;
+    vocab where dup [ first <pathname> ] when ;
 
 PRIVATE>
 
@@ -43,8 +43,8 @@ PRIVATE>
 : run-project-euler ( -- )
     problem-prompt dup problem-solved? [
         dup number>euler "project-euler." prepend run
-        "Answer: " swap dup number? [ number>string ] when append print
+        "Answer: " write dup number? [ number>string ] when print
-        "Source: " swap solution-path append print
+        "Source: " write solution-path .
     ] [
         drop "That problem has not been solved yet..." print
     ] if ;

vm/Config.windows.nt.x86.64

@@ -1,5 +1,5 @@
 #WIN64_PATH=/k/MinGW/win64/bin
-WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
+#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
 CC=$(WIN64_PATH)-gcc.exe
 WINDRES=$(WIN64_PATH)-windres.exe
 include vm/Config.windows.nt

vm/bignum.c

@@ -1,7 +1,7 @@
 /* :tabSize=2:indentSize=2:noTabs=true:
 
 Copyright (C) 1989-94 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2007 Slava Pestov
+Portions copyright (C) 2004-2008 Slava Pestov
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,6 +45,7 @@ MIT in each case. */
  *  - Remove unused functions
  *  - Add local variable GC root recording
  *  - Remove s48 prefix from function names
+ *  - Various fixes for Win64
  */
 
 #include "master.h"
@@ -366,8 +367,6 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
 /* all below allocate memory */
 FOO_TO_BIGNUM(cell,CELL,CELL)
 FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
-FOO_TO_BIGNUM(long,long,unsigned long)
-FOO_TO_BIGNUM(ulong,unsigned long,unsigned long)
 FOO_TO_BIGNUM(long_long,s64,u64)
 FOO_TO_BIGNUM(ulong_long,u64,u64)
 
@@ -389,8 +388,6 @@ FOO_TO_BIGNUM(ulong_long,u64,u64)
 /* all of the below allocate memory */
 BIGNUM_TO_FOO(cell,CELL,CELL);
 BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
-BIGNUM_TO_FOO(long,long,unsigned long)
-BIGNUM_TO_FOO(ulong,unsigned long,unsigned long)
 BIGNUM_TO_FOO(long_long,s64,u64)
 BIGNUM_TO_FOO(ulong_long,u64,u64)
 
@@ -435,7 +432,7 @@ double_to_bignum(double x)
     bignum_digit_type digit;
     int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
     if (odd_bits > 0)
-      DTB_WRITE_DIGIT (1L << odd_bits);
+      DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits);
     while (start < scan)
       {
         if (significand == 0)
@@ -1117,7 +1114,7 @@ bignum_destructive_normalization(bignum_type source, bignum_type target,
   bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
   bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
   int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
-  bignum_digit_type mask = ((1L << shift_right) - 1);
+  bignum_digit_type mask = (((CELL)1 << shift_right) - 1);
   while (scan_source < end_source)
     {
       digit = (*scan_source++);
@@ -1139,7 +1136,7 @@ bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
   bignum_digit_type digit;
   bignum_digit_type carry = 0;
   int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
-  bignum_digit_type mask = ((1L << shift_right) - 1);
+  bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1);
   while (start < scan)
     {
       digit = (*--scan);
@@ -1489,7 +1486,7 @@ bignum_bitwise_not(bignum_type x)
 
 /* allocates memory */
 bignum_type
-bignum_arithmetic_shift(bignum_type arg1, long n)
+bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
 {
   if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
     return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
@@ -1550,14 +1547,14 @@ bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
 /* ash for the magnitude */
 /* assume arg1 is a big number, n is a long */
 bignum_type
-bignum_magnitude_ash(bignum_type arg1, long n)
+bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
 {
   bignum_type result = NULL;
   bignum_digit_type *scan1;
   bignum_digit_type *scanr;
   bignum_digit_type *end;
 
-  long digit_offset,bit_offset;
+  F_FIXNUM digit_offset,bit_offset;
 
   if (BIGNUM_ZERO_P (arg1)) return (arg1);
 
@@ -1642,10 +1639,6 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
   while (scanr < endr) {
     digit1 = (scan1 < end1) ? *scan1++ : 0;
     digit2 = (scan2 < end2) ? *scan2++ : 0;
-    /*
-    fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n",
-            op, endr - scanr, digit1, digit2);
-            */
     *scanr++ = (op == AND_OP) ? digit1 & digit2 :
                (op == IOR_OP) ? digit1 | digit2 :
                                 digit1 ^ digit2;
@@ -1856,8 +1849,8 @@ digit_stream_to_bignum(unsigned int n_digits,
     return (BIGNUM_ZERO ());
   if (n_digits == 1)
     {
-      long digit = ((long) ((*producer) (0)));
+      F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
-      return (long_to_bignum (negative_p ? (- digit) : digit));
+      return (fixnum_to_bignum (negative_p ? (- digit) : digit));
     }
   {
     bignum_length_type length;

vm/bignum.h

@@ -55,14 +55,10 @@ bignum_type bignum_quotient(bignum_type, bignum_type);
 bignum_type bignum_remainder(bignum_type, bignum_type);
 DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
 DLLEXPORT bignum_type cell_to_bignum(CELL);
-DLLEXPORT bignum_type long_to_bignum(long);
 DLLEXPORT bignum_type long_long_to_bignum(s64 n);
 DLLEXPORT bignum_type ulong_long_to_bignum(u64 n);
-DLLEXPORT bignum_type ulong_to_bignum(unsigned long);
 F_FIXNUM bignum_to_fixnum(bignum_type);
 CELL bignum_to_cell(bignum_type);
-long bignum_to_long(bignum_type);
-unsigned long bignum_to_ulong(bignum_type);
 s64 bignum_to_long_long(bignum_type);
 u64 bignum_to_ulong_long(bignum_type);
 bignum_type double_to_bignum(double);
@@ -71,7 +67,7 @@ double bignum_to_double(bignum_type);
 /* Added bitwise operators. */
 
 DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
-                   bignum_arithmetic_shift(bignum_type, long),
+                   bignum_arithmetic_shift(bignum_type, F_FIXNUM),
                    bignum_bitwise_and(bignum_type, bignum_type),
                    bignum_bitwise_ior(bignum_type, bignum_type),
                    bignum_bitwise_xor(bignum_type, bignum_type);
@@ -116,7 +112,7 @@ bignum_type bignum_maybe_new_sign(bignum_type, int);
 void bignum_destructive_copy(bignum_type, bignum_type);
 
 /* Added for bitwise operations. */
-bignum_type bignum_magnitude_ash(bignum_type arg1, long n);
+bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n);
 bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
 bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
 bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);

vm/callstack.c

@@ -116,6 +116,8 @@ CELL frame_executing(F_STACK_FRAME *frame)
 
 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
 {
+	if(frame->size == 0)
+		critical_error("Stack frame has zero size",(CELL)frame);
 	return (F_STACK_FRAME *)((CELL)frame - frame->size);
 }
 

vm/cpu-x86.32.S

@@ -10,13 +10,18 @@ and the callstack top is passed in EDX */
 #define DS_REG %esi
 #define RETURN_REG %eax
 
+#define NV_TEMP_REG %ebx
+
 #define CELL_SIZE 4
+#define STACK_PADDING 12
 
 #define PUSH_NONVOLATILE \
 	push %ebx ; \
+	push %ebp ; \
 	push %ebp
 
 #define POP_NONVOLATILE \
+	pop %ebp ; \
 	pop %ebp ; \
 	pop %ebx
 

vm/cpu-x86.64.S

@@ -1,34 +1,71 @@
 #include "asm.h"
 
-#define ARG0 %rdi
-#define ARG1 %rsi
 #define STACK_REG %rsp
 #define DS_REG %r14
 #define RETURN_REG %rax
 
 #define CELL_SIZE 8
+#define STACK_PADDING 56
+
+#define NV_TEMP_REG %rbp
+
+#ifdef WINDOWS
+
+	#define ARG0 %rcx
+	#define ARG1 %rdx
+	#define ARG2 %r8
+	#define ARG3 %r9
+
+	#define PUSH_NONVOLATILE \
+		push %r12 ; \
+		push %r13 ; \
+		push %rdi ; \
+		push %rsi ; \
+		push %rbx ; \
+		push %rbp ; \
+		push %rbp
+
+	#define POP_NONVOLATILE \
+		pop %rbp ; \
+		pop %rbp ; \
+		pop %rbx ; \
+		pop %rsi ; \
+		pop %rdi ; \
+		pop %r13 ; \
+		pop %r12
+
+#else
+
+	#define ARG0 %rdi
+	#define ARG1 %rsi
+	#define ARG2 %rdx
+	#define ARG3 %rcx
 
 	#define PUSH_NONVOLATILE \
 		push %rbx ; \
 		push %rbp ; \
 		push %r12 ; \
-	push %r13 ;
+		push %r13 ; \
+		push %r13
 
 	#define POP_NONVOLATILE \
+		pop %r13 ; \
 		pop %r13 ; \
 		pop %r12 ; \
 		pop %rbp ; \
 		pop %rbx
 
+#endif
+
 #define QUOT_XT_OFFSET 21
 
 /* We pass a function pointer to memcpy to work around a Mac OS X
 ABI limitation which would otherwise require us to do a bizzaro PC-relative
 trampoline to retrieve the function address */
 DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
-	sub %rdx,%rdi                      /* compute new stack pointer */
+	sub ARG2,ARG0                      /* compute new stack pointer */
-	mov %rdi,%rsp
+	mov ARG0,%rsp
-	call *%rcx                         /* call memcpy */
+	call *ARG3                         /* call memcpy */
 	ret                                /* return _with new stack_ */
 
 #include "cpu-x86.S"

vm/cpu-x86.S

@@ -1,31 +1,35 @@
 DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
 	PUSH_NONVOLATILE
-	push ARG0                             /* Save quot */
+	mov ARG0,NV_TEMP_REG
 
-	lea -CELL_SIZE(STACK_REG),ARG0        /* Save stack pointer */
+	/* Create register shadow area for Win64 */
+	sub $32,STACK_REG
+
+	/* Save stack pointer */
+	lea -CELL_SIZE(STACK_REG),ARG0
 	call MANGLE(save_callstack_bottom)
 
-	mov (STACK_REG),ARG0                  /* Pass quot as arg 1 */
+	/* Call quot-xt */
-	call *QUOT_XT_OFFSET(ARG0)            /* Call quot-xt */
+	mov NV_TEMP_REG,ARG0
+	call *QUOT_XT_OFFSET(ARG0)
+
+	/* Tear down register shadow area */
+	add $32,STACK_REG
 
-	POP ARG0
 	POP_NONVOLATILE
 	ret
 
 DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
-	mov ARG1,STACK_REG                    /* rewind_to */
+	/* rewind_to */
+	mov ARG1,STACK_REG                    
 	jmp *QUOT_XT_OFFSET(ARG0)
 
 DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
 	mov STACK_REG,ARG1           /* Save stack pointer */
-	push ARG1                    /* Alignment */
+	sub $STACK_PADDING,STACK_REG
-	push ARG1
-	push ARG1
 	call MANGLE(primitive_jit_compile)
 	mov RETURN_REG,ARG0          /* No-op on 32-bit */
-	pop ARG1                     /* OK to clobber ARG1 here */
+	add $STACK_PADDING,STACK_REG
-	pop ARG1
-	pop ARG1
         jmp *QUOT_XT_OFFSET(ARG0)    /* Call the quotation */
 
 #ifdef WINDOWS

vm/data_gc.c

@@ -438,6 +438,8 @@ void collect_gen_cards(CELL gen)
 old->new references */
 void collect_cards(void)
 {
+	GC_PRINT("Collect cards\n");
+
 	int i;
 	for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
 		collect_gen_cards(i);
@@ -465,7 +467,10 @@ void collect_callstack(F_CONTEXT *stacks)
 	{
 		CELL top = (CELL)stacks->callstack_top;
 		CELL bottom = (CELL)stacks->callstack_bottom;
+
+		GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
 		iterate_callstack(top,bottom,collect_stack_frame);
+		GC_PRINT("Done\n");
 	}
 }
 
@@ -481,6 +486,7 @@ void collect_gc_locals(void)
 the user environment and extra roots registered with REGISTER_ROOT */
 void collect_roots(void)
 {
+	GC_PRINT("Collect roots\n");
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);

vm/factor.c

@@ -167,7 +167,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 	}
 
 	init_factor(&p);
-
 	nest_stacks();
 
 	F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);

vm/math.c

@@ -363,13 +363,13 @@ CELL unbox_array_size(void)
 	case BIGNUM_TYPE:
 		{
 			bignum_type zero = untag_object(bignum_zero);
-			bignum_type max = ulong_to_bignum(ARRAY_SIZE_MAX);
+			bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
 			bignum_type n = untag_object(dpeek());
 			if(bignum_compare(n,zero) != bignum_comparison_less
 				&& bignum_compare(n,max) == bignum_comparison_less)
 			{
 				dpop();
-				return bignum_to_ulong(n);
+				return bignum_to_cell(n);
 			}
 			break;
 		}