diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 675bc56503..9f7ac75558 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 ; @@ -97,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 +: c-type-array-constructor ( c-type -- word ) + array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; 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: c-type c-type-array-constructor - array-constructor>> dup word? - [ first2 specialized-array-vocab-not-loaded ] unless ; - -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: c-type c-type-direct-array-constructor - direct-array-constructor>> dup word? - [ first2 specialized-array-vocab-not-loaded ] unless ; +: c-type-direct-array-constructor ( c-type -- word ) + direct-array-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; 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 98d412639f..7727546c00 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -31,6 +31,7 @@ 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..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 @@ -35,9 +45,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 +64,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/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 +*/ 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 ]