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

basis/alien/structs/structs.factor

@@ -18,20 +18,16 @@ M: struct-type c-type-align align>> ;
 M: struct-type c-type-stack-align? drop f ;
 
 M: struct-type unbox-parameter
-    [ heap-size %unbox-struct ]
+    [ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
-    [ unbox-parameter ]
-    if-value-structs? ;
 
 M: struct-type unbox-return
-    f swap heap-size %unbox-struct ;
+    f swap %unbox-struct ;
 
 M: struct-type box-parameter
-    [ heap-size %box-struct ]
+    [ %box-struct ] [ box-parameter ] if-value-structs? ;
-    [ box-parameter ]
-    if-value-structs? ;
 
 M: struct-type box-return
-    f swap heap-size %box-struct ;
+    f swap %box-struct ;
 
 M: struct-type stack-size
     [ heap-size ] [ stack-size ] if-value-structs? ;

basis/compiler/generator/generator.factor

@@ -271,9 +271,7 @@ M: #return-recursive generate-node
 
 ! #alien-invoke
 : large-struct? ( ctype -- ? )
-    dup c-struct? [
+    dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
-        heap-size struct-small-enough? not
-    ] [ drop f ] if ;
 
 : alien-parameters ( params -- seq )
     dup parameters>>
@@ -304,10 +302,10 @@ M: #return-recursive generate-node
     alien-parameters parameter-sizes drop ;
 
 : alien-invoke-frame ( params -- n )
-    #! One cell is temporary storage, temp@
+    #! Two cells for temporary storage, temp@ and on x86.64,
-    dup return>> return-size
+    #! small struct return value unpacking
-    swap alien-stack-frame +
+    [ return>> return-size ] [ alien-stack-frame ] bi
-    cell + ;
+    + 2 cells + ;
 
 : set-stack-frame ( n -- )
     dup [ frame-required ] when* \ stack-frame set ;
@@ -361,17 +359,17 @@ M: float-regs inc-reg-class
     [ spill-param ] [ fastcall-param ] if
     [ param-reg ] keep ;
 
-: (flatten-int-type) ( size -- )
+: (flatten-int-type) ( size -- types )
-    cell /i "void*" c-type <repetition> % ;
+    cell /i "void*" c-type <repetition> ;
 
-GENERIC: flatten-value-type ( type -- )
+GENERIC: flatten-value-type ( type -- types )
 
-M: object flatten-value-type , ;
+M: object flatten-value-type 1array ;
 
-M: struct-type flatten-value-type ( type -- )
+M: struct-type flatten-value-type ( type -- types )
     stack-size cell align (flatten-int-type) ;
 
-M: long-long-type flatten-value-type ( type -- )
+M: long-long-type flatten-value-type ( type -- types )
     stack-size cell align (flatten-int-type) ;
 
 : flatten-value-types ( params -- params )
@@ -379,9 +377,9 @@ M: long-long-type flatten-value-type ( type -- )
     [
         0 [
             c-type
-            [ parameter-align (flatten-int-type) ] keep
+            [ parameter-align (flatten-int-type) % ] keep
             [ stack-size cell align + ] keep
-            flatten-value-type
+            flatten-value-type %
         ] reduce drop
     ] { } make ;
 

basis/compiler/tests/alien.factor

@@ -439,3 +439,109 @@ C-STRUCT: double-rect
 
 [ 1.0 2.0 3.0 4.0 ]
 [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
+
+C-STRUCT: test_struct_14
+{ "double" "x1" }
+{ "double" "x2" } ;
+
+FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
+
+[ 1.0 2.0 ] [
+    1.0 2.0 ffi_test_40
+    [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+] unit-test
+
+: callback-10 ( -- callback )
+    "test_struct_14" { "double" "double" } "cdecl"
+    [
+        "test_struct_14" <c-object>
+        [ set-test_struct_14-x2 ] keep
+        [ set-test_struct_14-x1 ] keep
+    ] alien-callback ;
+
+: callback-10-test ( x1 x2 callback -- result )
+    "test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
+
+[ 1.0 2.0 ] [
+    1.0 2.0 callback-10 callback-10-test
+    [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
+] unit-test
+
+FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
+
+[ 1 2.0 ] [
+    1 2.0 ffi_test_41
+    [ test-struct-12-a ] [ test-struct-12-x ] bi
+] unit-test
+
+: callback-11 ( -- callback )
+    "test-struct-12" { "int" "double" } "cdecl"
+    [
+        "test-struct-12" <c-object>
+        [ set-test-struct-12-x ] keep
+        [ set-test-struct-12-a ] keep
+    ] alien-callback ;
+
+: callback-11-test ( x1 x2 callback -- result )
+    "test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
+
+[ 1 2.0 ] [
+    1 2.0 callback-11 callback-11-test
+    [ test-struct-12-a ] [ test-struct-12-x ] bi
+] unit-test
+
+C-STRUCT: test_struct_15
+{ "float" "x" }
+{ "float" "y" } ;
+
+FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
+
+[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
+
+: callback-12 ( -- callback )
+    "test_struct_15" { "float" "float" } "cdecl"
+    [
+        "test_struct_15" <c-object>
+        [ set-test_struct_15-y ] keep
+        [ set-test_struct_15-x ] keep
+    ] alien-callback ;
+
+: callback-12-test ( x1 x2 callback -- result )
+    "test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
+
+[ 1.0 2.0 ] [
+    1.0 2.0 callback-12 callback-12-test
+    [ test_struct_15-x ] [ test_struct_15-y ] bi
+] unit-test
+
+C-STRUCT: test_struct_16
+{ "float" "x" }
+{ "int" "a" } ;
+
+FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
+
+[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
+
+: callback-13 ( -- callback )
+    "test_struct_16" { "float" "int" } "cdecl"
+    [
+        "test_struct_16" <c-object>
+        [ set-test_struct_16-a ] keep
+        [ set-test_struct_16-x ] keep
+    ] alien-callback ;
+
+: callback-13-test ( x1 x2 callback -- result )
+    "test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
+
+[ 1.0 2 ] [
+    1.0 2 callback-13 callback-13-test
+    [ test_struct_16-x ] [ test_struct_16-a ] bi
+] unit-test
+
+FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
+
+[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
+
+: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
+
+[ ] [ stack-frame-bustage 2drop ] unit-test

basis/cpu/architecture/architecture.factor

@@ -95,7 +95,7 @@ HOOK: %box-float cpu ( dst src -- )
 HOOK: small-enough? cpu ( n -- ? )
 
 ! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( size -- ? )
+HOOK: struct-small-enough? cpu ( heap-size -- ? )
 
 ! Do we pass explode value structs?
 HOOK: value-structs? cpu ( -- ? )
@@ -109,9 +109,9 @@ HOOK: %unbox cpu ( n reg-class func -- )
 
 HOOK: %unbox-long-long cpu ( n func -- )
 
-HOOK: %unbox-small-struct cpu ( size -- )
+HOOK: %unbox-small-struct cpu ( c-type -- )
 
-HOOK: %unbox-large-struct cpu ( n size -- )
+HOOK: %unbox-large-struct cpu ( n c-type -- )
 
 HOOK: %box cpu ( n reg-class func -- )
 
@@ -119,9 +119,9 @@ HOOK: %box-long-long cpu ( n func -- )
 
 HOOK: %prepare-box-struct cpu ( size -- )
 
-HOOK: %box-small-struct cpu ( size -- )
+HOOK: %box-small-struct cpu ( c-type -- )
 
-HOOK: %box-large-struct cpu ( n size -- )
+HOOK: %box-large-struct cpu ( n c-type -- )
 
 GENERIC: %save-param-reg ( stack reg reg-class -- )
 
@@ -169,14 +169,14 @@ PREDICATE: small-tagged < integer v>operand small-enough? ;
     [ [ nip ] prepose ] dip if ;
     inline
 
-: %unbox-struct ( n size -- )
+: %unbox-struct ( n c-type -- )
     [
         %unbox-small-struct
     ] [
         %unbox-large-struct
     ] if-small-struct ;
 
-: %box-struct ( n size -- )
+: %box-struct ( n c-type -- )
     [
         %box-small-struct
     ] [

basis/cpu/ppc/architecture/architecture.factor

@@ -195,12 +195,12 @@ M: ppc %unbox-long-long ( n func -- )
         4 1 rot cell + local@ STW
     ] when* ;
 
-M: ppc %unbox-large-struct ( n size -- )
+M: ppc %unbox-large-struct ( n c-type -- )
     ! Value must be in r3
     ! Compute destination address
     4 1 roll local@ ADDI
     ! Load struct size
-    5 LI
+    heap-size 5 LI
     ! Call the function
     "to_value_struct" f %alien-invoke ;
 
@@ -227,8 +227,9 @@ M: ppc %prepare-box-struct ( size -- )
     3 1 rot f struct-return@ ADDI
     3 1 0 local@ STW ;
 
-M: ppc %box-large-struct ( n size -- )
+M: ppc %box-large-struct ( n c-type -- )
     #! If n = f, then we're boxing a returned struct
+    heap-size
     [ swap struct-return@ ] keep
     ! Compute destination address
     3 1 roll ADDI

basis/cpu/x86/32/32.factor

@@ -28,6 +28,10 @@ M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
 
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
 
+M: x86.32 struct-small-enough? ( size -- ? )
+    heap-size { 1 2 4 8 } member?
+    os { linux netbsd solaris } member? not and ;
+
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs param-regs drop { } ;
@@ -73,62 +77,6 @@ M: object %load-param-reg 3drop ;
 
 M: object %save-param-reg 3drop ;
 
-M: x86.32 %prepare-unbox ( -- )
-    #! Move top of data stack to EAX.
-    EAX ESI [] MOV
-    ESI 4 SUB ;
-
-: (%unbox) ( func -- )
-    4 [
-        ! Push parameter
-        EAX PUSH
-        ! Call the unboxer
-        f %alien-invoke
-    ] with-aligned-stack ;
-
-M: x86.32 %unbox ( n reg-class func -- )
-    #! The value being unboxed must already be in EAX.
-    #! If n is f, we're unboxing a return value about to be
-    #! returned by the callback. Otherwise, we're unboxing
-    #! a parameter to a C function about to be called.
-    (%unbox)
-    ! Store the return value on the C stack
-    over [ store-return-reg ] [ 2drop ] if ;
-
-M: x86.32 %unbox-long-long ( n func -- )
-    (%unbox)
-    ! Store the return value on the C stack
-    [
-        dup stack@ EAX MOV
-        cell + stack@ EDX MOV
-    ] when* ;
-
-M: x86.32 %unbox-struct-2
-    #! Alien must be in EAX.
-    4 [
-        EAX PUSH
-        "alien_offset" f %alien-invoke
-        ! Load second cell
-        EDX EAX 4 [+] MOV
-        ! Load first cell
-        EAX EAX [] MOV
-    ] with-aligned-stack ;
-
-M: x86.32 %unbox-large-struct ( n size -- )
-    #! Alien must be in EAX.
-    ! Compute destination address
-    ECX ESP roll [+] LEA
-    12 [
-        ! Push struct size
-        PUSH
-        ! Push destination address
-        ECX PUSH
-        ! Push source address
-        EAX PUSH
-        ! Copy the struct to the stack
-        "to_value_struct" f %alien-invoke
-    ] with-aligned-stack ;
-
 : box@ ( n reg-class -- stack@ )
     #! Used for callbacks; we want to box the values given to
     #! us by the C function caller. Computes stack location of
@@ -172,8 +120,9 @@ M: x86.32 %box-long-long ( n func -- )
 : struct-return@ ( size n -- n )
     [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
 
-M: x86.32 %box-large-struct ( n size -- )
+M: x86.32 %box-large-struct ( n c-type -- )
     ! Compute destination address
+    heap-size
     [ swap struct-return@ ] keep
     ECX ESP roll [+] LEA
     8 [
@@ -191,7 +140,46 @@ M: x86.32 %prepare-box-struct ( size -- )
     ! Store it as the first parameter
     ESP [] EAX MOV ;
 
-M: x86.32 %unbox-struct-1
+M: x86.32 %box-small-struct ( c-type -- )
+    #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
+    12 [
+        heap-size PUSH
+        EDX PUSH
+        EAX PUSH
+        "box_small_struct" f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %prepare-unbox ( -- )
+    #! Move top of data stack to EAX.
+    EAX ESI [] MOV
+    ESI 4 SUB ;
+
+: (%unbox) ( func -- )
+    4 [
+        ! Push parameter
+        EAX PUSH
+        ! Call the unboxer
+        f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %unbox ( n reg-class func -- )
+    #! The value being unboxed must already be in EAX.
+    #! If n is f, we're unboxing a return value about to be
+    #! returned by the callback. Otherwise, we're unboxing
+    #! a parameter to a C function about to be called.
+    (%unbox)
+    ! Store the return value on the C stack
+    over [ store-return-reg ] [ 2drop ] if ;
+
+M: x86.32 %unbox-long-long ( n func -- )
+    (%unbox)
+    ! Store the return value on the C stack
+    [
+        dup stack@ EAX MOV
+        cell + stack@ EDX MOV
+    ] when* ;
+
+: %unbox-struct-1 ( -- )
     #! Alien must be in EAX.
     4 [
         EAX PUSH
@@ -200,13 +188,38 @@ M: x86.32 %unbox-struct-1
         EAX EAX [] MOV
     ] with-aligned-stack ;
 
-M: x86.32 %box-small-struct ( size -- )
+: %unbox-struct-2 ( -- )
-    #! Box a <= 8-byte struct returned in EAX:DX. OS X only.
+    #! Alien must be in EAX.
-    12 [
+    4 [
-        PUSH
-        EDX PUSH
         EAX PUSH
-        "box_small_struct" f %alien-invoke
+        "alien_offset" f %alien-invoke
+        ! Load second cell
+        EDX EAX 4 [+] MOV
+        ! Load first cell
+        EAX EAX [] MOV
+    ] with-aligned-stack ;
+
+M: x86 %unbox-small-struct ( size -- )
+    #! Alien must be in EAX.
+    heap-size cell align cell /i {
+        { 1 [ %unbox-struct-1 ] }
+        { 2 [ %unbox-struct-2 ] }
+    } case ;
+
+M: x86.32 %unbox-large-struct ( n c-type -- )
+    #! Alien must be in EAX.
+    heap-size
+    ! Compute destination address
+    ECX ESP roll [+] LEA
+    12 [
+        ! Push struct size
+        PUSH
+        ! Push destination address
+        ECX PUSH
+        ! Push source address
+        EAX PUSH
+        ! Copy the struct to the stack
+        "to_value_struct" f %alien-invoke
     ] with-aligned-stack ;
 
 M: x86.32 %prepare-alien-indirect ( -- )

basis/cpu/x86/64/64.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
@@ -6,7 +6,7 @@ cpu.x86.allot cpu.architecture kernel kernel.private math
 namespaces make sequences compiler.generator
 compiler.generator.registers compiler.generator.fixup system
 layouts alien alien.accessors alien.structs slots splitting
-assocs ;
+assocs combinators ;
 IN: cpu.x86.64
 
 M: x86.64 ds-reg R14 ;
@@ -48,6 +48,44 @@ M: stack-params %load-param-reg
 M: stack-params %save-param-reg
     >r stack-frame* + cell + swap r> %load-param-reg ;
 
+: with-return-regs ( quot -- )
+    [
+        V{ RDX RAX } clone int-regs set
+        V{ XMM1 XMM0 } clone float-regs set
+        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
@@ -62,22 +100,26 @@ M: x86.64 %unbox ( n reg-class func -- )
 M: x86.64 %unbox-long-long ( n func -- )
     int-regs swap %unbox ;
 
-M: x86.64 %unbox-struct-1 ( -- )
+: %unbox-struct-field ( c-type i -- )
-    #! Alien must be in RDI.
+    ! Alien must be in RDI.
-    "alien_offset" f %alien-invoke
+    RDI swap cells [+] swap reg-class>> {
-    ! Load first cell
+        { int-regs [ int-regs get pop swap MOV ] }
-    RAX RAX [] MOV ;
+        { double-float-regs [ float-regs get pop swap MOVSD ] }
+    } case ;
 
-M: x86.64 %unbox-struct-2 ( -- )
+M: x86.64 %unbox-small-struct ( c-type -- )
-    #! Alien must be in RDI.
+    ! Alien must be in RDI.
     "alien_offset" f %alien-invoke
-    ! Load second cell
+    ! Move alien_offset() return value to RDI so that we don't
-    RDX RAX cell [+] MOV
+    ! clobber it.
-    ! Load first cell
+    RDI RAX MOV
-    RAX RAX [] MOV ;
+    [
+        flatten-small-struct [ %unbox-struct-field ] each-index
+    ] with-return-regs ;
 
-M: x86.64 %unbox-large-struct ( n size -- )
+M: x86.64 %unbox-large-struct ( n c-type -- )
     ! Source is in RDI
+    heap-size
     ! Load destination address
     RSI RSP roll [+] LEA
     ! Load structure size
@@ -100,20 +142,33 @@ 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 -- ? ) 2 cells <= ;
+M: x86.64 struct-small-enough? ( size -- ? )
+    heap-size 2 cells <= ;
 
-M: x86.64 %box-small-struct ( size -- )
+: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
-    #! Box a <= 16-byte struct returned in RAX:RDX.
+
-    RDI RAX MOV
+: %box-struct-field ( c-type i -- )
-    RSI RDX MOV
+    box-struct-field@ swap reg-class>> {
-    RDX swap MOV
+        { int-regs [ int-regs get pop MOV ] }
-    "box_small_struct" f %alien-invoke ;
+        { double-float-regs [ float-regs get pop MOVSD ] }
+    } case ;
+
+M: x86.64 %box-small-struct ( c-type -- )
+    #! Box a <= 16-byte struct.
+    [
+        [ flatten-small-struct [ %box-struct-field ] each-index ]
+        [ RDX swap heap-size MOV ] bi
+        RDI 0 box-struct-field@ MOV
+        RSI 1 box-struct-field@ MOV
+        "box_small_struct" f %alien-invoke
+    ] with-return-regs ;
 
 : struct-return@ ( size n -- n )
     [ ] [ \ stack-frame get swap - ] ?if ;
 
-M: x86.64 %box-large-struct ( n size -- )
+M: x86.64 %box-large-struct ( n c-type -- )
     ! Struct size is parameter 2
+    heap-size
     RSI over MOV
     ! Compute destination address
     swap struct-return@ RDI RSP rot [+] LEA
@@ -170,32 +225,3 @@ USE: cpu.x86.intrinsics
 
 \ alien-signed-4 small-reg-32 define-signed-getter
 \ set-alien-signed-4 small-reg-32 define-setter
-
-! 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-large-struct ( type -- )
-    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
-    ] [
-        struct-types&offset split-struct [
-            [ c-type c-type-reg-class ] map
-            int-regs swap member?
-            "void*" "double" ? c-type ,
-        ] each
-    ] if ;

basis/cpu/x86/architecture/architecture.factor

@@ -139,21 +139,6 @@ M: x86 small-enough? ( n -- ? )
 
 : temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
 
-HOOK: %unbox-struct-1 cpu ( -- )
-
-HOOK: %unbox-struct-2 cpu ( -- )
-
-M: x86 %unbox-small-struct ( size -- )
-    #! Alien must be in EAX.
-    cell align cell /i {
-        { 1 [ %unbox-struct-1 ] }
-        { 2 [ %unbox-struct-2 ] }
-    } case ;
-
-M: x86 struct-small-enough? ( size -- ? )
-    { 1 2 4 8 } member?
-    os { linux netbsd solaris } member? not and ;
-
 M: x86 %return ( -- ) 0 %unwind ;
 
 ! Alien intrinsics

basis/smtp/smtp.factor

@@ -8,7 +8,7 @@ calendar.format accessors sets hashtables ;
 IN: smtp
 
 SYMBOL: smtp-domain
-SYMBOL: smtp-server     "localhost" "smtp" <inet> smtp-server set-global
+SYMBOL: smtp-server     "localhost" 25 <inet> smtp-server set-global
 SYMBOL: smtp-read-timeout    1 minutes smtp-read-timeout set-global
 SYMBOL: esmtp?           t esmtp? set-global
 

build-support/factor.sh

@@ -102,7 +102,7 @@ set_make() {
         *) MAKE='make';;
     esac
     if ! [[ $MAKE -eq 'gmake' ]] ; then
-    	ensure_program_installed gmake
+        ensure_program_installed gmake
     fi
 }
 
@@ -159,6 +159,7 @@ check_factor_exists() {
 }
 
 find_os() {
+    if [[ -n $OS ]] ; then return; fi
     $ECHO "Finding OS..."
     uname_s=`uname -s`
     check_ret uname
@@ -178,6 +179,7 @@ find_os() {
 }
 
 find_architecture() {
+    if [[ -n $ARCH ]] ; then return; fi
     $ECHO "Finding ARCH..."
     uname_m=`uname -m`
     check_ret uname
@@ -197,7 +199,7 @@ write_test_program() {
     echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
 }
 
-find_word_size() {
+c_find_word_size() {
     $ECHO "Finding WORD..."
     C_WORD=factor-word-size
     write_test_program
@@ -207,6 +209,29 @@ find_word_size() {
     rm -f $C_WORD*
 }
 
+intel_macosx_word_size() {
+    ensure_program_installed sysctl
+    $ECHO -n "Testing if your Intel Mac supports 64bit binaries..."
+    sysctl machdep.cpu.extfeatures | grep EM64T >/dev/null
+    if [[ $? -eq 0 ]] ; then
+        WORD=32
+        $ECHO "yes!"
+        $ECHO "Defaulting to 32bit for now though..."
+    else
+        WORD=32
+        $ECHO "no."
+    fi
+}
+
+find_word_size() {
+    if [[ -n $WORD ]] ; then return; fi
+    if [[ $OS == macosx && $ARCH == x86 ]] ; then
+        intel_macosx_word_size
+    else
+        c_find_word_size
+    fi
+}
+
 set_factor_binary() {
     case $OS in
         # winnt) FACTOR_BINARY=factor-nt;;
@@ -230,15 +255,18 @@ echo_build_info() {
     $ECHO MAKE=$MAKE
 }
 
-set_build_info() {
+check_os_arch_word() {
     if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
         $ECHO "OS: $OS"
         $ECHO "ARCH: $ARCH"
         $ECHO "WORD: $WORD"
-        $ECHO "OS, ARCH, or WORD is empty.  Please report this"
+        $ECHO "OS, ARCH, or WORD is empty.  Please report this."
         exit 5
     fi
+}
 
+set_build_info() {
+    check_os_arch_word
     MAKE_TARGET=$OS-$ARCH-$WORD
     MAKE_IMAGE_TARGET=$ARCH.$WORD
     BOOT_IMAGE=boot.$ARCH.$WORD.image
@@ -254,15 +282,32 @@ set_build_info() {
     fi
 }
 
+parse_build_info() {
+    ensure_program_installed cut
+    $ECHO "Parsing make target from command line: $1"
+    OS=`echo $1 | cut -d '-' -f 1`
+    ARCH=`echo $1 | cut -d '-' -f 2`
+    WORD=`echo $1 | cut -d '-' -f 3`
+    
+    if [[ $OS == linux && $ARCH == ppc ]] ; then WORD=32; fi
+    if [[ $OS == linux && $ARCH == arm ]] ; then WORD=32; fi
+    if [[ $OS == macosx && $ARCH == ppc ]] ; then WORD=32; fi
+    if [[ $OS == wince && $ARCH == arm ]] ; then WORD=32; fi
+    
+    $ECHO "OS=$OS"
+    $ECHO "ARCH=$ARCH"
+    $ECHO "WORD=$WORD"
+}
+
 find_build_info() {
     find_os
     find_architecture
     find_word_size
     set_factor_binary
     set_build_info
-	set_downloader
+    set_downloader
-	set_gcc
+    set_gcc
-	set_make
+    set_make
     echo_build_info
 }
 
@@ -415,30 +460,37 @@ make_boot_image() {
 }
 
 install_build_system_apt() {
-    ensure_program_installed yes
+    sudo apt-get --yes install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
-    yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
     check_ret sudo
 }
 
 install_build_system_port() {
     test_program_installed git
     if [[ $? -ne 1 ]] ; then
-    	ensure_program_installed yes
+        ensure_program_installed yes
-		echo "git not found."
+        echo "git not found."
-		echo "This script requires either git-core or port."
+        echo "This script requires either git-core or port."
-		echo "If it fails, install git-core or port and try again."
+        echo "If it fails, install git-core or port and try again."
-    	ensure_program_installed port
+        ensure_program_installed port
-		echo "Installing git-core with port...this will take awhile."
+        echo "Installing git-core with port...this will take awhile."
-    	yes | sudo port install git-core
+        yes | sudo port install git-core
     fi
 }
 
 usage() {
-    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
+    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target|report [optional-target]"
     echo "If you are behind a firewall, invoke as:"
     echo "env GIT_PROTOCOL=http $0 <command>"
+    echo ""
+    echo "Example for overriding the default target:"
+    echo "    $0 update macosx-x86-32"
 }
 
+# -n is nonzero length, -z is zero length
+if [[ -n "$2" ]] ; then
+    parse_build_info $2
+fi
+
 case "$1" in
     install) install ;;
     install-x11) install_build_system_apt; install ;;
@@ -447,8 +499,9 @@ case "$1" in
     quick-update) update; refresh_image ;;
     update) update; update_bootstrap ;;
     bootstrap) get_config_info; bootstrap ;;
+    report) find_build_info ;;
     dlls) get_config_info; maybe_download_dlls;;
     net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
-	make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
+    make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
     *) usage ;;
 esac

core/sequences/sequences-docs.factor

@@ -334,7 +334,7 @@ HELP: if-empty
 { $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
 { $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
 { $example
-    "USING: kernel prettyprint sequences sequences.lib ;"
+    "USING: kernel prettyprint sequences ;"
     "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
     "6"
 } ;

core/vocabs/loader/loader.factor

@@ -54,19 +54,19 @@ SYMBOL: load-help?
 : load-source ( vocab -- vocab )
     f over set-vocab-source-loaded?
     [ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
-    t over set-vocab-source-loaded?
+    t swap set-vocab-source-loaded?
-    [ [ % ] [ call ] if-bootstrapping ] dip ;
+    [ % ] [ call ] if-bootstrapping ;
 
 : load-docs ( vocab -- vocab )
     load-help? get [
         f over set-vocab-docs-loaded?
         [ vocab-docs-path [ ?run-file ] when* ] keep
-        t over set-vocab-docs-loaded?
+        t swap set-vocab-docs-loaded?
-    ] when ;
+    ] [ drop ] if ;
 
 : reload ( name -- )
     [
-        dup vocab [ load-source load-docs drop ] [ no-vocab ] ?if
+        dup vocab [ [ load-source ] [ load-docs ] bi ] [ no-vocab ] ?if
     ] with-compiler-errors ;
 
 : require ( vocab -- )
@@ -90,8 +90,8 @@ GENERIC: (load-vocab) ( name -- )
 
 M: vocab (load-vocab)
     [
-        dup vocab-source-loaded? [ load-source ] unless
+        dup vocab-source-loaded? [ dup load-source ] unless
-        dup vocab-docs-loaded? [ load-docs ] unless
+        dup vocab-docs-loaded? [ dup load-docs ] unless
         drop
     ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
 

extra/morse/tags.txt

@@ -1 +1 @@
-example
+examples

unfinished/regexp2/parser/parser-tests.factor

@@ -31,3 +31,7 @@ IN: regexp2.parser
 [ ] [ "[a-c]" test-regexp ] unit-test
 [ ] [ "[^a-c]" test-regexp ] unit-test
 [ "[^]" test-regexp ] must-fail
+
+[ ] [ "|b" test-regexp ] unit-test
+[ ] [ "b|" test-regexp ] unit-test
+[ ] [ "||" test-regexp ] unit-test

unfinished/regexp2/parser/parser.factor

@@ -67,7 +67,7 @@ left-parenthesis pipe caret dash ;
 : <negation> ( obj -- negation ) negation boa ;
 : <concatenation> ( seq -- concatenation )
     >vector get-reversed-regexp [ reverse ] when
-    concatenation boa ;
+    [ epsilon ] [ concatenation boa ] if-empty ;
 : <alternation> ( seq -- alternation ) >vector alternation boa ;
 : <capture-group> ( obj -- capture-group ) capture-group boa ;
 : <kleene-star> ( obj -- kleene-star ) kleene-star boa ;

unfinished/regexp2/regexp2-tests.factor

@@ -14,6 +14,13 @@ IN: regexp2-tests
 [ t ] [ "c" "a|b|c" <regexp> matches? ] unit-test
 [ f ] [ "c" "d|e|f" <regexp> matches? ] unit-test
 
+[ t ] [ "b" "|b" <regexp> matches? ] unit-test
+[ t ] [ "b" "b|" <regexp> matches? ] unit-test
+[ t ] [ "" "b|" <regexp> matches? ] unit-test
+[ t ] [ "" "b|" <regexp> matches? ] unit-test
+[ f ] [ "" "|" <regexp> matches? ] unit-test
+[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
+
 [ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
 [ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
 [ f ] [ "cc" "a|b|c" <regexp> matches? ] unit-test

vm/ffi_test.c

@@ -280,3 +280,48 @@ int ffi_test_39(long a, long b, struct test_struct_13 s)
 	if(a != b) abort();
 	return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
 }
+
+struct test_struct_14 ffi_test_40(double x1, double x2)
+{
+	struct test_struct_14 retval;
+	retval.x1 = x1;
+	retval.x2 = x2;
+	printf("ffi_test_40(%f,%f)\n",x1,x2);
+	return retval;
+}
+
+struct test_struct_12 ffi_test_41(int a, double x)
+{
+	struct test_struct_12 retval;
+	retval.a = a;
+	retval.x = x;
+	printf("ffi_test_41(%d,%f)\n",a,x);
+	return retval;
+}
+
+struct test_struct_15 ffi_test_42(float x, float y)
+{
+	struct test_struct_15 retval;
+	retval.x = x;
+	retval.y = y;
+	printf("ffi_test_42(%f,%f)\n",x,y);
+	return retval;
+}
+
+struct test_struct_16 ffi_test_43(float x, int a)
+{
+	struct test_struct_16 retval;
+	retval.x = x;
+	retval.a = a;
+	printf("ffi_test_43(%f,%d)\n",x,a);
+	return retval;
+}
+
+struct test_struct_14 ffi_test_44(void)
+{
+	struct test_struct_14 retval;
+	retval.x1 = 1.0;
+	retval.x2 = 2.0;
+	//printf("ffi_test_44()\n");
+	return retval;
+}

vm/ffi_test.h

@@ -71,3 +71,19 @@ DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long lon
 struct test_struct_13 { float x1, x2, x3, x4, x5, x6; };
 
 DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
+
+struct test_struct_14 { double x1, x2; };
+
+DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
+
+DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x);
+
+struct test_struct_15 { float x, y; };
+
+DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y);
+
+struct test_struct_16 { float x; int a; };
+
+DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
+
+DLLEXPORT struct test_struct_14 ffi_test_44();