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

basis/alien/arrays/arrays-docs.factor

@@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ;
 ARTICLE: "c-arrays" "C arrays"
 "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
 $nl
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
+$nl
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"
+{ $subsection require-c-type-arrays }
+{ $subsection <c-type-array> }
+{ $subsection <c-type-direct-array> } ;

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

@@ -1,7 +1,7 @@
 IN: alien.c-types
 USING: alien help.syntax help.markup libc kernel.private
 byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors ;
+io.encodings.string debugger destructors vocabs.loader ;
 
 HELP: <c-type>
 { $values { "type" hashtable } }
@@ -128,6 +128,21 @@ HELP: malloc-string
     }
 } ;
 
+HELP: require-c-type-arrays
+{ $values { "c-type" "a C type" } }
+{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-type-array> } " or " { $link <c-type-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
+
+HELP: <c-type-array>
+{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
+
+HELP: <c-type-direct-array>
+{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
+{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
+
 ARTICLE: "c-strings" "C strings"
 "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
 $nl

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

@@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
 cpu.architecture alien alien.accessors alien.strings quotations
 layouts system compiler.units io io.files io.encodings.binary
 io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -27,7 +27,12 @@ TUPLE: c-type < abstract-c-type
 boxer
 unboxer
 { rep initial: int-rep }
-stack-align? ;
+stack-align?
+array-class
+array-constructor
+direct-array-class
+direct-array-constructor
+sequence-mixin-class ;
 
 : <c-type> ( -- type )
     \ c-type new ;
@@ -71,6 +76,55 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+: ?require-word ( word/pair -- )
+    dup word? [ drop ] [ first require ] ?if ;
+
+GENERIC: require-c-type-arrays ( c-type -- )
+
+M: object require-c-type-arrays
+    drop ;
+
+M: c-type require-c-type-arrays
+    [ array-class>> ?require-word ]
+    [ sequence-mixin-class>> ?require-word ]
+    [ direct-array-class>> ?require-word ] tri ;
+
+M: string require-c-type-arrays
+    c-type require-c-type-arrays ;
+
+M: array require-c-type-arrays
+    first c-type 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: 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
+
+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
+
 GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
@@ -293,6 +347,36 @@ M: long-long-type box-return ( type -- )
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 
+: ?lookup ( vocab word -- word/pair )
+    over vocab [ swap lookup ] [ 2array ] if ;
+
+: set-array-class* ( c-type vocab-stem type-stem -- c-type )
+    {
+        [
+            [ "specialized-arrays." prepend ]
+            [ "-array" append ] bi* ?lookup >>array-class
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
+        ]
+        [
+            [ "specialized-arrays.direct." prepend ]
+            [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
+        ]
+        [
+            [ "specialized-arrays.direct." prepend ]
+            [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
+        ]
+    } 2cleave ;
+
+: set-array-class ( c-type stem -- c-type )
+    dup set-array-class* ;
+
 CONSTANT: primitive-types
     {
         "char" "uchar"
@@ -315,6 +399,7 @@ CONSTANT: primitive-types
         [ >c-ptr ] >>unboxer-quot
         "box_alien" >>boxer
         "alien_offset" >>unboxer
+        "alien" "void*" set-array-class*
     "void*" define-primitive-type
 
     <long-long-type>
@@ -326,6 +411,7 @@ CONSTANT: primitive-types
         8 >>align
         "box_signed_8" >>boxer
         "to_signed_8" >>unboxer
+        "longlong" set-array-class
     "longlong" define-primitive-type
 
     <long-long-type>
@@ -337,6 +423,7 @@ CONSTANT: primitive-types
         8 >>align
         "box_unsigned_8" >>boxer
         "to_unsigned_8" >>unboxer
+        "ulonglong" set-array-class
     "ulonglong" define-primitive-type
 
     <c-type>
@@ -348,6 +435,7 @@ CONSTANT: primitive-types
         bootstrap-cell >>align
         "box_signed_cell" >>boxer
         "to_fixnum" >>unboxer
+        "long" set-array-class
     "long" define-primitive-type
 
     <c-type>
@@ -359,6 +447,7 @@ CONSTANT: primitive-types
         bootstrap-cell >>align
         "box_unsigned_cell" >>boxer
         "to_cell" >>unboxer
+        "ulong" set-array-class
     "ulong" define-primitive-type
 
     <c-type>
@@ -370,6 +459,7 @@ CONSTANT: primitive-types
         4 >>align
         "box_signed_4" >>boxer
         "to_fixnum" >>unboxer
+        "int" set-array-class
     "int" define-primitive-type
 
     <c-type>
@@ -381,6 +471,7 @@ CONSTANT: primitive-types
         4 >>align
         "box_unsigned_4" >>boxer
         "to_cell" >>unboxer
+        "uint" set-array-class
     "uint" define-primitive-type
 
     <c-type>
@@ -392,6 +483,7 @@ CONSTANT: primitive-types
         2 >>align
         "box_signed_2" >>boxer
         "to_fixnum" >>unboxer
+        "short" set-array-class
     "short" define-primitive-type
 
     <c-type>
@@ -403,6 +495,7 @@ CONSTANT: primitive-types
         2 >>align
         "box_unsigned_2" >>boxer
         "to_cell" >>unboxer
+        "ushort" set-array-class
     "ushort" define-primitive-type
 
     <c-type>
@@ -414,6 +507,7 @@ CONSTANT: primitive-types
         1 >>align
         "box_signed_1" >>boxer
         "to_fixnum" >>unboxer
+        "char" set-array-class
     "char" define-primitive-type
 
     <c-type>
@@ -425,6 +519,7 @@ CONSTANT: primitive-types
         1 >>align
         "box_unsigned_1" >>boxer
         "to_cell" >>unboxer
+        "uchar" set-array-class
     "uchar" define-primitive-type
 
     <c-type>
@@ -434,6 +529,7 @@ CONSTANT: primitive-types
         1 >>align
         "box_boolean" >>boxer
         "to_boolean" >>unboxer
+        "bool" set-array-class
     "bool" define-primitive-type
 
     <c-type>
@@ -447,6 +543,7 @@ CONSTANT: primitive-types
         "to_float" >>unboxer
         single-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "float" set-array-class
     "float" define-primitive-type
 
     <c-type>
@@ -460,9 +557,11 @@ CONSTANT: primitive-types
         "to_double" >>unboxer
         double-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "double" set-array-class
     "double" define-primitive-type
 
     "long" "ptrdiff_t" typedef
     "long" "intptr_t" typedef
     "ulong" "size_t" typedef
 ] with-compilation-unit
+

basis/specialized-arrays/direct/functor/functor.factor

@@ -8,6 +8,7 @@ IN: specialized-arrays.direct.functor
 FUNCTOR: define-direct-array ( T -- )
 
 A'      IS ${T}-array
+S       IS ${T}-sequence
 >A'     IS >${T}-array
 <A'>    IS <${A'}>
 A'{     IS ${A'}{
@@ -31,6 +32,8 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
 M: A like drop dup A instance? [ >A' ] unless ;
 M: A new-sequence drop <A'> ;
 
+M: A byte-length length>> T heap-size * ;
+
 M: A pprint-delims drop \ A'{ \ } ;
 
 M: A >pprint-sequence ;
@@ -38,5 +41,11 @@ M: A >pprint-sequence ;
 M: A pprint* pprint-object ;
 
 INSTANCE: A sequence
+INSTANCE: A S
+
+T c-type
+    \ A >>direct-array-class
+    \ <A> >>direct-array-constructor
+    drop
 
 ;FUNCTOR

basis/specialized-arrays/functor/functor.factor

@@ -16,6 +16,7 @@ M: bad-byte-array-length summary
 FUNCTOR: define-array ( T -- )
 
 A            DEFINES-CLASS ${T}-array
+S            DEFINES-CLASS ${T}-sequence
 <A>          DEFINES <${A}>
 (A)          DEFINES (${A})
 >A           DEFINES >${A}
@@ -27,6 +28,8 @@ SET-NTH      [ T dup c-setter array-accessor ]
 
 WHERE
 
+MIXIN: S
+
 TUPLE: A
 { length array-capacity read-only }
 { underlying byte-array read-only } ;
@@ -73,7 +76,14 @@ M: A pprint* pprint-object ;
 SYNTAX: A{ \ } [ >A ] parse-literal ;
 
 INSTANCE: A sequence
+INSTANCE: A S
 
 A T c-type-boxed-class specialize-vector-words
 
+T c-type
+    \ A >>array-class
+    \ <A> >>array-constructor
+    \ S >>sequence-mixin-class
+    drop
+
 ;FUNCTOR

basis/specialized-vectors/functor/functor.factor

@@ -10,6 +10,7 @@ FUNCTOR: define-vector ( T -- )
 V   DEFINES-CLASS ${T}-vector
 
 A   IS      ${T}-array
+S   IS      ${T}-sequence
 <A> IS      <${A}>
 
 >V  DEFERS >${V}
@@ -32,5 +33,6 @@ M: V pprint* pprint-object ;
 SYNTAX: V{ \ } [ >V ] parse-literal ;
 
 INSTANCE: V growable
+INSTANCE: V S
 
 ;FUNCTOR

basis/windows/com/wrapper/wrapper.factor

@@ -153,7 +153,7 @@ PRIVATE>
     [ +live-wrappers+ get adjoin ] bi ;
 
 : <com-wrapper> ( implementations -- wrapper )
-    com-wrapper new-disposable swap (make-callbacks) >>vtbls
+    com-wrapper new-disposable swap (make-callbacks) >>callbacks
     dup allocate-wrapper ;
 
 M: com-wrapper dispose*

extra/alien/marshall/marshall.factor

@@ -93,7 +93,7 @@ ALIAS: marshall-void* marshall-pointer
 
 : primitive-marshaller ( type -- quot/f )
     {
-        { "bool"        [ [ marshall-bool ] ] }
+        { "bool"        [ [ ] ] }
         { "boolean"     [ [ marshall-bool ] ] }
         { "char"        [ [ marshall-primitive ] ] }
         { "uchar"       [ [ marshall-primitive ] ] }
@@ -179,7 +179,7 @@ ALIAS: marshall-void* marshall-pointer
 
 : primitive-unmarshaller ( type -- quot/f )
     {
-        { "bool"       [ [ unmarshall-bool ] ] }
+        { "bool"       [ [ ] ] }
         { "boolean"    [ [ unmarshall-bool ] ] }
         { "char"       [ [ ] ] }
         { "uchar"      [ [ ] ] }

extra/alien/marshall/syntax/syntax-tests.factor

@@ -9,8 +9,7 @@ C-LIBRARY: test
 
 C-INCLUDE: <stdlib.h>
 C-INCLUDE: <string.h>
-
+C-INCLUDE: <stdbool.h>
-C-TYPEDEF: char bool
 
 CM-FUNCTION: void outarg1 ( int* a )
     *a += 2;

extra/classes/c-types/c-types-docs.factor

@@ -1,72 +0,0 @@
-! (c)Joe Groff bsd license
-USING: alien arrays classes help.markup help.syntax kernel math
-specialized-arrays.direct ;
-IN: classes.c-types
-
-HELP: c-type-class
-{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ;
-
-HELP: char
-{ $class-description "A signed one-byte integer quantity." } ;
-
-HELP: direct-array-of
-{ $values
-    { "alien" c-ptr } { "len" integer } { "class" c-type-class }
-    { "array" "a direct array" }
-}
-{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ;
-
-HELP: int
-{ $class-description "A signed four-byte integer quantity." } ;
-
-HELP: long
-{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
-
-HELP: longlong
-{ $class-description "A signed eight-byte integer quantity." } ;
-
-HELP: short
-{ $class-description "A signed two-byte integer quantity." } ;
-
-HELP: single-complex
-{ $class-description "A single-precision complex floating point quantity." } ;
-
-HELP: single-float
-{ $class-description "A single-precision floating point quantity." } ;
-
-HELP: uchar
-{ $class-description "An unsigned one-byte integer quantity." } ;
-
-HELP: uint
-{ $class-description "An unsigned four-byte integer quantity." } ;
-
-HELP: ulong
-{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ;
-
-HELP: ulonglong
-{ $class-description "An unsigned eight-byte integer quantity." } ;
-
-HELP: ushort
-{ $class-description "An unsigned two-byte integer quantity." } ;
-
-ARTICLE: "classes.c-types" "C type classes"
-"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI."
-{ $subsection char }
-{ $subsection uchar }
-{ $subsection short }
-{ $subsection ushort }
-{ $subsection int }
-{ $subsection uint }
-{ $subsection long }
-{ $subsection ulong }
-{ $subsection longlong }
-{ $subsection ulonglong }
-{ $subsection single-float }
-{ $subsection float }
-{ $subsection single-complex }
-{ $subsection complex }
-{ $subsection pinned-c-ptr }
-"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:"
-{ $subsection direct-array-of } ;
-
-ABOUT: "classes.c-types"

extra/classes/c-types/c-types.factor

@@ -1,118 +0,0 @@
-! (c)Joe Groff bsd license
-USING: alien alien.c-types classes classes.predicate kernel
-math math.bitwise math.order namespaces sequences words
-specialized-arrays.direct.alien
-specialized-arrays.direct.bool
-specialized-arrays.direct.char
-specialized-arrays.direct.complex-double
-specialized-arrays.direct.complex-float
-specialized-arrays.direct.double
-specialized-arrays.direct.float
-specialized-arrays.direct.int
-specialized-arrays.direct.long
-specialized-arrays.direct.longlong
-specialized-arrays.direct.short
-specialized-arrays.direct.uchar
-specialized-arrays.direct.uint
-specialized-arrays.direct.ulong
-specialized-arrays.direct.ulonglong
-specialized-arrays.direct.ushort ;
-IN: classes.c-types
-
-PREDICATE: char < fixnum
-    HEX: -80 HEX: 7f between? ;
-
-PREDICATE: uchar < fixnum
-    HEX: 0 HEX: ff between? ;
-
-PREDICATE: short < fixnum
-    HEX: -8000 HEX: 7fff between? ;
-
-PREDICATE: ushort < fixnum
-    HEX: 0 HEX: ffff between? ;
-
-PREDICATE: int < integer
-    HEX: -8000,0000 HEX: 7fff,ffff between? ;
-
-PREDICATE: uint < integer
-    HEX: 0 HEX: ffff,ffff between? ;
-
-PREDICATE: longlong < integer
-    HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ;
-
-PREDICATE: ulonglong < integer
-    HEX: 0 HEX: ffff,ffff,ffff,ffff between? ;
-
-UNION: single-float float ;
-UNION: single-complex complex ;
-
-SYMBOLS: long ulong long-bits ;
-
-<<
-    "long" heap-size 8 =
-    [
-        \  long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class
-        \ ulong integer [ HEX:                    0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class
-        64 \ long-bits set-global
-    ] [
-        \  long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class
-        \ ulong integer [ HEX:          0 HEX: ffff,ffff between? ] define-predicate-class
-        32 \ long-bits set-global
-    ] if
->>
-
-: set-class-c-type ( class initial c-type <direct-array> -- )
-    [ "initial-value" set-word-prop ]
-    [ c-type "class-c-type" set-word-prop ]
-    [ "class-direct-array" set-word-prop ] tri-curry* tri ;
-
-: class-c-type ( class -- c-type )
-    "class-c-type" word-prop ;
-: class-direct-array ( class -- <direct-array> )
-    "class-direct-array" word-prop ;
-
-\ f            f            "void*"          \ <direct-void*-array>          set-class-c-type
-pinned-c-ptr   f            "void*"          \ <direct-void*-array>          set-class-c-type
-boolean        f            "bool"           \ <direct-bool-array>           set-class-c-type
-char           0            "char"           \ <direct-char-array>           set-class-c-type
-uchar          0            "uchar"          \ <direct-uchar-array>          set-class-c-type
-short          0            "short"          \ <direct-short-array>          set-class-c-type
-ushort         0            "ushort"         \ <direct-ushort-array>         set-class-c-type
-int            0            "int"            \ <direct-int-array>            set-class-c-type
-uint           0            "uint"           \ <direct-uint-array>           set-class-c-type
-long           0            "long"           \ <direct-long-array>           set-class-c-type
-ulong          0            "ulong"          \ <direct-ulong-array>          set-class-c-type
-longlong       0            "longlong"       \ <direct-longlong-array>       set-class-c-type
-ulonglong      0            "ulonglong"      \ <direct-ulonglong-array>      set-class-c-type
-float          0.0          "double"         \ <direct-double-array>         set-class-c-type
-single-float   0.0          "float"          \ <direct-float-array>          set-class-c-type
-complex        C{ 0.0 0.0 } "complex-double" \ <direct-complex-double-array> set-class-c-type
-single-complex C{ 0.0 0.0 } "complex-float"  \ <direct-complex-float-array>  set-class-c-type
-
-char      [  8 bits  8 >signed ] "coercer" set-word-prop
-uchar     [  8 bits            ] "coercer" set-word-prop
-short     [ 16 bits 16 >signed ] "coercer" set-word-prop
-ushort    [ 16 bits            ] "coercer" set-word-prop
-int       [ 32 bits 32 >signed ] "coercer" set-word-prop
-uint      [ 32 bits            ] "coercer" set-word-prop
-long      [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop
-ulong     [   bits               ] long-bits get-global prefix "coercer" set-word-prop
-longlong  [ 64 bits 64 >signed ] "coercer" set-word-prop
-ulonglong [ 64 bits            ] "coercer" set-word-prop
-
-PREDICATE: c-type-class < class
-    "class-c-type" word-prop ;
-
-GENERIC: direct-array-of ( alien len class -- array ) inline
-
-M: c-type-class direct-array-of
-    class-direct-array execute( alien len -- array ) ; inline
-
-M: c-type-class c-type class-c-type ;
-M: c-type-class c-type-align class-c-type c-type-align ;
-M: c-type-class c-type-getter class-c-type c-type-getter ;
-M: c-type-class c-type-setter class-c-type c-type-setter ;
-M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ;
-M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ;
-M: c-type-class heap-size class-c-type heap-size ;
-

extra/classes/struct/prettyprint/prettyprint.factor

@@ -1,7 +1,7 @@
 ! (c)Joe Groff bsd license
-USING: accessors assocs classes classes.struct kernel math
+USING: accessors assocs classes classes.struct combinators
-prettyprint.backend prettyprint.custom prettyprint.sections
+kernel math prettyprint.backend prettyprint.custom
-see.private sequences words ;
+prettyprint.sections see.private sequences words ;
 IN: classes.struct.prettyprint
 
 <PRIVATE
@@ -14,11 +14,21 @@ IN: classes.struct.prettyprint
 : struct>assoc ( struct -- assoc )
     [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
 
+: pprint-struct-slot ( slot -- )
+    <flow \ { pprint-word
+    {
+        [ name>> text ]
+        [ c-type>> text ]
+        [ read-only>> [ \ read-only pprint-word ] when ]
+        [ initial>> [ \ initial: pprint-word pprint* ] when* ]
+    } cleave
+    \ } pprint-word block> ;
+
 PRIVATE>
 
 M: struct-class see-class*
     <colon dup struct-definer-word pprint-word dup pprint-word
-    <block struct-slots [ pprint-slot ] each
+    <block struct-slots [ pprint-struct-slot ] each
     block> pprint-; block> ;
 
 M: struct pprint-delims

extra/classes/struct/struct-docs.factor

@@ -24,7 +24,7 @@ HELP: STRUCT:
 { $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:"
 { $list
 { "Struct classes cannot have a superclass defined." }
-{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." } 
+{ "The slots of a struct must all have a type declared. The type must be a C type." } 
 { { $link read-only } " slots on structs are not enforced, though they may be declared." }
 } } ;
 

extra/classes/struct/struct-tests.factor

@@ -1,19 +1,36 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.structs.fields classes.c-types
+USING: accessors alien.c-types alien.libraries
-classes.struct combinators io.streams.string kernel libc literals math
+alien.structs.fields alien.syntax classes.struct combinators
-multiline namespaces prettyprint prettyprint.config see tools.test ;
+destructors io.encodings.utf8 io.pathnames io.streams.string
+kernel libc literals math multiline namespaces prettyprint
+prettyprint.config see system tools.test ;
 IN: classes.struct.tests
 
+<<
+: libfactor-ffi-tests-path ( -- string )
+    "resource:" (normalize-path)
+    {
+        { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
+        { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
+        { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
+    } cond append-path ;
+
+"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
+
+"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
+>>
+
 STRUCT: struct-test-foo
     { x char }
     { y int initial: 123 }
-    { z boolean } ;
+    { z bool } ;
 
 STRUCT: struct-test-bar
     { w ushort initial: HEX: ffff }
     { foo struct-test-foo } ;
 
 [ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
 [ 16 ] [ struct-test-bar heap-size ] unit-test
 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
@@ -32,13 +49,24 @@ STRUCT: struct-test-bar
 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
 
 UNION-STRUCT: struct-test-float-and-bits
-    { f single-float }
+    { f float }
     { bits uint } ;
 
 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 
-[ ] [ struct-test-foo malloc-struct free ] unit-test
+[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
+
+STRUCT: struct-test-string-ptr
+    { x char* } ;
+
+[ "hello world" ] [
+    [
+        struct-test-string-ptr <struct>
+        "hello world" utf8 malloc-string &free >>x
+        x>>
+    ] with-destructors
+] unit-test
 
 [ "S{ struct-test-foo { y 7654 } }" ]
 [
@@ -54,18 +82,17 @@ UNION-STRUCT: struct-test-float-and-bits
     with-variable
 ] unit-test
 
-[ <" USING: classes.c-types classes.struct kernel ;
+[ <" USING: classes.struct ;
 IN: classes.struct.tests
 STRUCT: struct-test-foo
-    { x char initial: 0 } { y int initial: 123 }
+    { x char initial: 0 } { y int initial: 123 } { z bool } ;
-    { z boolean initial: f } ;
 "> ]
 [ [ struct-test-foo see ] with-string-writer ] unit-test
 
-[ <" USING: classes.c-types classes.struct ;
+[ <" USING: classes.struct ;
 IN: classes.struct.tests
 UNION-STRUCT: struct-test-float-and-bits
-    { f single-float initial: 0.0 } { bits uint initial: 0 } ;
+    { f float initial: 0.0 } { bits uint initial: 0 } ;
 "> ]
 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
 
@@ -73,21 +100,21 @@ UNION-STRUCT: struct-test-float-and-bits
     T{ field-spec
         { name "x" }
         { offset 0 }
-        { type $[ char c-type ] }
+        { type "char" }
         { reader x>> }
         { writer (>>x) }
     }
     T{ field-spec
         { name "y" }
         { offset 4 }
-        { type $[ int c-type ] }
+        { type "int" }
         { reader y>> }
         { writer (>>y) }
     }
     T{ field-spec
         { name "z" }
         { offset 8 }
-        { type $[ boolean c-type ] }
+        { type "bool" }
         { reader z>> }
         { writer (>>z) }
     }
@@ -97,16 +124,24 @@ UNION-STRUCT: struct-test-float-and-bits
     T{ field-spec
         { name "f" }
         { offset 0 }
-        { type $[ single-float c-type ] }
+        { type "float" }
         { reader f>> }
         { writer (>>f) }
     }
     T{ field-spec
         { name "bits" }
         { offset 0 }
-        { type $[ uint c-type ] }
+        { type "uint" }
         { reader bits>> }
         { writer (>>bits) }
     }
 } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
 
+STRUCT: struct-test-ffi-foo
+    { x int }
+    { y int } ;
+
+LIBRARY: f-cdecl
+FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
+
+[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test

extra/classes/struct/struct.factor

@@ -1,10 +1,11 @@
 ! (c)Joe Groff bsd license
 USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
-byte-arrays classes classes.c-types classes.parser classes.tuple
+byte-arrays classes classes.parser classes.tuple
 classes.tuple.parser classes.tuple.private combinators
 combinators.smart fry generalizations generic.parser kernel
-kernel.private libc macros make math math.order parser
+kernel.private lexer libc macros make math math.order parser
-quotations sequences slots slots.private struct-arrays words ;
+quotations sequences slots slots.private struct-arrays
+vectors words ;
 FROM: slots => reader-word writer-word ;
 IN: classes.struct
 
@@ -13,6 +14,9 @@ IN: classes.struct
 TUPLE: struct
     { (underlying) c-ptr read-only } ;
 
+TUPLE: struct-slot-spec < slot-spec
+    c-type ;
+
 PREDICATE: struct-class < tuple-class
     \ struct subclass-of? ;
 
@@ -52,11 +56,11 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
     [ struct-slots [ initial>> ] map over length tail append ] keep ;
 
 : (reader-quot) ( slot -- quot )
-    [ class>> c-type-getter-boxer ]
+    [ c-type>> c-type-getter-boxer ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 : (writer-quot) ( slot -- quot )
-    [ class>> c-setter ]
+    [ c-type>> c-setter ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 : (boxer-quot) ( class -- quot )
@@ -90,13 +94,17 @@ M: struct-class writer-quot
     [ \ struct-slot-values create-method-in ]
     [ struct-slot-values-quot ] bi define ;
 
+: (define-byte-length-method) ( class -- )
+    [ \ byte-length create-method-in ]
+    [ heap-size \ drop swap [ ] 2sequence ] bi define ;
+
 ! Struct as c-type
 
 : slot>field ( slot -- field )
     field-spec new swap {
         [ name>> >>name ]
         [ offset>> >>offset ]
-        [ class>> c-type >>type ]
+        [ c-type>> >>type ]
         [ name>> reader-word >>reader ]
         [ name>> writer-word >>writer ]
     } cleave ;
@@ -111,9 +119,12 @@ M: struct-class writer-quot
         } cleave
         (define-struct)
     ] [
-        [ name>> c-type ]
+        {
-        [ (unboxer-quot) >>unboxer-quot ]
+            [ name>> c-type ]
-        [ (boxer-quot) >>boxer-quot ] tri drop
+            [ (unboxer-quot) >>unboxer-quot ]
+            [ (boxer-quot) >>boxer-quot ]
+            [ >>boxed-class ]
+        } cleave drop
     ] bi ;
 
 : align-offset ( offset class -- offset' )
@@ -121,15 +132,15 @@ M: struct-class writer-quot
 
 : struct-offsets ( slots -- size )
     0 [
-        [ class>> align-offset ] keep
+        [ c-type>> align-offset ] keep
-        [ (>>offset) ] [ class>> heap-size + ] 2bi
+        [ (>>offset) ] [ c-type>> heap-size + ] 2bi
     ] reduce ;
 
 : union-struct-offsets ( slots -- size )
-    [ 0 >>offset class>> heap-size ] [ max ] map-reduce ;
+    [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ;
 
 : struct-align ( slots -- align )
-    [ class>> c-type-align ] [ max ] map-reduce ;
+    [ c-type>> c-type-align ] [ max ] map-reduce ;
 
 M: struct-class c-type
     name>> c-type ;
@@ -153,9 +164,6 @@ M: struct-class c-type-unboxer-quot
 M: struct-class heap-size
     "struct-size" word-prop ;
 
-M: struct-class direct-array-of
-    <direct-struct-array> ;
-
 ! class definition
 
 : struct-prototype ( class -- prototype )
@@ -168,6 +176,10 @@ M: struct-class direct-array-of
         over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
     ] each ;
 
+: (struct-methods) ( class -- )
+    [ (define-struct-slot-values-method) ]
+    [ (define-byte-length-method) ] bi ;
+
 : (struct-word-props) ( class slots size align -- )
     [
         [ "struct-slots" set-word-prop ]
@@ -177,10 +189,10 @@ M: struct-class direct-array-of
     [ "struct-align" set-word-prop ] tri-curry*
     [ tri ] 3curry
     [ dup struct-prototype "prototype" set-word-prop ]
-    [ (define-struct-slot-values-method) ] tri ;
+    [ (struct-methods) ] tri ;
 
 : check-struct-slots ( slots -- )
-    [ class>> c-type drop ] each ;
+    [ c-type>> c-type drop ] each ;
 
 : (define-struct-class) ( class slots offsets-quot -- )
     [ drop struct f define-tuple-class ]
@@ -197,8 +209,27 @@ M: struct-class direct-array-of
 : define-union-struct-class ( class slots -- )
     [ union-struct-offsets ] (define-struct-class) ;
 
+ERROR: invalid-struct-slot token ;
+
+: struct-slot-class ( c-type -- class' )
+    c-type c-type-boxed-class
+    dup \ byte-array = [ drop \ c-ptr ] when ;
+
+: parse-struct-slot ( -- slot )
+    struct-slot-spec new
+    scan >>name
+    scan [ >>c-type ] [ struct-slot-class >>class ] bi
+    \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
+    
+: parse-struct-slots ( slots -- slots' more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot over push t ] }
+        [ invalid-struct-slot ]
+    } case ;
+
 : parse-struct-definition ( -- class slots )
-    CREATE-CLASS [ parse-tuple-slots ] { } make ;
+    CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
 
 SYNTAX: STRUCT:
     parse-struct-definition define-struct-class ;