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

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

@@ -21,19 +21,19 @@ TUPLE: abstract-c-type
 { getter callable }
 { setter callable }
 size
-align ;
+align
-
-TUPLE: c-type < abstract-c-type
-boxer
-unboxer
-{ rep initial: int-rep }
-stack-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? ;
+
 : <c-type> ( -- 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-direct-array-constructor ( c-type -- word )
-    c-type c-type-array-constructor ;
+    direct-array-constructor>> dup array?
-M: array c-type-array-constructor
+    [ first2 specialized-array-vocab-not-loaded ] when ; foldable
-    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 ;
 
 GENERIC: <c-type-array> ( len c-type -- array )
 M: object <c-type-array>
     c-type-array-constructor execute( len -- array ) ; inline
+M: string <c-type-array>
+    c-type <c-type-array> ; inline
+M: array <c-type-array>
+    first c-type <c-type-array> ; inline
 
 GENERIC: <c-type-direct-array> ( alien len c-type -- array )
 M: object <c-type-direct-array>
     c-type-direct-array-constructor execute( alien len -- array ) ; inline
+M: string <c-type-direct-array>
+    c-type <c-type-direct-array> ; inline
+M: array <c-type-direct-array>
+    first c-type <c-type-direct-array> ; inline
 
 GENERIC: c-type-class ( name -- class )
 

basis/alien/complex/functor/functor.factor

@@ -31,6 +31,7 @@ T c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
 number >>boxed-class
+T set-array-class
 drop
 
 ;FUNCTOR

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 <c-type-array> ( len c-type -- array )
+    dup c-type-array-constructor
+    [ execute( len -- array ) ]
+    [ <struct-array> ] ?if ; inline
+
+M: struct-type <c-type-direct-array> ( alien len c-type -- array )
+    dup c-type-direct-array-constructor
+    [ execute( alien len -- array ) ]
+    [ <direct-struct-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 -- )
+: (define-struct) ( name size align fields class -- )
-    [ [ align ] keep ] dip
+    [ [ align ] keep ] 2dip new
-    struct-type 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>> 

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
 
-*/
+*/

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 ]