From 61c1ed17d982084b144e958524d310e4cdfad5fb Mon Sep 17 00:00:00 2001 From: sheeple Date: Tue, 25 Aug 2009 19:41:17 -0500 Subject: [PATCH 1/4] basis/compiler/tests/low-level-ir: add ##copy double-float-rep test --- basis/compiler/tests/low-level-ir.factor | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index ececac3037..e3e2c3344e 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -46,6 +46,17 @@ IN: compiler.tests.low-level-ir } compile-test-bb ] unit-test +! ##copy on floats +[ 1.5 ] [ + V{ + T{ ##load-reference f 4 1.5 } + T{ ##unbox-float f 1 4 } + T{ ##copy f 2 1 double-float-rep } + T{ ##box-float f 3 2 } + T{ ##copy f 0 3 int-rep } + } compile-test-bb +] unit-test + ! make sure slot access works when the destination is ! one of the sources [ t ] [ @@ -138,4 +149,4 @@ USE: multiline } compile-test-bb ] unit-test -*/ \ No newline at end of file +*/ From 8aa9327dccf2686c0e216751102693b85597e3b3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 19:58:04 -0500 Subject: [PATCH 2/4] support on complex ffi types --- basis/alien/c-types/c-types.factor | 9 ++++++--- basis/alien/complex/functor/functor.factor | 22 ++++++++++++++++------ basis/alien/structs/structs.factor | 9 ++++----- extra/classes/struct/struct.factor | 2 +- 4 files changed, 27 insertions(+), 15 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 675bc56503..779a5e18de 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -79,12 +79,15 @@ M: string c-type ( name -- type ) : ?require-word ( word/pair -- ) dup word? [ drop ] [ first require ] ?if ; +MIXIN: array-c-type +INSTANCE: c-type array-c-type + GENERIC: require-c-type-arrays ( c-type -- ) M: object require-c-type-arrays drop ; -M: c-type require-c-type-arrays +M: array-c-type require-c-type-arrays [ array-class>> ?require-word ] [ sequence-mixin-class>> ?require-word ] [ direct-array-class>> ?require-word ] tri ; @@ -103,7 +106,7 @@ M: string c-type-array-constructor c-type c-type-array-constructor ; M: array c-type-array-constructor first c-type c-type-array-constructor ; -M: c-type c-type-array-constructor +M: array-c-type c-type-array-constructor array-constructor>> dup word? [ first2 specialized-array-vocab-not-loaded ] unless ; @@ -113,7 +116,7 @@ M: string c-type-direct-array-constructor c-type c-type-direct-array-constructor ; M: array c-type-direct-array-constructor first c-type c-type-direct-array-constructor ; -M: c-type c-type-direct-array-constructor +M: array-c-type c-type-direct-array-constructor direct-array-constructor>> dup word? [ first2 specialized-array-vocab-not-loaded ] unless ; diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 98d412639f..a5580318a9 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,10 +1,18 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.structs alien.c-types math math.functions sequences -arrays kernel functors vocabs.parser namespaces accessors -quotations ; +USING: alien.structs alien.structs.fields alien.c-types +math math.functions sequences arrays kernel functors +vocabs.parser namespaces accessors quotations ; IN: alien.complex.functor +TUPLE: complex-c-type < struct-type + array-class + array-constructor + direct-array-class + direct-array-constructor + sequence-mixin-class ; +INSTANCE: complex-c-type array-c-type + FUNCTOR: define-complex-type ( N T -- ) T-real DEFINES ${T}-real @@ -23,14 +31,16 @@ WHERE : *T ( alien -- z ) [ T-real ] [ T-imaginary ] bi rect> ; inline -T current-vocab -{ { N "real" } { N "imaginary" } } -define-struct +T N c-type-align [ 2 * ] [ ] bi +T current-vocab N "real" +T current-vocab N "imaginary" N c-type-align >>offset +2array complex-c-type (define-struct) T c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot number >>boxed-class +T set-array-class drop ;FUNCTOR diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 5c1fb4063b..3d9cae1202 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -35,9 +35,8 @@ M: struct-type stack-size : c-struct? ( type -- ? ) (c-type) struct-type? ; -: (define-struct) ( name size align fields -- ) - [ [ align ] keep ] dip - struct-type new +: (define-struct) ( name size align fields class -- ) + [ [ align ] keep ] 2dip new byte-array >>class byte-array >>boxed-class swap >>fields @@ -55,13 +54,13 @@ M: struct-type stack-size [ 2drop ] [ make-fields ] 3bi [ struct-offsets ] keep [ [ type>> ] map compute-struct-align ] keep - [ (define-struct) ] keep + [ struct-type (define-struct) ] keep [ define-field ] each ; : define-union ( name members -- ) [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep - compute-struct-align f (define-struct) ; + compute-struct-align f struct-type (define-struct) ; : offset-of ( field struct -- offset ) c-types get at fields>> diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index 7d4eed80af..e9de2f7e36 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -117,7 +117,7 @@ M: struct-class writer-quot [ "struct-align" word-prop ] [ struct-slots [ slot>field ] map ] } cleave - (define-struct) + struct-type (define-struct) ] [ { [ name>> c-type ] From a2518377e342a62933366a457f907bb938d6720b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 20:43:48 -0500 Subject: [PATCH 3/4] support of structs using struct-arrays --- basis/alien/c-types/c-types.factor | 47 +++++++++------------- basis/alien/complex/functor/functor.factor | 21 +++------- basis/alien/structs/structs.factor | 12 +++++- 3 files changed, 37 insertions(+), 43 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 779a5e18de..4fc8dab9fe 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -21,19 +21,19 @@ TUPLE: abstract-c-type { getter callable } { setter callable } size -align ; - -TUPLE: c-type < abstract-c-type -boxer -unboxer -{ rep initial: int-rep } -stack-align? +align array-class array-constructor direct-array-class direct-array-constructor sequence-mixin-class ; +TUPLE: c-type < abstract-c-type +boxer +unboxer +{ rep initial: int-rep } +stack-align? ; + : ( -- type ) \ c-type new ; @@ -79,15 +79,12 @@ M: string c-type ( name -- type ) : ?require-word ( word/pair -- ) dup word? [ drop ] [ first require ] ?if ; -MIXIN: array-c-type -INSTANCE: c-type array-c-type - GENERIC: require-c-type-arrays ( c-type -- ) M: object require-c-type-arrays drop ; -M: array-c-type require-c-type-arrays +M: c-type require-c-type-arrays [ array-class>> ?require-word ] [ sequence-mixin-class>> ?require-word ] [ direct-array-class>> ?require-word ] tri ; @@ -100,33 +97,29 @@ M: array require-c-type-arrays ERROR: specialized-array-vocab-not-loaded vocab word ; -GENERIC: c-type-array-constructor ( c-type -- word ) foldable - -M: string c-type-array-constructor - c-type c-type-array-constructor ; -M: array c-type-array-constructor - first c-type c-type-array-constructor ; -M: array-c-type c-type-array-constructor +: c-type-array-constructor ( c-type -- word ) array-constructor>> dup word? - [ first2 specialized-array-vocab-not-loaded ] unless ; + [ first2 specialized-array-vocab-not-loaded ] unless ; foldable -GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable - -M: string c-type-direct-array-constructor - c-type c-type-direct-array-constructor ; -M: array c-type-direct-array-constructor - first c-type c-type-direct-array-constructor ; -M: array-c-type c-type-direct-array-constructor +: c-type-direct-array-constructor ( c-type -- word ) direct-array-constructor>> dup word? - [ first2 specialized-array-vocab-not-loaded ] unless ; + [ first2 specialized-array-vocab-not-loaded ] unless ; foldable GENERIC: ( len c-type -- array ) M: object c-type-array-constructor execute( len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline GENERIC: ( alien len c-type -- array ) M: object c-type-direct-array-constructor execute( alien len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline GENERIC: c-type-class ( name -- class ) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index a5580318a9..7727546c00 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -1,18 +1,10 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.structs alien.structs.fields alien.c-types -math math.functions sequences arrays kernel functors -vocabs.parser namespaces accessors quotations ; +USING: alien.structs alien.c-types math math.functions sequences +arrays kernel functors vocabs.parser namespaces accessors +quotations ; IN: alien.complex.functor -TUPLE: complex-c-type < struct-type - array-class - array-constructor - direct-array-class - direct-array-constructor - sequence-mixin-class ; -INSTANCE: complex-c-type array-c-type - FUNCTOR: define-complex-type ( N T -- ) T-real DEFINES ${T}-real @@ -31,10 +23,9 @@ WHERE : *T ( alien -- z ) [ T-real ] [ T-imaginary ] bi rect> ; inline -T N c-type-align [ 2 * ] [ ] bi -T current-vocab N "real" -T current-vocab N "imaginary" N c-type-align >>offset -2array complex-c-type (define-struct) +T current-vocab +{ { N "real" } { N "imaginary" } } +define-struct T c-type 1quotation >>unboxer-quot diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 3d9cae1202..d8b2edf394 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order -quotations byte-arrays ; +quotations byte-arrays struct-arrays ; IN: alien.structs TUPLE: struct-type < abstract-c-type fields return-in-registers? ; @@ -12,6 +12,16 @@ M: struct-type c-type ; M: struct-type c-type-stack-align? drop f ; +M: struct-type ( len c-type -- array ) + dup c-type-array-constructor + [ execute( len -- array ) ] + [ ] ?if ; inline + +M: struct-type ( alien len c-type -- array ) + dup c-type-direct-array-constructor + [ execute( alien len -- array ) ] + [ ] ?if ; inline + : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline From 87c670b785604ecff2cd2493ff9fd328f8cac209 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 20:57:23 -0500 Subject: [PATCH 4/4] no really, support of structs using struct-arrays --- basis/alien/c-types/c-types.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 4fc8dab9fe..9f7ac75558 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -98,12 +98,12 @@ M: array require-c-type-arrays ERROR: specialized-array-vocab-not-loaded vocab word ; : c-type-array-constructor ( c-type -- word ) - array-constructor>> dup word? - [ first2 specialized-array-vocab-not-loaded ] unless ; foldable + array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable : c-type-direct-array-constructor ( c-type -- word ) - direct-array-constructor>> dup word? - [ first2 specialized-array-vocab-not-loaded ] unless ; foldable + direct-array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable GENERIC: ( len c-type -- array ) M: object