diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index e82d663d08..ce30a2ee25 100755 --- a/basis/alien/structs/structs.factor +++ b/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-parameter ] - if-value-structs? ; + [ %unbox-struct ] [ 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-parameter ] - if-value-structs? ; + [ %box-struct ] [ 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? ; diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 939d6e2276..0a9885357e 100755 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -271,9 +271,7 @@ M: #return-recursive generate-node ! #alien-invoke : large-struct? ( ctype -- ? ) - dup c-struct? [ - heap-size struct-small-enough? not - ] [ drop f ] if ; + dup c-struct? [ 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@ - dup return>> return-size - swap alien-stack-frame + - cell + ; + #! Two cells for temporary storage, temp@ and on x86.64, + #! small struct return value unpacking + [ return>> return-size ] [ alien-stack-frame ] bi + + 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 -- ) - cell /i "void*" c-type % ; +: (flatten-int-type) ( size -- types ) + cell /i "void*" c-type ; -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 ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index dc73888796..635dd42532 100755 --- a/basis/compiler/tests/alien.factor +++ b/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-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" + [ 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" + [ 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" + [ 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" + [ 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 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 432e748cbf..63c52d1025 100755 --- a/basis/cpu/architecture/architecture.factor +++ b/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 ] [ diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 12fbbea82e..80ee1802e1 100755 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/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 diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 5328f2a263..50d8025b38 100755 --- a/basis/cpu/x86/32/32.factor +++ b/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 -- ) - #! Box a <= 8-byte struct returned in EAX:DX. OS X only. - 12 [ - PUSH - EDX PUSH +: %unbox-struct-2 ( -- ) + #! Alien must be in EAX. + 4 [ 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 ( -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index c135d0490d..01b8935e39 100755 --- a/basis/cpu/x86/64/64.factor +++ b/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 ; + +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 ( -- ) - #! Alien must be in RDI. - "alien_offset" f %alien-invoke - ! Load first cell - RAX RAX [] MOV ; +: %unbox-struct-field ( c-type i -- ) + ! Alien must be in RDI. + RDI 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-struct-2 ( -- ) - #! Alien must be in RDI. +M: x86.64 %unbox-small-struct ( c-type -- ) + ! Alien must be in RDI. "alien_offset" f %alien-invoke - ! Load second cell - RDX RAX cell [+] MOV - ! Load first cell - RAX RAX [] MOV ; + ! Move alien_offset() return value to RDI so that we don't + ! clobber it. + RDI 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 a <= 16-byte struct returned in RAX:RDX. - RDI RAX MOV - RSI RDX MOV - RDX swap MOV - "box_small_struct" f %alien-invoke ; +: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ; + +: %box-struct-field ( c-type i -- ) + box-struct-field@ swap reg-class>> { + { int-regs [ int-regs get pop MOV ] } + { 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 % ; - -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 ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 04b496f12a..c97552a649 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/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 diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 26bfea9a13..c17bccf064 100755 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -8,7 +8,7 @@ calendar.format accessors sets hashtables ; IN: smtp SYMBOL: smtp-domain -SYMBOL: smtp-server "localhost" "smtp" smtp-server set-global +SYMBOL: smtp-server "localhost" 25 smtp-server set-global SYMBOL: smtp-read-timeout 1 minutes smtp-read-timeout set-global SYMBOL: esmtp? t esmtp? set-global diff --git a/build-support/factor.sh b/build-support/factor.sh index c60ab46671..16ab260df5 100755 --- a/build-support/factor.sh +++ b/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_gcc - set_make + set_downloader + set_gcc + set_make echo_build_info } @@ -415,30 +460,37 @@ make_boot_image() { } install_build_system_apt() { - ensure_program_installed yes - yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + sudo apt-get --yes 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 - echo "git not found." - echo "This script requires either git-core or port." - echo "If it fails, install git-core or port and try again." - ensure_program_installed port - echo "Installing git-core with port...this will take awhile." - yes | sudo port install git-core + ensure_program_installed yes + echo "git not found." + echo "This script requires either git-core or port." + echo "If it fails, install git-core or port and try again." + ensure_program_installed port + echo "Installing git-core with port...this will take awhile." + 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 " + 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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 5c0dbf7985..015e82f2c5 100755 --- a/core/sequences/sequences-docs.factor +++ b/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" } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 44f538d5d9..f48a3d1950 100755 --- a/core/vocabs/loader/loader.factor +++ b/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? - [ [ % ] [ call ] if-bootstrapping ] dip ; + t swap set-vocab-source-loaded? + [ % ] [ 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? - ] when ; + t swap set-vocab-docs-loaded? + ] [ 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-docs-loaded? [ load-docs ] unless + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless drop ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; diff --git a/extra/morse/tags.txt b/extra/morse/tags.txt index 33a9488b16..1e107f52e4 100644 --- a/extra/morse/tags.txt +++ b/extra/morse/tags.txt @@ -1 +1 @@ -example +examples diff --git a/unfinished/regexp2/parser/parser-tests.factor b/unfinished/regexp2/parser/parser-tests.factor index 9dc7dc7909..6911e8e76d 100644 --- a/unfinished/regexp2/parser/parser-tests.factor +++ b/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 diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp2/parser/parser.factor index a970f82aab..fb1bd08bfe 100644 --- a/unfinished/regexp2/parser/parser.factor +++ b/unfinished/regexp2/parser/parser.factor @@ -67,7 +67,7 @@ left-parenthesis pipe caret dash ; : ( obj -- negation ) negation boa ; : ( seq -- concatenation ) >vector get-reversed-regexp [ reverse ] when - concatenation boa ; + [ epsilon ] [ concatenation boa ] if-empty ; : ( seq -- alternation ) >vector alternation boa ; : ( obj -- capture-group ) capture-group boa ; : ( obj -- kleene-star ) kleene-star boa ; diff --git a/unfinished/regexp2/regexp2-tests.factor b/unfinished/regexp2/regexp2-tests.factor index f691c2becf..e77a7a4419 100644 --- a/unfinished/regexp2/regexp2-tests.factor +++ b/unfinished/regexp2/regexp2-tests.factor @@ -14,6 +14,13 @@ IN: regexp2-tests [ t ] [ "c" "a|b|c" matches? ] unit-test [ f ] [ "c" "d|e|f" matches? ] unit-test +[ t ] [ "b" "|b" matches? ] unit-test +[ t ] [ "b" "b|" matches? ] unit-test +[ t ] [ "" "b|" matches? ] unit-test +[ t ] [ "" "b|" matches? ] unit-test +[ f ] [ "" "|" matches? ] unit-test +[ f ] [ "" "|||||||" matches? ] unit-test + [ f ] [ "aa" "a|b|c" matches? ] unit-test [ f ] [ "bb" "a|b|c" matches? ] unit-test [ f ] [ "cc" "a|b|c" matches? ] unit-test diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 44a14f21f5..081ae42ebf 100755 --- a/vm/ffi_test.c +++ b/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; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 779cb97857..f9195a4285 100755 --- a/vm/ffi_test.h +++ b/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();