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

basis/alien/arrays/arrays-docs.factor

@@ -7,6 +7,6 @@ $nl
 "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 require-c-arrays }
-{ $subsection <c-type-array> }
+{ $subsection <c-array> }
-{ $subsection <c-type-direct-array> } ;
+{ $subsection <c-direct-array> } ;

basis/alien/arrays/arrays.factor

@@ -35,8 +35,8 @@ M: array stack-size drop "void*" stack-size ;
 M: array c-type-boxer-quot
     unclip
     [ array-length ]
-    [ [ require-c-type-arrays ] keep ] bi*
+    [ [ require-c-arrays ] keep ] bi*
-    [ <c-type-direct-array> ] 2curry ;
+    [ <c-direct-array> ] 2curry ;
 
 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
 

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

@@ -49,10 +49,10 @@ HELP: c-setter
 { $errors "Throws an error if the type does not exist." } ;
 
 HELP: <c-array>
-{ $deprecated "New code should use " { $link <c-type-array> } " or the " { $vocab-link "specialized-arrays" } " vocabularies." }
 { $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
-{ $errors "Throws an error if the type does not exist or the requested size is negative." } ;
+{ $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-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
 
 HELP: <c-object>
 { $values { "type" "a C type" } { "array" byte-array } }
@@ -72,8 +72,8 @@ HELP: byte-array>memory
 
 HELP: malloc-array
 { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
-{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-type-direct-array> } "." }
+{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
-{ $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." }
+{ $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-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
 
@@ -89,7 +89,7 @@ HELP: malloc-byte-array
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if memory allocation fails." } ;
 
-{ <c-type-array> <c-type-direct-array> malloc-array } related-words
+{ <c-array> <c-direct-array> malloc-array } related-words
 
 HELP: box-parameter
 { $values { "n" integer } { "ctype" string } }
@@ -130,20 +130,15 @@ HELP: malloc-string
     }
 } ;
 
-HELP: require-c-type-arrays
+HELP: require-c-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." }
+{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-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>
+HELP: <c-direct-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." } ;
+{ $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-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."

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

@@ -24,6 +24,7 @@ size
 align
 array-class
 array-constructor
+(array)-constructor
 direct-array-class
 direct-array-constructor
 sequence-mixin-class ;
@@ -79,47 +80,74 @@ M: string c-type ( name -- type )
 : ?require-word ( word/pair -- )
     dup word? [ drop ] [ first require ] ?if ;
 
-GENERIC: require-c-type-arrays ( c-type -- )
+! These words being foldable means that words need to be
+! recompiled if a C type is redefined. Even so, folding the
+! size facilitates some optimizations.
+GENERIC: heap-size ( type -- size ) foldable
 
-M: object require-c-type-arrays
+M: string heap-size c-type heap-size ;
+
+M: abstract-c-type heap-size size>> ;
+
+GENERIC: require-c-arrays ( c-type -- )
+
+M: object require-c-arrays
     drop ;
 
-M: c-type require-c-type-arrays
+M: c-type require-c-arrays
     [ array-class>> ?require-word ]
     [ sequence-mixin-class>> ?require-word ]
     [ direct-array-class>> ?require-word ] tri ;
 
-M: string require-c-type-arrays
+M: string require-c-arrays
-    c-type require-c-type-arrays ;
+    c-type require-c-arrays ;
 
-M: array require-c-type-arrays
+M: array require-c-arrays
-    first c-type require-c-type-arrays ;
+    first c-type require-c-arrays ;
 
 ERROR: specialized-array-vocab-not-loaded vocab word ;
 
-: c-type-array-constructor ( c-type -- word )
+: c-array-constructor ( c-type -- word )
     array-constructor>> dup array?
     [ first2 specialized-array-vocab-not-loaded ] when ; foldable
 
-: c-type-direct-array-constructor ( c-type -- word )
+: c-(array)-constructor ( c-type -- word )
+    (array)-constructor>> dup array?
+    [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+
+: c-direct-array-constructor ( c-type -- word )
     direct-array-constructor>> dup array?
     [ first2 specialized-array-vocab-not-loaded ] when ; foldable
 
-GENERIC: <c-type-array> ( len c-type -- array )
+GENERIC: <c-array> ( len c-type -- array )
-M: object <c-type-array>
+M: object <c-array>
-    c-type-array-constructor execute( len -- array ) ; inline
+    c-array-constructor execute( len -- array ) ; inline
-M: string <c-type-array>
+M: string <c-array>
-    c-type <c-type-array> ; inline
+    c-type <c-array> ; inline
-M: array <c-type-array>
+M: array <c-array>
-    first c-type <c-type-array> ; inline
+    first c-type <c-array> ; inline
 
-GENERIC: <c-type-direct-array> ( alien len c-type -- array )
+GENERIC: (c-array) ( len c-type -- array )
-M: object <c-type-direct-array>
+M: object (c-array)
-    c-type-direct-array-constructor execute( alien len -- array ) ; inline
+    c-(array)-constructor execute( len -- array ) ; inline
-M: string <c-type-direct-array>
+M: string (c-array)
-    c-type <c-type-direct-array> ; inline
+    c-type (c-array) ; inline
-M: array <c-type-direct-array>
+M: array (c-array)
-    first c-type <c-type-direct-array> ; inline
+    first c-type (c-array) ; inline
+
+GENERIC: <c-direct-array> ( alien len c-type -- array )
+M: object <c-direct-array>
+    c-direct-array-constructor execute( alien len -- array ) ; inline
+M: string <c-direct-array>
+    c-type <c-direct-array> ; inline
+M: array <c-direct-array>
+    first c-type <c-direct-array> ; inline
+
+: malloc-array ( n type -- alien )
+    [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
+
+: (malloc-array) ( n type -- alien )
+    [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
 
 GENERIC: c-type-class ( name -- class )
 
@@ -219,15 +247,6 @@ M: c-type unbox-return f swap c-type-unbox ;
 
 M: string unbox-return c-type unbox-return ;
 
-! These words being foldable means that words need to be
-! recompiled if a C type is redefined. Even so, folding the
-! size facilitates some optimizations.
-GENERIC: heap-size ( type -- size ) foldable
-
-M: string heap-size c-type heap-size ;
-
-M: abstract-c-type heap-size size>> ;
-
 GENERIC: stack-size ( type -- size ) foldable
 
 M: string stack-size c-type stack-size ;
@@ -253,21 +272,12 @@ M: f byte-length drop 0 ; inline
         [ "Cannot write struct fields with this type" throw ]
     ] unless* ;
 
-: <c-array> ( n type -- array )
-    heap-size * <byte-array> ; inline deprecated
-
 : <c-object> ( type -- array )
     heap-size <byte-array> ; inline
 
 : (c-object) ( type -- array )
     heap-size (byte-array) ; inline
 
-: malloc-array ( n type -- alien )
-    [ heap-size calloc ] [ <c-type-direct-array> ] 2bi ; inline
-
-: (malloc-array) ( n type -- alien )
-    [ heap-size * malloc ] [ <c-type-direct-array> ] 2bi ; inline
-
 : malloc-object ( type -- alien )
     1 swap heap-size calloc ; inline
 
@@ -354,6 +364,10 @@ M: long-long-type box-return ( type -- )
             [ "specialized-arrays." prepend ]
             [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
         ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
+        ]
         [
             [ "specialized-arrays." prepend ]
             [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class

basis/classes/struct/prettyprint/prettyprint.factor

@@ -1,7 +1,9 @@
 ! (c)Joe Groff bsd license
-USING: accessors assocs classes classes.struct combinators
+USING: accessors alien alien.c-types arrays assocs classes
-kernel math prettyprint.backend prettyprint.custom
+classes.struct combinators continuations fry kernel make math
-prettyprint.sections see.private sequences strings words ;
+math.parser mirrors prettyprint.backend prettyprint.custom
+prettyprint.sections see.private sequences strings
+summary words ;
 IN: classes.struct.prettyprint
 
 <PRIVATE
@@ -12,7 +14,7 @@ IN: classes.struct.prettyprint
     [ drop \ STRUCT: ] if ;
 
 : struct>assoc ( struct -- assoc )
-    [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
+    [ class struct-slots ] [ struct-slot-values ] bi zip ;
 
 : pprint-struct-slot ( slot -- )
     <flow \ { pprint-word
@@ -24,6 +26,17 @@ IN: classes.struct.prettyprint
     } cleave
     \ } pprint-word block> ;
 
+: pprint-struct ( struct -- )
+    [
+        [ \ S{ ] dip
+        [ class ]
+        [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
+        \ } (pprint-tuple)
+    ] ?pprint-tuple ;
+
+: pprint-struct-pointer ( struct -- )
+    \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
+
 PRIVATE>
 
 M: struct-class see-class*
@@ -38,4 +51,23 @@ M: struct >pprint-sequence
     [ class ] [ struct-slot-values ] bi class-slot-sequence ;
 
 M: struct pprint*
-    [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
+    [ pprint-struct ]
+    [ pprint-struct-pointer ] pprint-c-object ;
+
+M: struct summary
+    [
+        dup class name>> %
+        " struct of " %
+        byte-length #
+        " bytes " %
+    ] "" make ;
+
+M: struct make-mirror
+    [
+        [ drop "underlying" ] [ (underlying)>> ] bi 2array 1array
+    ] [
+        '[
+            _ struct>assoc
+            [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map
+        ] [ drop { } ] recover
+    ] bi append ;

basis/classes/struct/struct-docs.factor

@@ -42,6 +42,13 @@ HELP: S{
 { $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
 { $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
 
+HELP: S@
+{ $syntax "S@ class alien" }
+{ $values { "class" "a " { $link struct } " class word" } { "alien" "a literal alien" } }
+{ $description "Marks the beginning of a literal struct at a specific C address. The prettyprinter uses this syntax when the memory backing a struct object is invalid. This syntax should not generally be used in source code." } ;
+
+{ POSTPONE: S{ POSTPONE: S@ } related-words
+
 HELP: UNION-STRUCT:
 { $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
 { $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }

basis/classes/struct/struct-tests.factor

@@ -1,12 +1,12 @@
 ! (c)Joe Groff bsd license
 USING: accessors alien alien.c-types alien.libraries
-alien.structs.fields alien.syntax ascii classes.struct combinators
+alien.structs.fields alien.syntax ascii byte-arrays classes.struct
-destructors io.encodings.utf8 io.pathnames io.streams.string
+combinators destructors io.encodings.utf8 io.pathnames io.streams.string
 kernel libc literals math multiline namespaces prettyprint
 prettyprint.config see sequences specialized-arrays.ushort
 system tools.test compiler.tree.debugger struct-arrays
 classes.tuple.private specialized-arrays.direct.int
-compiler.units byte-arrays specialized-arrays.char ;
+compiler.units specialized-arrays.char ;
 IN: classes.struct.tests
 
 <<
@@ -76,18 +76,38 @@ STRUCT: struct-test-string-ptr
     ] with-destructors
 ] unit-test
 
-[ "S{ struct-test-foo { y 7654 } }" ]
+[ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
 [
-    f boa-tuples?
+    [
-    [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+        boa-tuples? off
-    with-variable
+        c-object-pointers? off
+        struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
+    ] with-scope
+] unit-test
+
+[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
+[
+    [
+        c-object-pointers? on
+        12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
+    ] with-scope
 ] unit-test
 
 [ "S{ struct-test-foo f 0 7654 f }" ]
 [
-    t boa-tuples?
+    [
-    [ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
+        boa-tuples? on
-    with-variable
+        c-object-pointers? off
+        struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
+    ] with-scope
+] unit-test
+
+[ "S@ struct-test-foo f" ]
+[
+    [
+        c-object-pointers? off
+        f struct-test-foo memory>struct [ pprint ] with-string-writer
+    ] with-scope
 ] unit-test
 
 [ <" USING: classes.struct ;
@@ -164,6 +184,14 @@ STRUCT: struct-test-equality-2
     ] with-destructors
 ] unit-test
 
+[ t ] [
+    [
+        struct-test-equality-1 <struct> 5 >>x
+        struct-test-equality-1 malloc-struct &free 5 >>x
+        [ hashcode ] bi@ =
+    ] with-destructors
+] unit-test
+
 STRUCT: struct-test-ffi-foo
     { x int }
     { y int } ;

basis/classes/struct/struct.factor

@@ -6,7 +6,7 @@ combinators combinators.short-circuit combinators.smart
 functors.backend fry generalizations generic.parser kernel
 kernel.private lexer libc locals macros make math math.order parser
 quotations sequences slots slots.private struct-arrays vectors
-words compiler.tree.propagation.transforms ;
+words compiler.tree.propagation.transforms specialized-arrays.direct.uchar ;
 FROM: slots => reader-word writer-word ;
 IN: classes.struct
 
@@ -23,7 +23,7 @@ TUPLE: struct-slot-spec < slot-spec
 PREDICATE: struct-class < tuple-class
     { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
 
-: struct-slots ( struct -- slots )
+: struct-slots ( struct-class -- slots )
     "struct-slots" word-prop ;
 
 ! struct allocation
@@ -35,7 +35,10 @@ M: struct equal?
     {
         [ [ class ] bi@ = ]
         [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
-    } 2&& ;
+    } 2&& ; inline
+
+M: struct hashcode*
+    [ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline    
 
 : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
 
@@ -254,19 +257,22 @@ PRIVATE>
 
 ERROR: invalid-struct-slot token ;
 
-<PRIVATE
 : struct-slot-class ( c-type -- class' )
     c-type c-type-boxed-class
     dup \ byte-array = [ drop \ c-ptr ] when ;
 
+: <struct-slot-spec> ( name c-type attributes -- slot-spec )
+    [ struct-slot-spec new ] 3dip
+    [ >>name ]
+    [ [ >>c-type ] [ struct-slot-class >>class ] bi ]
+    [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
+
+<PRIVATE
 : scan-c-type ( -- c-type )
     scan dup "{" = [ drop \ } parse-until >array ] when ;
 
 : parse-struct-slot ( -- slot )
-    struct-slot-spec new
+    scan scan-c-type \ } parse-until <struct-slot-spec> ;
-    scan >>name
-    scan-c-type [ >>c-type ] [ struct-slot-class >>class ] bi
-    \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
     
 : parse-struct-slots ( slots -- slots' more? )
     scan {
@@ -287,23 +293,18 @@ SYNTAX: UNION-STRUCT:
 SYNTAX: S{
     scan-word dup struct-slots parse-tuple-literal-slots parsed ;
 
+SYNTAX: S@
+    scan-word scan-object swap memory>struct parsed ;
+
 ! functor support
 
 <PRIVATE
 : scan-c-type` ( -- c-type/param )
     scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
 
-:: parse-struct-slot` ( accum -- accum )
+: parse-struct-slot` ( accum -- accum )
-    scan-string-param :> name
+    scan-string-param scan-c-type` \ } parse-until
-    scan-c-type` :> c-type
+    [ <struct-slot-spec> over push ] 3curry over push-all ;
-    \ } parse-until :> attributes
-    accum {
-        \ struct-slot-spec new 
-            name >>name
-            c-type [ >>c-type ] [ struct-slot-class >>class ] bi
-            attributes [ dup empty? ] [ peel-off-attributes ] until drop
-        over push
-    } over push-all ;
 
 : parse-struct-slots` ( accum -- accum more? )
     scan {

basis/cocoa/enumeration/enumeration.factor

@@ -4,7 +4,7 @@ USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
 locals math sequences vectors fry libc destructors ;
 IN: cocoa.enumeration
 
-<< "id" require-c-type-arrays >>
+<< "id" require-c-arrays >>
 
 CONSTANT: NS-EACH-BUFFER-SIZE 16
 
@@ -19,7 +19,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
     object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
     items-count 0 = [
-        state itemsPtr>> [ items-count "id" <c-type-direct-array> ] [ stackbuf ] if* :> items
+        state itemsPtr>> [ items-count "id" <c-direct-array> ] [ stackbuf ] if* :> items
         items-count iota [ items nth quot call ] each
         object quot state stackbuf count (NSFastEnumeration-each)
     ] unless ; inline recursive

basis/cocoa/messages/messages.factor

@@ -155,12 +155,16 @@ objc>alien-types get [ swap ] assoc-map
 } case
 assoc-union alien>objc-types set-global
 
+: internal-cocoa-type? ( c-type -- ? )
+    [ "?" = ] [ first CHAR: _ = ] bi or ;
+
+: warn-c-type ( c-type -- )
+    dup internal-cocoa-type?
+    [ drop ] [ "Warning: no such C type: " write print ] if ;
+
 : objc-struct-type ( i string -- ctype )
     [ CHAR: = ] 2keep index-from swap subseq
-    dup c-types get key? [
+    dup c-types get key? [ warn-c-type "void*" ] unless ;
-        "Warning: no such C type: " write dup print
-        drop "void*"
-    ] unless ;
 
 ERROR: no-objc-type name ;
 

basis/environment/winnt/winnt.factor

@@ -6,10 +6,10 @@ alien.c-types sequences windows.errors io.streams.memory
 io.encodings io ;
 IN: environment.winnt
 
-<< "TCHAR" require-c-type-arrays >>
+<< "TCHAR" require-c-arrays >>
 
 M: winnt os-env ( key -- value )
-    MAX_UNICODE_PATH "TCHAR" <c-type-array>
+    MAX_UNICODE_PATH "TCHAR" <c-array>
     [ dup length GetEnvironmentVariable ] keep over 0 = [
         2drop f
     ] [

basis/game-input/dinput/dinput.factor

@@ -39,12 +39,14 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
     get IDirectInputDevice8W::SetDataFormat ole32-error ;
 
 : <buffer-size-diprop> ( size -- DIPROPDWORD )
-    "DIPROPDWORD" <c-object>
+    DIPROPDWORD <struct> [
-        "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
+        diph>>
-        "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
+        DIPROPDWORD heap-size  >>dwSize
-        0 over set-DIPROPHEADER-dwObj
+        DIPROPHEADER heap-size >>dwHeaderSize
-        DIPH_DEVICE over set-DIPROPHEADER-dwHow
+        0           >>dwObj
-        swap over set-DIPROPDWORD-dwData ;
+        DIPH_DEVICE >>dwHow
+        drop
+    ] keep swap >>dwData ;
 
 : set-buffer-size ( device size -- )
     DIPROP_BUFFERSIZE swap <buffer-size-diprop>
@@ -63,7 +65,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
     GUID_SysKeyboard device-for-guid
     [ configure-keyboard ]
     [ +keyboard-device+ set-global ] bi
-    256 <byte-array> <keys-array> keyboard-state boa
+    256 <byte-array> 256 <keys-array> keyboard-state boa
     +keyboard-state+ set-global ;
 
 : find-mouse ( -- )
@@ -72,23 +74,20 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
     [ +mouse-device+ set-global ] bi
     0 0 0 0 8 f <array> mouse-state boa
     +mouse-state+ set-global
-    MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
+    MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA <struct-array>
     +mouse-buffer+ set-global ;
 
 : device-info ( device -- DIDEVICEIMAGEINFOW )
-    "DIDEVICEINSTANCEW" <c-object>
+    DIDEVICEINSTANCEW <struct>
-    "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
+        DIDEVICEINSTANCEW heap-size >>dwSize
-    [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
+    [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
 : device-caps ( device -- DIDEVCAPS )
-    "DIDEVCAPS" <c-object>
+    DIDEVCAPS <struct>
-    "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
+        DIDEVCAPS heap-size >>dwSize
-    [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
+    [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline
-
-: <guid> ( memory -- byte-array )
-    "GUID" heap-size memory>byte-array ;
 
 : device-guid ( device -- guid )
-    device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
+    device-info guidInstance>> ; inline
 
 : device-attached? ( device -- ? )
     +dinput+ get swap device-guid
@@ -96,8 +95,9 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
 
 : find-device-axes-callback ( -- alien )
     [ ! ( lpddoi pvRef -- BOOL )
+        [ DIDEVICEOBJECTINSTANCEW memory>struct ] dip
         +controller-devices+ get at
-        swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
+        swap guidType>> {
             { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
             { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
             { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
@@ -118,8 +118,8 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
 : controller-state-template ( device -- controller-state )
     controller-state new
     over device-caps
-    [ DIDEVCAPS-dwButtons f <array> >>buttons ]
+    [ dwButtons>> f <array> >>buttons ]
-    [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
+    [ dwPOVs>> zero? f pov-neutral ? >>pov ] bi
     find-device-axes ;
 
 : device-known? ( guid -- ? )
@@ -129,12 +129,12 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
     device-for-guid {
         [ configure-controller ]
         [ controller-state-template ]
-        [ dup device-guid +controller-guids+ get set-at ]
+        [ dup device-guid clone +controller-guids+ get set-at ]
         [ +controller-devices+ get set-at ]
     } cleave ;
 
 : add-controller ( guid -- )
-    dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
+    dup device-known? [ drop ] [ (add-controller) ] if ;
 
 : remove-controller ( device -- )
     [ +controller-devices+ get delete-at ]
@@ -143,9 +143,9 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
 
 : find-controller-callback ( -- alien )
     [ ! ( lpddi pvRef -- BOOL )
-        drop DIDEVICEINSTANCEW-guidInstance add-controller
+        drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller
         DIENUM_CONTINUE
-    ] LPDIENUMDEVICESCALLBACKW ;
+    ] LPDIENUMDEVICESCALLBACKW ; inline
 
 : find-controllers ( -- )
     +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
@@ -252,11 +252,11 @@ M: dinput-game-input-backend get-controllers
     [ drop controller boa ] { } assoc>map ;
 
 M: dinput-game-input-backend product-string
-    handle>> device-info DIDEVICEINSTANCEW-tszProductName
+    handle>> device-info tszProductName>>
     utf16n alien>string ;
 
 M: dinput-game-input-backend product-id
-    handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
+    handle>> device-info guidProduct>> ;
 M: dinput-game-input-backend instance-id
     handle>> device-guid ;
 
@@ -273,38 +273,36 @@ CONSTANT: pov-values
     }
 
 : >axis ( long -- float )
-    32767 - 32767.0 /f ;
+    32767 - 32767.0 /f ; inline
 : >slider ( long -- float )
-    65535.0 /f ;
+    65535.0 /f ; inline
 : >pov ( long -- symbol )
     dup HEX: FFFF bitand HEX: FFFF =
     [ drop pov-neutral ]
-    [ 2750 + 4500 /i pov-values nth ] if ;
+    [ 2750 + 4500 /i pov-values nth ] if ; inline
-: >buttons ( alien length -- array )
-    memory>byte-array <keys-array> ;
 
 : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
     [ drop ] compose [ 2drop ] if ; inline
 
 : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
     {
-        [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
+        [ over x>> [ lX>> >axis >>x ] (fill-if) ]
-        [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
+        [ over y>> [ lY>> >axis >>y ] (fill-if) ]
-        [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
+        [ over z>> [ lZ>> >axis >>z ] (fill-if) ]
-        [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
+        [ over rx>> [ lRx>> >axis >>rx ] (fill-if) ]
-        [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
+        [ over ry>> [ lRy>> >axis >>ry ] (fill-if) ]
-        [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
+        [ over rz>> [ lRz>> >axis >>rz ] (fill-if) ]
-        [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
+        [ over slider>> [ rglSlider>> first >slider >>slider ] (fill-if) ]
-        [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
+        [ over pov>> [ rgdwPOV>> first >pov >>pov ] (fill-if) ]
-        [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
+        [ rgbButtons>> over buttons>> length <keys-array> >>buttons ]
     } 2cleave ;
 
 : read-device-buffer ( device buffer count -- buffer count' )
-    [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
+    [ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
     [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
 
 : (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
-    [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
+    [ dwData>> 32 >signed ] [ dwOfs>> ] bi {
         { DIMOFS_X [ [ + ] curry change-dx ] }
         { DIMOFS_Y [ [ + ] curry change-dy ] }
         { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
@@ -312,16 +310,15 @@ CONSTANT: pov-values
     } case ;
 
 : fill-mouse-state ( buffer count -- state )
-    [ +mouse-state+ get ] 2dip swap
+    [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
-    [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
 
-: get-device-state ( device byte-array -- )
+: get-device-state ( device DIJOYSTATE2 -- )
     [ dup IDirectInputDevice8W::Poll ole32-error ] dip
-    [ length ] keep
+    [ byte-length ] keep
     IDirectInputDevice8W::GetDeviceState ole32-error ;
 
 : (read-controller) ( handle template -- state )
-    swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
+    swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
     [ fill-controller-state ] [ drop f ] with-acquisition ;
 
 M: dinput-game-input-backend read-controller

basis/game-input/dinput/keys-array/keys-array.factor

@@ -2,13 +2,15 @@ USING: sequences sequences.private math alien.c-types
 accessors ;
 IN: game-input.dinput.keys-array
 
-TUPLE: keys-array underlying ;
+TUPLE: keys-array
+    { underlying sequence read-only }
+    { length integer read-only } ;
 C: <keys-array> keys-array
 
 : >key ( byte -- ? )
     HEX: 80 bitand c-bool> ;
 
-M: keys-array length underlying>> length ;
+M: keys-array length length>> ;
 M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
 
 INSTANCE: keys-array sequence

basis/io/files/info/unix/freebsd/freebsd.factor

@@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.syntax combinators
 io.backend io.files io.files.info io.files.unix kernel math system unix
 unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
 sequences grouping alien.strings io.encodings.utf8 unix.types
-arrays io.files.info.unix classes.struct ;
+arrays io.files.info.unix classes.struct struct-arrays ;
 IN: io.files.info.unix.freebsd
 
 TUPLE: freebsd-file-system-info < unix-file-system-info
@@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
     } cleave ;
 
 M: freebsd file-system-statvfs ( path -- byte-array )
-    \ statvfs <struct> [ \ statvfs io-error ] keep ;
+    \ statvfs <struct> [ statvfs io-error ] keep ;
 
 M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
     {
@@ -50,6 +50,6 @@ M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in
 
 M: freebsd file-systems ( -- array )
     f 0 0 getfsstat dup io-error
-    \ statfs <struct> dup dup length 0 getfsstat io-error
+    \ statfs <struct-array>
-    statfs heap-size group
+    [ dup length 0 getfsstat io-error ]
-    [ f_mntonname>> alien>native-string file-system-info ] map ;
+    [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ;

basis/io/files/info/unix/netbsd/netbsd.factor

@@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix
 combinators system io.backend accessors alien.c-types
 io.encodings.utf8 alien.strings unix.types io.files.unix
 io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
-grouping sequences io.encodings.utf8 classes.struct
+grouping sequences io.encodings.utf8 classes.struct struct-arrays
 io.files.info.unix ;
 IN: io.files.info.unix.netbsd
 
@@ -47,6 +47,6 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
 
 M: netbsd file-systems ( -- array )
     f 0 0 getvfsstat dup io-error
-    \ statvfs <c-type-array> dup dup length 0 getvfsstat io-error
+    \ statvfs <struct-array>
-    \ statvfs heap-size group
+    [ dup length 0 getvfsstat io-error ]
-    [ f_mntonname>> utf8 alien>string file-system-info ] map ;
+    [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ;

basis/io/files/info/unix/openbsd/openbsd.factor

@@ -4,7 +4,8 @@ USING: accessors alien.c-types alien.strings alien.syntax
 combinators io.backend io.files io.files.info io.files.unix kernel math
 sequences system unix unix.getfsstat.openbsd grouping
 unix.statfs.openbsd unix.statvfs.openbsd unix.types
-arrays io.files.info.unix classes.struct ;
+arrays io.files.info.unix classes.struct struct-arrays
+io.encodings.utf8 ;
 IN: io.files.unix.openbsd
 
 TUPLE: freebsd-file-system-info < unix-file-system-info
@@ -34,9 +35,9 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
         [ f_fsid>> >>id ]
         [ f_namemax>> >>name-max ]
         [ f_owner>> >>owner ]
-        [ f_fstypename>> alien>native-string >>type ]
+        [ f_fstypename>> utf8 alien>string >>type ]
-        [ f_mntonname>> alien>native-string >>mount-point ]
+        [ f_mntonname>> utf8 alien>string >>mount-point ]
-        [ f_mntfromname>> alien>native-string >>device-name ]
+        [ f_mntfromname>> utf8 alien>string >>device-name ]
     } cleave ;
 
 M: openbsd file-system-statvfs ( normalized-path -- statvfs )
@@ -47,6 +48,6 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in
 
 M: openbsd file-systems ( -- seq )
     f 0 0 getfsstat dup io-error
-    \ statfs <c-type-array> dup dup length 0 getfsstat io-error 
+    \ statfs <struct-array>
-    \ statfs heap-size group 
+    [ dup length 0 getfsstat io-error ]
-    [ f_mntonname>> alien>native-string file-system-info ] map ;
+    [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ;

basis/io/files/info/windows/windows.factor

@@ -98,11 +98,11 @@ M: windows link-info ( path -- info )
     file-info ;
 
 : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
-    MAX_PATH 1 + [ <byte-array> ] keep
+    MAX_PATH 1 + [ <ushort-array> ] keep
     "DWORD" <c-object>
     "DWORD" <c-object>
     "DWORD" <c-object>
-    MAX_PATH 1 + [ <byte-array> ] keep
+    MAX_PATH 1 + [ <ushort-array> ] keep
     [ GetVolumeInformation win32-error=0/f ] 7 nkeep
     drop 5 nrot drop
     [ utf16n alien>string ] 4 ndip
@@ -154,13 +154,13 @@ M: winnt file-system-info ( path -- file-system-info )
     ] if ;
 
 : find-first-volume ( -- string handle )
-    MAX_PATH 1 + [ <byte-array> ] keep
+    MAX_PATH 1 + [ <ushort-array> ] keep
     dupd
     FindFirstVolume dup win32-error=0/f
     [ utf16n alien>string ] dip ;
 
 : find-next-volume ( handle -- string/f )
-    MAX_PATH 1 + [ <byte-array> tuck ] keep
+    MAX_PATH 1 + [ <ushort-array> tuck ] keep
     FindNextVolume 0 = [
         GetLastError ERROR_NO_MORE_FILES =
         [ drop f ] [ win32-error-string throw ] if

basis/math/blas/matrices/matrices.factor

@@ -132,7 +132,7 @@ M: blas-matrix-base clone
 
 ! XXX try rounding stride to next 128 bit bound for better vectorizin'
 : <empty-matrix> ( rows cols exemplar -- matrix )
-    [ element-type [ * ] dip <c-array> ]
+    [ element-type heap-size * * <byte-array> ]
     [ 2drop ]
     [ f swap (blas-matrix-like) ] 3tri ;
 

basis/math/blas/vectors/vectors.factor

@@ -99,12 +99,12 @@ PRIVATE>
     length v inc>> v (blas-vector-like) ;
 
 : <zero-vector> ( exemplar -- zero )
-    [ element-type <c-object> ]
+    [ element-type heap-size <byte-array> ]
     [ length>> 0 ]
     [ (blas-vector-like) ] tri ;
 
 : <empty-vector> ( length exemplar -- vector )
-    [ element-type <c-array> ]
+    [ element-type heap-size * <byte-array> ]
     [ 1 swap ] 2bi
     (blas-vector-like) ;
 

basis/pango/layouts/layouts.factor

@@ -5,7 +5,7 @@ USING: arrays sequences alien alien.c-types alien.destructors
 alien.syntax math math.functions math.vectors destructors combinators
 colors fonts accessors assocs namespaces kernel pango pango.fonts
 pango.cairo cairo cairo.ffi glib unicode.data images cache init
-math.rectangles fry memoize io.encodings.utf8 ;
+math.rectangles fry memoize io.encodings.utf8 classes.struct ;
 IN: pango.layouts
 
 LIBRARY: pango
@@ -84,8 +84,8 @@ SYMBOL: dpi
     [ set-layout-text ] keep ;
 
 : layout-extents ( layout -- ink-rect logical-rect )
-    "PangoRectangle" <c-object>
+    PangoRectangle <struct>
-    "PangoRectangle" <c-object>
+    PangoRectangle <struct>
     [ pango_layout_get_extents ] 2keep
     [ PangoRectangle>rect ] bi@ ;
 

basis/pango/pango.factor

@@ -2,7 +2,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license
 USING: arrays system alien.destructors alien.c-types alien.syntax alien
-combinators math.rectangles kernel math alien.libraries ;
+combinators math.rectangles kernel math alien.libraries classes.struct
+accessors ;
 IN: pango
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -25,13 +26,13 @@ CONSTANT: PANGO_SCALE 1024
 FUNCTION: PangoContext*
 pango_context_new ( ) ;
 
-C-STRUCT: PangoRectangle
+STRUCT: PangoRectangle
-    { "int" "x" }
+    { x int }
-    { "int" "y" }
+    { y int }
-    { "int" "width" }
+    { width int }
-    { "int" "height" } ;
+    { height int } ;
 
 : PangoRectangle>rect ( PangoRectangle -- rect )
-    [ [ PangoRectangle-x pango>float ] [ PangoRectangle-y pango>float ] bi 2array ]
+    [ [ x>> pango>float ] [ y>> pango>float ] bi 2array ]
-    [ [ PangoRectangle-width pango>float ] [ PangoRectangle-height pango>float ] bi 2array ] bi
+    [ [ width>> pango>float ] [ height>> pango>float ] bi 2array ] bi
     <rect> ;

basis/prettyprint/backend/backend.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors generic hashtables
+USING: accessors arrays byte-arrays byte-vectors continuations
-assocs kernel math namespaces make sequences strings sbufs vectors
+generic hashtables assocs kernel math namespaces make sequences
-words prettyprint.config prettyprint.custom prettyprint.sections
+strings sbufs vectors words prettyprint.config prettyprint.custom
-quotations io io.pathnames io.styles math.parser effects classes.tuple
+prettyprint.sections quotations io io.pathnames io.styles math.parser
-math.order classes.tuple.private classes combinators colors ;
+effects classes.tuple math.order classes.tuple.private classes
+combinators colors ;
 IN: prettyprint.backend
 
 M: effect pprint* effect>string "(" ")" surround text ;
@@ -153,6 +154,15 @@ M: pathname pprint*
 M: tuple pprint*
     pprint-tuple ;
 
+: recover-pprint ( try recovery -- )
+    pprinter-stack get clone
+    [ pprinter-stack set ] curry prepose recover ; inline
+
+: pprint-c-object ( object content-quot pointer-quot -- )
+    [ c-object-pointers? get ] 2dip
+    [ nip ]
+    [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
+
 : do-length-limit ( seq -- trimmed n/f )
     length-limit get dup [
         over length over [-]

basis/prettyprint/config/config-docs.factor

@@ -23,5 +23,8 @@ HELP: string-limit?
 { $var-description "Toggles whether printed strings are truncated to the margin." } ;
 
 HELP: boa-tuples?
-{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." }
+{ $var-description "Toggles whether tuples and structs print in BOA-form or assoc-form." }
 { $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ;
+
+HELP: c-object-pointers?
+{ $var-description "Toggles whether C objects such as structs and direct arrays only print their underlying address. If this flag isn't set, C objects will attempt to print their contents. If a C object points to invalid memory, it will display only its address regardless." } ;

basis/prettyprint/config/config.factor

@@ -13,6 +13,7 @@ SYMBOL: length-limit
 SYMBOL: line-limit
 SYMBOL: string-limit?
 SYMBOL: boa-tuples?
+SYMBOL: c-object-pointers?
 
 4 tab-size set-global
 64 margin set-global

basis/prettyprint/prettyprint-docs.factor

@@ -30,6 +30,7 @@ ARTICLE: "prettyprint-variables" "Prettyprint control variables"
 { $subsection line-limit }
 { $subsection string-limit? }
 { $subsection boa-tuples? }
+{ $subsection c-object-pointers? }
 "Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables."
 {
     $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope."

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

@@ -2,9 +2,17 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: functors sequences sequences.private kernel words classes
 math alien alien.c-types byte-arrays accessors
-specialized-arrays prettyprint.custom ;
+specialized-arrays parser
+prettyprint.backend prettyprint.custom prettyprint.sections ;
 IN: specialized-arrays.direct.functor
 
+<PRIVATE
+
+: pprint-direct-array ( direct-array tag -- )
+    [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
+PRIVATE>
+
 FUNCTOR: define-direct-array ( T -- )
 
 A'      IS ${T}-array
@@ -15,6 +23,7 @@ A'{     IS ${A'}{
 
 A       DEFINES-CLASS direct-${T}-array
 <A>     DEFINES <${A}>
+A'@      DEFINES ${A'}@
 
 NTH     [ T dup c-type-getter-boxer array-accessor ]
 SET-NTH [ T dup c-setter array-accessor ]
@@ -34,11 +43,17 @@ M: A new-sequence drop <A'> ; inline
 
 M: A byte-length length>> T heap-size * ; inline
 
+SYNTAX: A'@ 
+    scan-object scan-object <A> parsed ;
+
 M: A pprint-delims drop \ A'{ \ } ;
 
 M: A >pprint-sequence ;
 
-M: A pprint* pprint-object ;
+M: A pprint*
+    [ pprint-object ]
+    [ \ A'@ pprint-direct-array ]
+    pprint-c-object ;
 
 INSTANCE: A sequence
 INSTANCE: A S

basis/specialized-arrays/functor/functor.factor

@@ -10,10 +10,10 @@ ERROR: bad-byte-array-length byte-array type ;
 M: bad-byte-array-length summary
     drop "Byte array length doesn't divide type width" ;
 
-: (c-array) ( n c-type -- array )
+: (underlying) ( n c-type -- array )
     heap-size * (byte-array) ; inline
 
-: <c-array> ( n type -- array )
+: <underlying> ( n type -- array )
     heap-size * <byte-array> ; inline
 
 FUNCTOR: define-array ( T -- )
@@ -37,9 +37,9 @@ TUPLE: A
 { length array-capacity read-only }
 { underlying byte-array read-only } ;
 
-: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
+: <A> ( n -- specialized-array ) dup T <underlying> A boa ; inline
 
-: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
+: (A) ( n -- specialized-array ) dup T (underlying) A boa ; inline
 
 : byte-array>A ( byte-array -- specialized-array )
     dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
@@ -86,6 +86,7 @@ A T c-type-boxed-class specialize-vector-words
 T c-type
     \ A >>array-class
     \ <A> >>array-constructor
+    \ (A) >>(array)-constructor
     \ S >>sequence-mixin-class
     drop
 

basis/struct-arrays/prettyprint/prettyprint.factor

@@ -1,6 +1,6 @@
 ! (c)Joe Groff bsd license
 USING: accessors arrays kernel prettyprint.backend
-prettyprint.custom sequences struct-arrays ;
+prettyprint.custom prettyprint.sections sequences struct-arrays ;
 IN: struct-arrays.prettyprint
 
 M: struct-array pprint-delims
@@ -9,5 +9,12 @@ M: struct-array pprint-delims
 M: struct-array >pprint-sequence
     [ >array ] [ class>> ] bi prefix ;
 
-M: struct-array pprint* pprint-object ;
+: pprint-struct-array-pointer ( struct-array -- )
+    \ struct-array@ 
+    [ [ class>> pprint-word ] [ underlying>> pprint* ] [ length>> pprint* ] tri ]
+    pprint-prefix ;
+
+M: struct-array pprint*
+    [ pprint-object ]
+    [ pprint-struct-array-pointer ] pprint-c-object ;
 

basis/struct-arrays/struct-arrays-docs.factor

@@ -1,5 +1,5 @@
 IN: struct-arrays
-USING: help.markup help.syntax alien strings math ;
+USING: classes.struct help.markup help.syntax alien strings math multiline ;
 
 HELP: struct-array
 { $class-description "The class of C struct and union arrays."
@@ -14,10 +14,38 @@ HELP: <direct-struct-array>
 { $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } }
 { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
 
+HELP: struct-array-on
+{ $value { "struct" struct } { "length" integer } }
+{ $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." }
+{ $examples
+"This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:"
+{ $code <" USING: alien.syntax classes.struct struct-arrays ;
+IN: scratchpad
+
+STRUCT: zim { zang int } { zung int } ;
+
+FUNCTION: zim* zingle ( ) ; ! Returns a pointer to 20 zims
+
+zingle 20 struct-array-on "> }
+} ;
+
+HELP: struct-array{
+{ $syntax "struct-array{ class value value value ... }" }
+{ $description "Literal syntax for a " { $link struct-array } " containing structs of the given " { $link struct } " class." } ;
+
+HELP: struct-array@
+{ $syntax "struct-array@ class alien length" }
+{ $description "Literal syntax for a " { $link struct-array } " at a particular memory address. The prettyprinter uses this syntax when the memory backing a struct array object is invalid. This syntax should not generally be used in source code." } ;
+
+{ POSTPONE: struct-array{ POSTPONE: struct-array@ } related-words
+
 ARTICLE: "struct-arrays" "C struct and union arrays"
 "The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values."
 { $subsection struct-array }
 { $subsection <struct-array> }
-{ $subsection <direct-struct-array> } ;
+{ $subsection <direct-struct-array> }
+{ $subsection struct-array-on }
+"Struct arrays have literal syntax:"
+{ $subsection POSTPONE: struct-array{ } ;
 
 ABOUT: "struct-arrays"

basis/struct-arrays/struct-arrays.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.structs byte-arrays
-classes.struct kernel libc math parser sequences sequences.private ;
+classes classes.struct kernel libc math parser sequences
+sequences.private words fry memoize compiler.units ;
 IN: struct-arrays
 
 : c-type-struct-class ( c-type -- class )
@@ -11,7 +12,8 @@ TUPLE: struct-array
 { underlying c-ptr read-only }
 { length array-capacity read-only }
 { element-size array-capacity read-only }
-{ class read-only } ;
+{ class read-only }
+{ ctor read-only } ;
 
 M: struct-array length length>> ; inline
 M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
@@ -20,47 +22,65 @@ M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
     [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
 
 M: struct-array nth-unsafe
-    [ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
+    [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
 
 M: struct-array set-nth-unsafe
     [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
 
+: (struct-element-constructor) ( c-type -- word )
+    [
+        "struct-array-ctor" f <word>
+        [
+            swap dup struct-class?
+            [ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
+            (( alien -- object )) define-inline
+        ] keep
+    ] with-compilation-unit ;
+
+! Foldable memo word. This is an optimization; by precompiling a
+! constructor for array elements, we avoid memory>struct's slow path.
+MEMO: struct-element-constructor ( c-type -- word )
+    (struct-element-constructor) ; foldable
+
+: <direct-struct-array> ( alien length c-type -- struct-array )
+    [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
+    tri struct-array boa ; inline
+
 M: struct-array new-sequence
-    [ element-size>> [ * (byte-array) ] 2keep ]
+    [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
-    [ class>> ] bi struct-array boa ; inline
+    <direct-struct-array> ; inline
 
 M: struct-array resize ( n seq -- newseq )
-    [ [ element-size>> * ] [ underlying>> ] bi resize ]
+    [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
-    [ [ element-size>> ] [ class>> ] bi ] 2bi
+    <direct-struct-array> ; inline
-    struct-array boa ;
 
 : <struct-array> ( length c-type -- struct-array )
-    [ heap-size [ * <byte-array> ] 2keep ]
+    [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
-    [ c-type-struct-class ] bi struct-array boa ; inline
 
 ERROR: bad-byte-array-length byte-array ;
 
 : byte-array>struct-array ( byte-array c-type -- struct-array )
-    [ heap-size [
+    [
+        heap-size
         [ dup length ] dip /mod 0 =
         [ drop bad-byte-array-length ] unless
-    ] keep ] [ c-type-struct-class ] bi struct-array boa ; inline
+    ] keep <direct-struct-array> ; inline
 
-: <direct-struct-array> ( alien length c-type -- struct-array )
+: struct-array-on ( struct length -- struct-array )
-    [ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline
+    [ [ >c-ptr ] [ class ] bi ] dip swap <direct-struct-array> ; inline    
 
 : malloc-struct-array ( length c-type -- struct-array )
     [ heap-size calloc ] 2keep <direct-struct-array> ; inline
 
 INSTANCE: struct-array sequence
 
-M: struct-type <c-type-array> ( len c-type -- array )
+M: struct-type <c-array> ( len c-type -- array )
-    dup c-type-array-constructor
+    dup c-array-constructor
     [ execute( len -- array ) ]
     [ <struct-array> ] ?if ; inline
 
-M: struct-type <c-type-direct-array> ( alien len c-type -- array )
+M: struct-type <c-direct-array> ( alien len c-type -- array )
-    dup c-type-direct-array-constructor
+    dup c-direct-array-constructor
     [ execute( alien len -- array ) ]
     [ <direct-struct-array> ] ?if ; inline
 
@@ -71,6 +91,9 @@ M: struct-type <c-type-direct-array> ( alien len c-type -- array )
 SYNTAX: struct-array{
     \ } scan-word [ >struct-array ] curry parse-literal ;
 
+SYNTAX: struct-array@
+    scan-word [ scan-object scan-object ] dip <direct-struct-array> parsed ;
+
 USING: vocabs vocabs.loader ;
 
 "prettyprint" vocab [ "struct-arrays.prettyprint" require ] when

basis/tools/deploy/shaker/shaker.factor

@@ -68,9 +68,14 @@ IN: tools.deploy.shaker
     ] when ;
 
 : strip-destructors ( -- )
-    "libc" vocab [
     "Stripping destructor debug code" show
     "vocab:tools/deploy/shaker/strip-destructors.factor"
+    run-file ;
+
+: strip-struct-arrays ( -- )
+    "struct-arrays" vocab [
+        "Stripping dynamic struct array code" show
+        "vocab:tools/deploy/shaker/strip-struct-arrays.factor"
         run-file
     ] when ;
 
@@ -493,6 +498,7 @@ SYMBOL: deploy-vocab
 : strip ( -- )
     init-stripper
     strip-libc
+    strip-struct-arrays
     strip-destructors
     strip-call
     strip-cocoa

basis/tools/deploy/shaker/strip-call.factor

@@ -1,10 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-IN: tools.deploy.shaker.call
+USING: combinators.private kernel ;
-
 IN: combinators
-USE: combinators.private
 
-: call-effect ( word effect -- ) call-effect-unsafe ; inline
+: call-effect ( word effect -- ) call-effect-unsafe ;
 
-: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
+: execute-effect ( word effect -- ) execute-effect-unsafe ;
+
+IN: compiler.tree.propagation.call-effect
+
+: call-effect-unsafe? ( quot effect -- ? ) 2drop t ; inline
+
+: execute-effect-unsafe? ( word effect -- ? ) 2drop t ; inline

basis/tools/deploy/shaker/strip-struct-arrays.factor

@@ -0,0 +1,13 @@
+USING: kernel stack-checker.transforms ;
+IN: struct-arrays
+
+: struct-element-constructor ( c-type -- word )
+    "Struct array usages must be compiled" throw ;
+
+<<
+
+\ struct-element-constructor [
+    (struct-element-constructor) [ ] curry
+] 1 define-transform
+
+>>

basis/ui/backend/windows/windows.factor

@@ -614,8 +614,8 @@ M: windows-ui-backend do-events
 
 : default-position-RECT ( RECT -- RECT' )
     dup get-RECT-width/height
-        [ CW_USEDEFAULT + >>bottom ] dip
+        [ CW_USEDEFAULT + >>right ] dip
-        CW_USEDEFAULT + >>right
+        CW_USEDEFAULT + >>bottom
         CW_USEDEFAULT >>left
         CW_USEDEFAULT >>top ;
 
@@ -758,7 +758,7 @@ M: windows-ui-backend beep ( -- )
 : client-area>RECT ( hwnd -- RECT )
     RECT <struct>
     [ GetClientRect win32-error=0/f ]
-    [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
+    [ >c-ptr "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
     [ nip ] 2tri ;
 
 : hwnd>RECT ( hwnd -- RECT )

basis/unix/bsd/bsd.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax combinators system vocabs.loader ;
+USING: alien.syntax classes.struct combinators system
+vocabs.loader ;
 IN: unix
 
 CONSTANT: MAXPATHLEN 1024
@@ -46,18 +47,18 @@ C-STRUCT: sockaddr-un
     { "uchar" "family" }
     { { "char" 104 } "path" } ;
 
-C-STRUCT: passwd
+STRUCT: passwd
-    { "char*"  "pw_name" }
+    { pw_name char* }
-    { "char*"  "pw_passwd" }
+    { pw_passwd char* }
-    { "uid_t"  "pw_uid" }
+    { pw_uid uid_t }
-    { "gid_t"  "pw_gid" }
+    { pw_gid gid_t }
-    { "time_t" "pw_change" }
+    { pw_change time_t }
-    { "char*"  "pw_class" }
+    { pw_class char* }
-    { "char*"  "pw_gecos" }
+    { pw_gecos char* }
-    { "char*"  "pw_dir" }
+    { pw_dir char* }
-    { "char*"  "pw_shell" }
+    { pw_shell char* }
-    { "time_t" "pw_expire" }
+    { pw_expire time_t }
-    { "int"    "pw_fields" } ;
+    { pw_fields int } ;
 
 CONSTANT: max-un-path 104
 

basis/unix/groups/groups.factor

@@ -1,12 +1,14 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting unix strings
+io.backend.unix kernel math sequences splitting strings
 combinators.short-circuit byte-arrays combinators
 accessors math.parser fry assocs namespaces continuations
-unix.users unix.utilities ;
+unix.users unix.utilities classes.struct ;
 IN: unix.groups
 
+QUALIFIED: unix
+
 QUALIFIED: grouping
 
 TUPLE: group id name passwd members ;
@@ -18,27 +20,27 @@ GENERIC: group-struct ( obj -- group/f )
 <PRIVATE
 
 : group-members ( group-struct -- seq )
-    group-gr_mem utf8 alien>strings ;
+    gr_mem>> utf8 alien>strings ;
 
 : (group-struct) ( id -- group-struct id group-struct byte-array length void* )
-    "group" <c-object> tuck 4096
+    \ unix:group <struct> tuck 4096
     [ <byte-array> ] keep f <void*> ;
 
 : check-group-struct ( group-struct ptr -- group-struct/f )
     *void* [ drop f ] unless ;
 
 M: integer group-struct ( id -- group/f )
-    (group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
+    (group-struct) [ unix:getgrgid_r unix:io-error ] keep check-group-struct ;
 
 M: string group-struct ( string -- group/f )
-    (group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
+    (group-struct) [ unix:getgrnam_r unix:io-error ] keep check-group-struct ;
 
 : group-struct>group ( group-struct -- group )
     [ \ group new ] dip
     {
-        [ group-gr_name >>name ]
+        [ gr_name>> >>name ]
-        [ group-gr_passwd >>passwd ]
+        [ gr_passwd>> >>passwd ]
-        [ group-gr_gid >>id ]
+        [ gr_gid>> >>id ]
         [ group-members >>members ]
     } cleave ;
 
@@ -48,12 +50,12 @@ PRIVATE>
     dup group-cache get [
         ?at [ name>> ] [ number>string ] if
     ] [
-        group-struct [ group-gr_name ] [ f ] if*
+        group-struct [ gr_name>> ] [ f ] if*
     ] if*
     [ nip ] [ number>string ] if* ;
 
 : group-id ( string -- id/f )
-    group-struct [ group-gr_gid ] [ f ] if* ;
+    group-struct [ gr_gid>> ] [ f ] if* ;
 
 <PRIVATE
 
@@ -62,8 +64,8 @@ PRIVATE>
 
 : (user-groups) ( string -- seq )
     #! first group is -1337, legacy unix code
-    -1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
+    -1337 unix:NGROUPS_MAX [ 4 * <byte-array> ] keep
-    <int> [ getgrouplist io-error ] 2keep
+    <int> [ unix:getgrouplist unix:io-error ] 2keep
     [ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
 
 PRIVATE>
@@ -77,7 +79,7 @@ M: integer user-groups ( id -- seq )
     user-name (user-groups) ;
     
 : all-groups ( -- seq )
-    [ getgrent dup ] [ group-struct>group ] produce nip ;
+    [ unix:getgrent dup ] [ \ unix:group memory>struct group-struct>group ] produce nip ;
 
 : <group-cache> ( -- assoc )
     all-groups [ [ id>> ] keep ] H{ } map>assoc ;
@@ -85,14 +87,11 @@ M: integer user-groups ( id -- seq )
 : with-group-cache ( quot -- )
     [ <group-cache> group-cache ] dip with-variable ; inline
 
-: real-group-id ( -- id )
+: real-group-id ( -- id ) unix:getgid ; inline
-    getgid ; inline
 
-: real-group-name ( -- string )
+: real-group-name ( -- string ) real-group-id group-name ; inline
-    real-group-id group-name ; inline
 
-: effective-group-id ( -- string )
+: effective-group-id ( -- string ) unix:getegid ; inline
-    getegid ; inline
 
 : effective-group-name ( -- string )
     effective-group-id group-name ; inline
@@ -112,10 +111,10 @@ GENERIC: set-effective-group ( obj -- )
 <PRIVATE
 
 : (set-real-group) ( id -- )
-    setgid io-error ; inline
+    unix:setgid unix:io-error ; inline
 
 : (set-effective-group) ( id -- )
-    setegid io-error ; inline
+    unix:setegid unix:io-error ; inline
 
 PRIVATE>
     

basis/unix/linux/linux.factor

@@ -84,14 +84,14 @@ CONSTANT: SEEK_SET 0
 CONSTANT: SEEK_CUR 1
 CONSTANT: SEEK_END 2
 
-C-STRUCT: passwd
+STRUCT: passwd
-    { "char*"  "pw_name" }
+    { pw_name char* }
-    { "char*"  "pw_passwd" }
+    { pw_passwd char* }
-    { "uid_t"  "pw_uid" }
+    { pw_uid uid_t }
-    { "gid_t"  "pw_gid" }
+    { pw_gid gid_t }
-    { "char*"  "pw_gecos" }
+    { pw_gecos char* }
-    { "char*"  "pw_dir" }
+    { pw_dir char* }
-    { "char*"  "pw_shell" } ;
+    { pw_shell char* } ;
 
 ! dirent64
 STRUCT: dirent

basis/unix/unix.factor

@@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc
 sequences continuations byte-arrays strings math namespaces
 system combinators vocabs.loader accessors
 stack-checker macros locals generalizations unix.types
-io vocabs ;
+io vocabs classes.struct ;
 IN: unix
 
 CONSTANT: PROT_NONE   0
@@ -35,11 +35,11 @@ CONSTANT: DT_LNK      10
 CONSTANT: DT_SOCK     12
 CONSTANT: DT_WHT      14
 
-C-STRUCT: group
+STRUCT: group
-    { "char*" "gr_name" }
+    { gr_name char* }
-    { "char*" "gr_passwd" }
+    { gr_passwd char* }
-    { "int" "gr_gid" }
+    { gr_gid int }
-    { "char**" "gr_mem" } ;
+    { gr_mem char** } ;
 
 LIBRARY: libc
 
@@ -147,18 +147,18 @@ M: unix open-file [ open ] unix-system-call ;
 
 FUNCTION: DIR* opendir ( char* path ) ;
 
-C-STRUCT: utimbuf
+STRUCT: utimbuf
-    { "time_t" "actime"  }
+    { actime time_t }
-    { "time_t" "modtime" } ;
+    { modtime time_t } ;
 
-FUNCTION: int utime ( char* path, utimebuf* buf ) ;
+FUNCTION: int utime ( char* path, utimbuf* buf ) ;
 
 : touch ( filename -- ) f [ utime ] unix-system-call drop ;
 
 : change-file-times ( filename access modification -- )
-    "utimebuf" <c-object>
+    utimbuf <struct>
-    [ set-utimbuf-modtime ] keep
+        swap >>modtime
-    [ set-utimbuf-actime ] keep
+        swap >>actime
         [ utime ] unix-system-call drop ;
 
 FUNCTION: int pclose ( void* file ) ;

basis/unix/users/bsd/bsd.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators accessors kernel unix unix.users
+USING: combinators accessors kernel unix.users
 system ;
 IN: unix.users.bsd
+QUALIFIED: unix
 
 TUPLE: bsd-passwd < passwd change class expire fields ;
 
@@ -11,9 +12,9 @@ M: bsd new-passwd ( -- bsd-passwd ) bsd-passwd new ;
 M: bsd passwd>new-passwd ( passwd -- bsd-passwd )
     [ call-next-method ] keep
     {
-        [ passwd-pw_change >>change ]
+        [ pw_change>> >>change ]
-        [ passwd-pw_class >>class ]
+        [ pw_class>> >>class ]
-        [ passwd-pw_shell >>shell ]
+        [ pw_shell>> >>shell ]
-        [ passwd-pw_expire >>expire ]
+        [ pw_expire>> >>expire ]
-        [ passwd-pw_fields >>fields ]
+        [ pw_fields>> >>fields ]
     } cleave ;

basis/unix/users/users.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting unix strings
+io.backend.unix kernel math sequences splitting strings
 combinators.short-circuit grouping byte-arrays combinators
 accessors math.parser fry assocs namespaces continuations
-vocabs.loader system ;
+vocabs.loader system classes.struct ;
 IN: unix.users
+QUALIFIED: unix
 
 TUPLE: passwd user-name password uid gid gecos dir shell ;
 
@@ -20,23 +21,23 @@ M: unix new-passwd ( -- passwd )
 M: unix passwd>new-passwd ( passwd -- seq )
     [ new-passwd ] dip
     {
-        [ passwd-pw_name >>user-name ]
+        [ pw_name>> >>user-name ]
-        [ passwd-pw_passwd >>password ]
+        [ pw_passwd>> >>password ]
-        [ passwd-pw_uid >>uid ]
+        [ pw_uid>> >>uid ]
-        [ passwd-pw_gid >>gid ]
+        [ pw_gid>> >>gid ]
-        [ passwd-pw_gecos >>gecos ]
+        [ pw_gecos>> >>gecos ]
-        [ passwd-pw_dir >>dir ]
+        [ pw_dir>> >>dir ]
-        [ passwd-pw_shell >>shell ]
+        [ pw_shell>> >>shell ]
     } cleave ;
 
 : with-pwent ( quot -- )
-    [ endpwent ] [ ] cleanup ; inline
+    [ unix:endpwent ] [ ] cleanup ; inline
 
 PRIVATE>
 
 : all-users ( -- seq )
     [
-        [ getpwent dup ] [ passwd>new-passwd ] produce nip
+        [ unix:getpwent dup ] [ unix:passwd memory>struct passwd>new-passwd ] produce nip
     ] with-pwent ;
 
 SYMBOL: user-cache
@@ -51,10 +52,10 @@ GENERIC: user-passwd ( obj -- passwd/f )
 
 M: integer user-passwd ( id -- passwd/f )
     user-cache get
-    [ at ] [ getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
+    [ at ] [ unix:getpwuid [ unix:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ;
 
 M: string user-passwd ( string -- passwd/f )
-    getpwnam dup [ passwd>new-passwd ] when ;
+    unix:getpwnam dup [ unix:passwd memory>struct passwd>new-passwd ] when ;
 
 : user-name ( id -- string )
     dup user-passwd
@@ -64,13 +65,13 @@ M: string user-passwd ( string -- passwd/f )
     user-passwd uid>> ;
 
 : real-user-id ( -- id )
-    getuid ; inline
+    unix:getuid ; inline
 
 : real-user-name ( -- string )
     real-user-id user-name ; inline
 
 : effective-user-id ( -- id )
-    geteuid ; inline
+    unix:geteuid ; inline
 
 : effective-user-name ( -- string )
     effective-user-id user-name ; inline
@@ -92,10 +93,10 @@ GENERIC: set-effective-user ( string/id -- )
 <PRIVATE
 
 : (set-real-user) ( id -- )
-    setuid io-error ; inline
+    unix:setuid unix:io-error ; inline
 
 : (set-effective-user) ( id -- )
-    seteuid io-error ; inline
+    unix:seteuid unix:io-error ; inline
 
 PRIVATE>
 

basis/windows/com/wrapper/wrapper.factor

@@ -3,7 +3,8 @@ init windows.com.syntax.private windows.com continuations kernel
 namespaces windows.ole32 libc vocabs assocs accessors arrays
 sequences quotations combinators math words compiler.units
 destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien ;
+specialized-arrays.alien specialized-arrays.direct.alien
+windows.kernel32 ;
 IN: windows.com.wrapper
 
 TUPLE: com-wrapper < disposable callbacks vtbls ;

basis/windows/dinput/constants/constants.factor

@@ -2,7 +2,7 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com
 windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
 combinators sequences fry math accessors macros words quotations
 libc continuations generalizations splitting locals assocs init
-struct-arrays memoize ;
+struct-arrays memoize classes.struct ;
 IN: windows.dinput.constants
 
 ! Some global variables aren't provided by the DirectInput DLL (they're in the
@@ -38,14 +38,6 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
 : (flags) ( array -- n )
     0 [ (flag) bitor ] reduce ;
 
-: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien )
-    [ {
-        [ set-DIOBJECTDATAFORMAT-dwFlags ]
-        [ set-DIOBJECTDATAFORMAT-dwType ]
-        [ set-DIOBJECTDATAFORMAT-dwOfs ]
-        [ set-DIOBJECTDATAFORMAT-pguid ]
-    } cleave ] keep ;
-
 : <DIOBJECTDATAFORMAT> ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- alien )
     {
         [ first dup word? [ get ] when ]
@@ -54,10 +46,10 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
         [ fourth (flags) ]
         [ 4 swap nth (flag) ]
     } cleave
-    "DIOBJECTDATAFORMAT" <c-object> (DIOBJECTDATAFORMAT) ;
+    DIOBJECTDATAFORMAT <struct-boa> ;
 
 :: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
-    [let | alien [ array length "DIOBJECTDATAFORMAT" malloc-struct-array ] |
+    [let | alien [ array length DIOBJECTDATAFORMAT malloc-struct-array ] |
         array [| args i |
             struct args <DIOBJECTDATAFORMAT>
             i alien set-nth
@@ -65,22 +57,10 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
         alien
     ] ;
 
-: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
-    [
-        {
-            [ set-DIDATAFORMAT-rgodf ]
-            [ set-DIDATAFORMAT-dwNumObjs ]
-            [ set-DIDATAFORMAT-dwDataSize ]
-            [ set-DIDATAFORMAT-dwFlags ]
-            [ set-DIDATAFORMAT-dwObjSize ]
-            [ set-DIDATAFORMAT-dwSize ]
-        } cleave
-    ] keep ;
-
 : <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
-    [ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip
+    [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
     [ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
-    "DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
+    DIDATAFORMAT <struct-boa> ;
 
 : initialize ( symbol quot -- )
     call swap set-global ; inline
@@ -861,7 +841,7 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
 
     {
         c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
-    } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
+    } [ [ rgodf>> free ] uninitialize ] each ;
 
 PRIVATE>
 

basis/windows/dinput/dinput.factor

@@ -1,5 +1,6 @@
 USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
-alien alien.c-types alien.syntax kernel system namespaces math ;
+alien alien.c-types alien.syntax kernel system namespaces math
+classes.struct ;
 IN: windows.dinput
 
 LIBRARY: dinput
@@ -35,291 +36,293 @@ TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
 
 TYPEDEF: DWORD D3DCOLOR
 
-C-STRUCT: DIDEVICEINSTANCEW
+STRUCT: DIDEVICEINSTANCEW
-    { "DWORD"      "dwSize" }
+    { dwSize          DWORD      }
-    { "GUID"       "guidInstance" }
+    { guidInstance    GUID       }
-    { "GUID"       "guidProduct" }
+    { guidProduct     GUID       }
-    { "DWORD"      "dwDevType" }
+    { dwDevType       DWORD      }
-    { "WCHAR[260]" "tszInstanceName" }
+    { tszInstanceName WCHAR[260] }
-    { "WCHAR[260]" "tszProductName" }
+    { tszProductName  WCHAR[260] }
-    { "GUID"       "guidFFDriver" }
+    { guidFFDriver    GUID       }
-    { "WORD"       "wUsagePage" }
+    { wUsagePage      WORD       }
-    { "WORD"       "wUsage" } ;
+    { wUsage          WORD       } ;
 TYPEDEF: DIDEVICEINSTANCEW* LPDIDEVICEINSTANCEW
 TYPEDEF: DIDEVICEINSTANCEW* LPCDIDEVICEINSTANCEW
-C-UNION: DIACTION-union "LPCWSTR" "UINT" ;
+UNION-STRUCT: DIACTION-union
-C-STRUCT: DIACTIONW
+    { lptszActionName LPCWSTR }
-    { "UINT_PTR"       "uAppData" }
+    { uResIdString    UINT    } ;
-    { "DWORD"          "dwSemantic" }
+STRUCT: DIACTIONW
-    { "DWORD"          "dwFlags" }
+    { uAppData     UINT_PTR       }
-    { "DIACTION-union" "lptszActionName-or-uResIdString" }
+    { dwSemantic   DWORD          }
-    { "GUID"           "guidInstance" }
+    { dwFlags      DWORD          }
-    { "DWORD"          "dwObjID" }
+    { union        DIACTION-union }
-    { "DWORD"          "dwHow" } ;
+    { guidInstance GUID           }
+    { dwObjID      DWORD          }
+    { dwHow        DWORD          } ;
 TYPEDEF: DIACTIONW* LPDIACTIONW
 TYPEDEF: DIACTIONW* LPCDIACTIONW
-C-STRUCT: DIACTIONFORMATW
+STRUCT: DIACTIONFORMATW
-    { "DWORD"       "dwSize" }
+    { dwSize        DWORD       }
-    { "DWORD"       "dwActionSize" }
+    { dwActionSize  DWORD       }
-    { "DWORD"       "dwDataSize" }
+    { dwDataSize    DWORD       }
-    { "DWORD"       "dwNumActions" }
+    { dwNumActions  DWORD       }
-    { "LPDIACTIONW" "rgoAction" }
+    { rgoAction     LPDIACTIONW }
-    { "GUID"        "guidActionMap" }
+    { guidActionMap GUID        }
-    { "DWORD"       "dwGenre" }
+    { dwGenre       DWORD       }
-    { "DWORD"       "dwBufferSize" }
+    { dwBufferSize  DWORD       }
-    { "LONG"        "lAxisMin" }
+    { lAxisMin      LONG        }
-    { "LONG"        "lAxisMax" }
+    { lAxisMax      LONG        }
-    { "HINSTANCE"   "hInstString" }
+    { hInstString   HINSTANCE   }
-    { "FILETIME"    "ftTimeStamp" }
+    { ftTimeStamp   FILETIME    }
-    { "DWORD"       "dwCRC" }
+    { dwCRC         DWORD       }
-    { "WCHAR[260]"  "tszActionMap" } ;
+    { tszActionMap  WCHAR[260]  } ;
 TYPEDEF: DIACTIONFORMATW* LPDIACTIONFORMATW
 TYPEDEF: DIACTIONFORMATW* LPCDIACTIONFORMATW
-C-STRUCT: DICOLORSET
+STRUCT: DICOLORSET
-    { "DWORD"    "dwSize" }
+    { dwSize            DWORD    }
-    { "D3DCOLOR" "cTextFore" }
+    { cTextFore         D3DCOLOR }
-    { "D3DCOLOR" "cTextHighlight" }
+    { cTextHighlight    D3DCOLOR }
-    { "D3DCOLOR" "cCalloutLine" }
+    { cCalloutLine      D3DCOLOR }
-    { "D3DCOLOR" "cCalloutHighlight" }
+    { cCalloutHighlight D3DCOLOR }
-    { "D3DCOLOR" "cBorder" }
+    { cBorder           D3DCOLOR }
-    { "D3DCOLOR" "cControlFill" }
+    { cControlFill      D3DCOLOR }
-    { "D3DCOLOR" "cHighlightFill" }
+    { cHighlightFill    D3DCOLOR }
-    { "D3DCOLOR" "cAreaFill" } ;
+    { cAreaFill         D3DCOLOR } ;
 TYPEDEF: DICOLORSET* LPDICOLORSET
 TYPEDEF: DICOLORSET* LPCDICOLORSET
 
-C-STRUCT: DICONFIGUREDEVICESPARAMSW
+STRUCT: DICONFIGUREDEVICESPARAMSW
-    { "DWORD"             "dwSize" }
+    { dwSize         DWORD             }
-    { "DWORD"             "dwcUsers" }
+    { dwcUsers       DWORD             }
-    { "LPWSTR"            "lptszUserNames" }
+    { lptszUserNames LPWSTR            }
-    { "DWORD"             "dwcFormats" }
+    { dwcFormats     DWORD             }
-    { "LPDIACTIONFORMATW" "lprgFormats" }
+    { lprgFormats    LPDIACTIONFORMATW }
-    { "HWND"              "hwnd" }
+    { hwnd           HWND              }
-    { "DICOLORSET"        "dics" }
+    { dics           DICOLORSET        }
-    { "IUnknown*"         "lpUnkDDSTarget" } ;
+    { lpUnkDDSTarget IUnknown*         } ;
 TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
 TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
 
-C-STRUCT: DIDEVCAPS
+STRUCT: DIDEVCAPS
-    { "DWORD" "dwSize" }
+    { dwSize DWORD }
-    { "DWORD" "dwFlags" }
+    { dwFlags DWORD }
-    { "DWORD" "dwDevType" }
+    { dwDevType DWORD }
-    { "DWORD" "dwAxes" }
+    { dwAxes DWORD }
-    { "DWORD" "dwButtons" }
+    { dwButtons DWORD }
-    { "DWORD" "dwPOVs" }
+    { dwPOVs DWORD }
-    { "DWORD" "dwFFSamplePeriod" }
+    { dwFFSamplePeriod DWORD }
-    { "DWORD" "dwFFMinTimeResolution" }
+    { dwFFMinTimeResolution DWORD }
-    { "DWORD" "dwFirmwareRevision" }
+    { dwFirmwareRevision DWORD }
-    { "DWORD" "dwHardwareRevision" }
+    { dwHardwareRevision DWORD }
-    { "DWORD" "dwFFDriverVersion" } ;
+    { dwFFDriverVersion DWORD } ;
 TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
 TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
-C-STRUCT: DIDEVICEOBJECTINSTANCEW
+STRUCT: DIDEVICEOBJECTINSTANCEW
-    { "DWORD" "dwSize" }
+    { dwSize DWORD }
-    { "GUID" "guidType" }
+    { guidType GUID }
-    { "DWORD" "dwOfs" }
+    { dwOfs DWORD }
-    { "DWORD" "dwType" }
+    { dwType DWORD }
-    { "DWORD" "dwFlags" }
+    { dwFlags DWORD }
-    { "WCHAR[260]" "tszName" }
+    { tszName WCHAR[260] }
-    { "DWORD" "dwFFMaxForce" }
+    { dwFFMaxForce DWORD }
-    { "DWORD" "dwFFForceResolution" }
+    { dwFFForceResolution DWORD }
-    { "WORD" "wCollectionNumber" }
+    { wCollectionNumber WORD }
-    { "WORD" "wDesignatorIndex" }
+    { wDesignatorIndex WORD }
-    { "WORD" "wUsagePage" }
+    { wUsagePage WORD }
-    { "WORD" "wUsage" }
+    { wUsage WORD }
-    { "DWORD" "dwDimension" }
+    { dwDimension DWORD }
-    { "WORD" "wExponent" }
+    { wExponent WORD }
-    { "WORD" "wReportId" } ;
+    { wReportId WORD } ;
 TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
 TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
-C-STRUCT: DIDEVICEOBJECTDATA
+STRUCT: DIDEVICEOBJECTDATA
-    { "DWORD"    "dwOfs" }
+    { dwOfs DWORD    }
-    { "DWORD"    "dwData" }
+    { dwData DWORD    }
-    { "DWORD"    "dwTimeStamp" }
+    { dwTimeStamp DWORD    }
-    { "DWORD"    "dwSequence" }
+    { dwSequence DWORD    }
-    { "UINT_PTR" "uAppData" } ;
+    { uAppData UINT_PTR } ;
 TYPEDEF: DIDEVICEOBJECTDATA* LPDIDEVICEOBJECTDATA
 TYPEDEF: DIDEVICEOBJECTDATA* LPCDIDEVICEOBJECTDATA
-C-STRUCT: DIOBJECTDATAFORMAT
+STRUCT: DIOBJECTDATAFORMAT
-    { "GUID*" "pguid" }
+    { pguid GUID* }
-    { "DWORD" "dwOfs" }
+    { dwOfs DWORD }
-    { "DWORD" "dwType" }
+    { dwType DWORD }
-    { "DWORD" "dwFlags" } ;
+    { dwFlags DWORD } ;
 TYPEDEF: DIOBJECTDATAFORMAT* LPDIOBJECTDATAFORMAT
 TYPEDEF: DIOBJECTDATAFORMAT* LPCDIOBJECTDATAFORMAT
-C-STRUCT: DIDATAFORMAT
+STRUCT: DIDATAFORMAT
-    { "DWORD" "dwSize" }
+    { dwSize DWORD }
-    { "DWORD" "dwObjSize" }
+    { dwObjSize DWORD }
-    { "DWORD" "dwFlags" }
+    { dwFlags DWORD }
-    { "DWORD" "dwDataSize" }
+    { dwDataSize DWORD }
-    { "DWORD" "dwNumObjs" }
+    { dwNumObjs DWORD }
-    { "LPDIOBJECTDATAFORMAT" "rgodf" } ;
+    { rgodf LPDIOBJECTDATAFORMAT } ;
 TYPEDEF: DIDATAFORMAT* LPDIDATAFORMAT
 TYPEDEF: DIDATAFORMAT* LPCDIDATAFORMAT
-C-STRUCT: DIPROPHEADER
+STRUCT: DIPROPHEADER
-    { "DWORD" "dwSize" }
+    { dwSize DWORD }
-    { "DWORD" "dwHeaderSize" }
+    { dwHeaderSize DWORD }
-    { "DWORD" "dwObj" }
+    { dwObj DWORD }
-    { "DWORD" "dwHow" } ;
+    { dwHow DWORD } ;
 TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
 TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER
-C-STRUCT: DIPROPDWORD
+STRUCT: DIPROPDWORD
-    { "DIPROPHEADER" "diph" }
+    { diph DIPROPHEADER }
-    { "DWORD"        "dwData" } ;
+    { dwData DWORD        } ;
 TYPEDEF: DIPROPDWORD* LPDIPROPDWORD
 TYPEDEF: DIPROPDWORD* LPCDIPROPDWORD
-C-STRUCT: DIPROPPOINTER
+STRUCT: DIPROPPOINTER
-    { "DIPROPHEADER" "diph" }
+    { diph DIPROPHEADER }
-    { "UINT_PTR" "uData" } ;
+    { uData UINT_PTR } ;
 TYPEDEF: DIPROPPOINTER* LPDIPROPPOINTER
 TYPEDEF: DIPROPPOINTER* LPCDIPROPPOINTER
-C-STRUCT: DIPROPRANGE
+STRUCT: DIPROPRANGE
-    { "DIPROPHEADER" "diph" }
+    { diph DIPROPHEADER }
-    { "LONG" "lMin" }
+    { lMin LONG }
-    { "LONG" "lMax" } ;
+    { lMax LONG } ;
 TYPEDEF: DIPROPRANGE* LPDIPROPRANGE
 TYPEDEF: DIPROPRANGE* LPCDIPROPRANGE
-C-STRUCT: DIPROPCAL
+STRUCT: DIPROPCAL
-    { "DIPROPHEADER" "diph" }
+    { diph DIPROPHEADER }
-    { "LONG" "lMin" }
+    { lMin LONG }
-    { "LONG" "lCenter" }
+    { lCenter LONG }
-    { "LONG" "lMax" } ;
+    { lMax LONG } ;
 TYPEDEF: DIPROPCAL* LPDIPROPCAL
 TYPEDEF: DIPROPCAL* LPCDIPROPCAL
-C-STRUCT: DIPROPGUIDANDPATH
+STRUCT: DIPROPGUIDANDPATH
-    { "DIPROPHEADER" "diph" }
+    { diph DIPROPHEADER }
-    { "GUID" "guidClass" }
+    { guidClass GUID }
-    { "WCHAR[260]"   "wszPath" } ;
+    { wszPath WCHAR[260]   } ;
 TYPEDEF: DIPROPGUIDANDPATH* LPDIPROPGUIDANDPATH
 TYPEDEF: DIPROPGUIDANDPATH* LPCDIPROPGUIDANDPATH
-C-STRUCT: DIPROPSTRING
+STRUCT: DIPROPSTRING
-    { "DIPROPHEADER" "diph" }
+    { diph DIPROPHEADER }
-    { "WCHAR[260]"   "wsz" } ;
+    { wsz WCHAR[260]   } ;
 TYPEDEF: DIPROPSTRING* LPDIPROPSTRING
 TYPEDEF: DIPROPSTRING* LPCDIPROPSTRING
-C-STRUCT: CPOINT
+STRUCT: CPOINT
-    { "LONG" "lP" }
+    { lP LONG }
-    { "DWORD" "dwLog" } ;
+    { dwLog DWORD } ;
-C-STRUCT: DIPROPCPOINTS
+STRUCT: DIPROPCPOINTS
-    { "DIPROPHEADER" "diph" }
+    { diph DIPROPHEADER }
-    { "DWORD" "dwCPointsNum" }
+    { dwCPointsNum DWORD }
-    { "CPOINT[8]" "cp" } ;
+    { cp CPOINT[8] } ;
 TYPEDEF: DIPROPCPOINTS* LPDIPROPCPOINTS
 TYPEDEF: DIPROPCPOINTS* LPCDIPROPCPOINTS
-C-STRUCT: DIENVELOPE
+STRUCT: DIENVELOPE
-    { "DWORD" "dwSize" }
+    { dwSize DWORD }
-    { "DWORD" "dwAttackLevel" }
+    { dwAttackLevel DWORD }
-    { "DWORD" "dwAttackTime" }
+    { dwAttackTime DWORD }
-    { "DWORD" "dwFadeLevel" }
+    { dwFadeLevel DWORD }
-    { "DWORD" "dwFadeTime" } ;
+    { dwFadeTime DWORD } ;
 TYPEDEF: DIENVELOPE* LPDIENVELOPE
 TYPEDEF: DIENVELOPE* LPCDIENVELOPE
-C-STRUCT: DIEFFECT
+STRUCT: DIEFFECT
-    { "DWORD" "dwSize" }
+    { dwSize DWORD }
-    { "DWORD" "dwFlags" }
+    { dwFlags DWORD }
-    { "DWORD" "dwDuration" }
+    { dwDuration DWORD }
-    { "DWORD" "dwSamplePeriod" }
+    { dwSamplePeriod DWORD }
-    { "DWORD" "dwGain" }
+    { dwGain DWORD }
-    { "DWORD" "dwTriggerButton" }
+    { dwTriggerButton DWORD }
-    { "DWORD" "dwTriggerRepeatInterval" }
+    { dwTriggerRepeatInterval DWORD }
-    { "DWORD" "cAxes" }
+    { cAxes DWORD }
-    { "LPDWORD" "rgdwAxes" }
+    { rgdwAxes LPDWORD }
-    { "LPLONG" "rglDirection" }
+    { rglDirection LPLONG }
-    { "LPDIENVELOPE" "lpEnvelope" }
+    { lpEnvelope LPDIENVELOPE }
-    { "DWORD" "cbTypeSpecificParams" }
+    { cbTypeSpecificParams DWORD }
-    { "LPVOID" "lpvTypeSpecificParams" }
+    { lpvTypeSpecificParams LPVOID }
-    { "DWORD" "dwStartDelay" } ;
+    { dwStartDelay DWORD } ;
 TYPEDEF: DIEFFECT* LPDIEFFECT
 TYPEDEF: DIEFFECT* LPCDIEFFECT
-C-STRUCT: DIEFFECTINFOW
+STRUCT: DIEFFECTINFOW
-    { "DWORD"      "dwSize" }
+    { dwSize          DWORD      }
-    { "GUID"       "guid" }
+    { guid            GUID       }
-    { "DWORD"      "dwEffType" }
+    { dwEffType       DWORD      }
-    { "DWORD"      "dwStaticParams" }
+    { dwStaticParams  DWORD      }
-    { "DWORD"      "dwDynamicParams" }
+    { dwDynamicParams DWORD      }
-    { "WCHAR[260]" "tszName" } ;
+    { tszName         WCHAR[260] } ;
 TYPEDEF: DIEFFECTINFOW* LPDIEFFECTINFOW
 TYPEDEF: DIEFFECTINFOW* LPCDIEFFECTINFOW
-C-STRUCT: DIEFFESCAPE
+STRUCT: DIEFFESCAPE
-    { "DWORD"  "dwSize" }
+    { dwSize       DWORD  }
-    { "DWORD"  "dwCommand" }
+    { dwCommand    DWORD  }
-    { "LPVOID" "lpvInBuffer" }
+    { lpvInBuffer  LPVOID }
-    { "DWORD"  "cbInBuffer" }
+    { cbInBuffer   DWORD  }
-    { "LPVOID" "lpvOutBuffer" }
+    { lpvOutBuffer LPVOID }
-    { "DWORD"  "cbOutBuffer" } ;
+    { cbOutBuffer  DWORD  } ;
 TYPEDEF: DIEFFESCAPE* LPDIEFFESCAPE
 TYPEDEF: DIEFFESCAPE* LPCDIEFFESCAPE
-C-STRUCT: DIFILEEFFECT
+STRUCT: DIFILEEFFECT
-    { "DWORD"       "dwSize" }
+    { dwSize         DWORD       }
-    { "GUID"        "GuidEffect" }
+    { GuidEffect     GUID        }
-    { "LPCDIEFFECT" "lpDiEffect" }
+    { lpDiEffect     LPCDIEFFECT }
-    { "CHAR[260]"   "szFriendlyName" } ;
+    { szFriendlyName CHAR[260]   } ;
 TYPEDEF: DIFILEEFFECT* LPDIFILEEFFECT
 TYPEDEF: DIFILEEFFECT* LPCDIFILEEFFECT
-C-STRUCT: DIDEVICEIMAGEINFOW
+STRUCT: DIDEVICEIMAGEINFOW
-    { "WCHAR[260]" "tszImagePath" }
+    { tszImagePath    WCHAR[260] }
-    { "DWORD"      "dwFlags" }
+    { dwFlags         DWORD      }
-    { "DWORD"      "dwViewID" }
+    { dwViewID        DWORD      }
-    { "RECT"       "rcOverlay" }
+    { rcOverlay       RECT       }
-    { "DWORD"      "dwObjID" }
+    { dwObjID         DWORD      }
-    { "DWORD"      "dwcValidPts" }
+    { dwcValidPts     DWORD      }
-    { "POINT[5]"   "rgptCalloutLine" }
+    { rgptCalloutLine POINT[5]   }
-    { "RECT"       "rcCalloutRect" }
+    { rcCalloutRect   RECT       }
-    { "DWORD"      "dwTextAlign" } ;
+    { dwTextAlign     DWORD      } ;
 TYPEDEF: DIDEVICEIMAGEINFOW* LPDIDEVICEIMAGEINFOW
 TYPEDEF: DIDEVICEIMAGEINFOW* LPCDIDEVICEIMAGEINFOW
-C-STRUCT: DIDEVICEIMAGEINFOHEADERW
+STRUCT: DIDEVICEIMAGEINFOHEADERW
-    { "DWORD" "dwSize" }
+    { dwSize          DWORD }
-    { "DWORD" "dwSizeImageInfo" }
+    { dwSizeImageInfo DWORD }
-    { "DWORD" "dwcViews" }
+    { dwcViews        DWORD }
-    { "DWORD" "dwcButtons" }
+    { dwcButtons      DWORD }
-    { "DWORD" "dwcAxes" }
+    { dwcAxes         DWORD }
-    { "DWORD" "dwcPOVs" }
+    { dwcPOVs         DWORD }
-    { "DWORD" "dwBufferSize" }
+    { dwBufferSize    DWORD }
-    { "DWORD" "dwBufferUsed" }
+    { dwBufferUsed    DWORD }
-    { "DIDEVICEIMAGEINFOW*" "lprgImageInfoArray" } ;
+    { lprgImageInfoArray DIDEVICEIMAGEINFOW* } ;
 TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPDIDEVICEIMAGEINFOHEADERW
 TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPCDIDEVICEIMAGEINFOHEADERW
 
-C-STRUCT: DIMOUSESTATE2
+STRUCT: DIMOUSESTATE2
-    { "LONG"    "lX" }
+    { lX         LONG    }
-    { "LONG"    "lY" }
+    { lY         LONG    }
-    { "LONG"    "lZ" }
+    { lZ         LONG    }
-    { "BYTE[8]" "rgbButtons" } ;
+    { rgbButtons BYTE[8] } ;
 TYPEDEF: DIMOUSESTATE2* LPDIMOUSESTATE2
 TYPEDEF: DIMOUSESTATE2* LPCDIMOUSESTATE2
 
-C-STRUCT: DIJOYSTATE2
+STRUCT: DIJOYSTATE2
-    { "LONG"      "lX" }
+    { lX         LONG      }
-    { "LONG"      "lY" }
+    { lY         LONG      }
-    { "LONG"      "lZ" }
+    { lZ         LONG      }
-    { "LONG"      "lRx" }
+    { lRx        LONG      }
-    { "LONG"      "lRy" }
+    { lRy        LONG      }
-    { "LONG"      "lRz" }
+    { lRz        LONG      }
-    { "LONG[2]"   "rglSlider" }
+    { rglSlider  LONG[2]   }
-    { "DWORD[4]"  "rgdwPOV" }
+    { rgdwPOV    DWORD[4]  }
-    { "BYTE[128]" "rgbButtons" }
+    { rgbButtons BYTE[128] }
-    { "LONG"      "lVX" }
+    { lVX        LONG      }
-    { "LONG"      "lVY" }
+    { lVY        LONG      }
-    { "LONG"      "lVZ" }
+    { lVZ        LONG      }
-    { "LONG"      "lVRx" }
+    { lVRx       LONG      }
-    { "LONG"      "lVRy" }
+    { lVRy       LONG      }
-    { "LONG"      "lVRz" }
+    { lVRz       LONG      }
-    { "LONG[2]"   "rglVSlider" }
+    { rglVSlider LONG[2]   }
-    { "LONG"      "lAX" }
+    { lAX        LONG      }
-    { "LONG"      "lAY" }
+    { lAY        LONG      }
-    { "LONG"      "lAZ" }
+    { lAZ        LONG      }
-    { "LONG"      "lARx" }
+    { lARx       LONG      }
-    { "LONG"      "lARy" }
+    { lARy       LONG      }
-    { "LONG"      "lARz" }
+    { lARz       LONG      }
-    { "LONG[2]"   "rglASlider" }
+    { rglASlider LONG[2]   }
-    { "LONG"      "lFX" }
+    { lFX        LONG      }
-    { "LONG"      "lFY" }
+    { lFY        LONG      }
-    { "LONG"      "lFZ" }
+    { lFZ        LONG      }
-    { "LONG"      "lFRx" }
+    { lFRx       LONG      }
-    { "LONG"      "lFRy" }
+    { lFRy       LONG      }
-    { "LONG"      "lFRz" }
+    { lFRz       LONG      }
-    { "LONG[2]"   "rglFSlider" } ;
+    { rglFSlider LONG[2]   } ;
 TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2
 TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2
 

basis/windows/dragdrop-listener/dragdrop-listener.factor

@@ -1,16 +1,19 @@
-USING: windows.com windows.com.wrapper combinators
+USING: alien.strings io.encodings.utf16n windows.com
-windows.kernel32 windows.ole32 windows.shell32 kernel accessors
+windows.com.wrapper combinators windows.kernel32 windows.ole32
+windows.shell32 kernel accessors
 prettyprint namespaces ui.tools.listener ui.tools.workspace
 alien.c-types alien sequences math ;
 IN: windows.dragdrop-listener
 
+<< "WCHAR" require-c-arrays >>
+
 : filenames-from-hdrop ( hdrop -- filenames )
     dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files
     [
         2dup f 0 DragQueryFile 1 + ! get size of filename buffer
         dup "WCHAR" <c-array>
         [ swap DragQueryFile drop ] keep
-        alien>u16-string
+        utf16n alien>string
     ] with map ;
 
 : filenames-from-data-object ( data-object -- filenames )

basis/windows/errors/errors.factor

@@ -4,6 +4,8 @@ io.encodings.string io.encodings.utf16n alien.strings
 arrays literals ;
 IN: windows.errors
 
+<< "TCHAR" require-c-arrays >>
+
 CONSTANT: ERROR_SUCCESS                               0
 CONSTANT: ERROR_INVALID_FUNCTION                      1
 CONSTANT: ERROR_FILE_NOT_FOUND                        2
@@ -696,7 +698,7 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK   HEX: 000000FF
 : make-lang-id ( lang1 lang2 -- n )
     10 shift bitor ; inline
 
-<< "TCHAR" require-c-type-arrays >>
+<< "TCHAR" require-c-arrays >>
 
 ERROR: error-message-failed id ;
 :: n>win32-error-string ( id -- string )
@@ -707,7 +709,7 @@ ERROR: error-message-failed id ;
     f
     id
     LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
-    32768 [ "TCHAR" <c-type-array> ] [ ] bi
+    32768 [ "TCHAR" <c-array> ] [ ] bi
     f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
     utf16n alien>string [ blank? ] trim ;
 

basis/windows/ole32/ole32-tests.factor

@@ -1,5 +1,6 @@
 USING: kernel tools.test windows.ole32 alien.c-types
-classes.struct specialized-arrays.uchar windows.kernel32 ;
+classes.struct specialized-arrays.uchar windows.kernel32
+windows.com.syntax ;
 IN: windows.ole32.tests
 
 [ t ] [

basis/windows/shell32/shell32.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2006, 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings alien.syntax
-combinators io.encodings.utf16n io.files io.pathnames kernel
+classes.struct combinators io.encodings.utf16n io.files
-windows.errors windows.com windows.com.syntax windows.user32
+io.pathnames kernel windows.errors windows.com
-windows.ole32 windows specialized-arrays.ushort classes.struct ;
+windows.com.syntax windows.user32 windows.ole32 windows
+specialized-arrays.ushort ;
 IN: windows.shell32
 
 CONSTANT: CSIDL_DESKTOP HEX: 00
@@ -194,10 +195,13 @@ CONSTANT: STRRET_WSTR 0
 CONSTANT: STRRET_OFFSET 1
 CONSTANT: STRRET_CSTR 2
 
-C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
+UNION-STRUCT: STRRET-union
+    { pOleStr LPWSTR }
+    { uOffset UINT }
+    { cStr char[260] } ;
 STRUCT: STRRET
     { uType int }
-    { union STRRET-union } ;
+    { value STRRET-union } ;
 
 COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
     HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )

basis/windows/types/types.factor

@@ -330,9 +330,7 @@ STRUCT: PIXELFORMATDESCRIPTOR
     { dwDamageMask DWORD } ;
 
 : <RECT> ( loc dim -- RECT )
-    [ RECT <struct> ] 2dip
+    dupd v+ [ first2 ] bi@ RECT <struct-boa> ;
-    [ drop [ first >>left ] [ second >>top ] bi ]
-    [ v+ [ first >>right ] [ second >>bottom ] bi ] 2bi ;
 
 TYPEDEF: RECT* PRECT
 TYPEDEF: RECT* LPRECT

core/combinators/combinators-docs.factor

@@ -275,7 +275,7 @@ $nl
 "The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
 { $subsection call }
 { $subsection execute }
-"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:"
+"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
 { $subsection POSTPONE: call( }
 { $subsection POSTPONE: execute( }
 "The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
@@ -303,11 +303,25 @@ ABOUT: "combinators"
 
 HELP: call-effect
 { $values { "quot" quotation } { "effect" effect } }
-{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
+{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." }
+{ $examples
+  "The following two lines are equivalent:"
+  { $code
+    "call( a b -- c )"
+    "(( a b -- c )) call-effect"
+  }
+} ;
 
 HELP: execute-effect
 { $values { "word" word } { "effect" effect } }
-{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
+{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
+{ $examples
+  "The following two lines are equivalent:"
+  { $code
+    "execute( a b -- c )"
+    "(( a b -- c )) execute-effect"
+  }
+} ;
 
 HELP: execute-effect-unsafe
 { $values { "word" word } { "effect" effect } }

core/syntax/syntax-docs.factor

@@ -834,6 +834,14 @@ HELP: call(
 
 HELP: execute(
 { $syntax "execute( stack -- effect )" }
-{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
+{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." }
+{ $examples
+  { $code
+    "IN: scratchpad"
+    ""
+    ": eat ( -- ) ; : sleep ( -- ) ; : hack ( -- ) ;"
+    "{ eat sleep hack } [ execute( -- ) ] each"
+  }
+} ;
 
 { POSTPONE: call( POSTPONE: execute( } related-words

extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor

@@ -2,50 +2,50 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.accessors alien.c-types alien.syntax byte-arrays
 destructors generalizations hints kernel libc locals math math.order
-sequences sequences.private ;
+sequences sequences.private classes.struct accessors ;
 IN: benchmark.yuv-to-rgb
 
-C-STRUCT: yuv_buffer
+STRUCT: yuv_buffer
-    { "int" "y_width" }
+    { y_width int }
-    { "int" "y_height" }
+    { y_height int }
-    { "int" "y_stride" }
+    { y_stride int }
-    { "int" "uv_width" }
+    { uv_width int }
-    { "int" "uv_height" }
+    { uv_height int }
-    { "int" "uv_stride" }
+    { uv_stride int }
-    { "void*" "y" }
+    { y void* }
-    { "void*" "u" }
+    { u void* }
-    { "void*" "v" } ;
+    { v void* } ;
 
 :: fake-data ( -- rgb yuv )
     [let* | w [ 1600 ]
             h [ 1200 ]
-            buffer [ "yuv_buffer" <c-object> ]
+            buffer [ yuv_buffer <struct> ]
             rgb [ w h * 3 * <byte-array> ] |
-        w buffer set-yuv_buffer-y_width
-        h buffer set-yuv_buffer-y_height
-        h buffer set-yuv_buffer-uv_height
-        w buffer set-yuv_buffer-y_stride
-        w buffer set-yuv_buffer-uv_stride
-        w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y
-        w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u
-        w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v
         rgb buffer
+            w >>y_width
+            h >>y_height
+            h >>uv_height
+            w >>y_stride
+            w >>uv_stride
+            w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
+            w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
+            w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v
     ] ;
 
 : clamp ( n -- n )
     255 min 0 max ; inline
 
 : stride ( line yuv  -- uvy yy )
-    [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline
+    [ uv_stride>> swap 2/ * ] [ y_stride>> * ] 2bi ; inline
 
 : compute-y ( yuv uvy yy x -- y )
-    + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
+    + >fixnum nip swap y>> swap alien-unsigned-1 16 - ; inline
 
 : compute-v ( yuv uvy yy x -- v )
-    nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline
+    nip 2/ + >fixnum swap u>> swap alien-unsigned-1 128 - ; inline
 
 : compute-u ( yuv uvy yy x -- v )
-    nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline
+    nip 2/ + >fixnum swap v>> swap alien-unsigned-1 128 - ; inline
 
 :: compute-yuv ( yuv uvy yy x -- y u v )
     yuv uvy yy x compute-y
@@ -77,16 +77,16 @@ C-STRUCT: yuv_buffer
 
 : yuv>rgb-row ( index rgb yuv y -- index )
     over stride
-    pick yuv_buffer-y_width
+    pick y_width>>
     [ yuv>rgb-pixel ] with with with with each ; inline
 
 : yuv>rgb ( rgb yuv -- )
     [ 0 ] 2dip
-    dup yuv_buffer-y_height
+    dup y_height>>
     [ yuv>rgb-row ] with with each
     drop ;
 
-HINTS: yuv>rgb byte-array byte-array ;
+HINTS: yuv>rgb byte-array yuv_buffer ;
 
 : yuv>rgb-benchmark ( -- )
     [ fake-data yuv>rgb ] with-destructors ;

extra/gpu/demos/bunny/bunny.factor

@@ -1,11 +1,11 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors alien.c-types arrays combinators combinators.short-circuit
+USING: accessors alien.c-types arrays classes.struct combinators
-game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
+combinators.short-circuit game-worlds gpu gpu.buffers gpu.util.wasd
-gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
+gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util
-images.loader io io.encodings.ascii io.files io.files.temp
+grouping http.client images images.loader io io.encodings.ascii io.files
-kernel math math.matrices math.parser math.vectors
+io.files.temp kernel math math.matrices math.parser math.vectors
-method-chains sequences specialized-arrays.float specialized-vectors.uint splitting
+method-chains sequences specialized-arrays.float specialized-vectors.uint
-struct-vectors threads ui ui.gadgets ui.gadgets.worlds
+splitting struct-vectors threads ui ui.gadgets ui.gadgets.worlds
 ui.pixel-formats ;
 IN: gpu.demos.bunny
 
@@ -73,9 +73,8 @@ UNIFORM-TUPLE: loading-uniforms
     " " split [ string>number ] map sift ;
 
 : <bunny-vertex> ( vertex -- struct )
-    >float-array
+    bunny-vertex-struct <struct>
-    "bunny-vertex-struct" <c-object>
+        swap >float-array >>vertex ; inline
-    [ set-bunny-vertex-struct-vertex ] keep ;
 
 : (parse-bunny-model) ( vs is -- vs is )
     readln [
@@ -87,7 +86,7 @@ UNIFORM-TUPLE: loading-uniforms
     ] when* ;
 
 : parse-bunny-model ( -- vertexes indexes )
-    100000 "bunny-vertex-struct" <struct-vector>
+    100000 bunny-vertex-struct <struct-vector>
     100000 <uint-vector>
     (parse-bunny-model) ;
 
@@ -98,23 +97,15 @@ UNIFORM-TUPLE: loading-uniforms
 
 : calc-bunny-normal ( vertexes indexes -- )
     swap
-    [ [ nth bunny-vertex-struct-vertex ] curry { } map-as normal ]
+    [ [ nth vertex>> ] curry { } map-as normal ]
-    [
+    [ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ;
-        [
-            nth [ bunny-vertex-struct-normal v+ ] keep
-            set-bunny-vertex-struct-normal
-        ] curry with each
-    ] 2bi ;
 
 : calc-bunny-normals ( vertexes indexes -- )
     3 <groups>
     [ calc-bunny-normal ] with each ;
 
 : normalize-bunny-normals ( vertexes -- )
-    [
+    [ [ normalize ] change-normal drop ] each ;
-        [ bunny-vertex-struct-normal normalize ] keep
-        set-bunny-vertex-struct-normal
-    ] each ;
 
 : bunny-data ( filename -- vertexes indexes )
     ascii [ parse-bunny-model ] with-file-reader

extra/gpu/shaders/shaders-docs.factor

@@ -1,5 +1,5 @@
 ! (c)2009 Joe Groff bsd license
-USING: alien.syntax classes gpu.buffers help.markup help.syntax
+USING: classes classes.struct gpu.buffers help.markup help.syntax
 images kernel math multiline quotations sequences strings ;
 IN: gpu.shaders
 
@@ -51,7 +51,7 @@ HELP: VERTEX-FORMAT:
 
 HELP: VERTEX-STRUCT:
 { $syntax <" VERTEX-STRUCT: struct-name format-name "> }
-{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
+{ $description "Defines a struct class (like " { $link POSTPONE: STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
 
 { POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
 

extra/gpu/shaders/shaders.factor

@@ -1,7 +1,7 @@
 ! (c)2009 Joe Groff bsd license
 USING: accessors alien alien.c-types alien.strings
-alien.structs arrays assocs byte-arrays classes.mixin
+arrays assocs byte-arrays classes.mixin classes.parser
-classes.parser classes.singleton combinators
+classes.singleton classes.struct combinators
 combinators.short-circuit definitions destructors
 generic.parser gpu gpu.buffers hashtables images
 io.encodings.ascii io.files io.pathnames kernel lexer literals
@@ -238,8 +238,8 @@ M: f (verify-feedback-format)
         { uint-integer-components [ "uint" ] }
     } case ;
 
-: c-array-dim ( dim -- string )
+: c-array-dim ( type dim -- type' )
-    dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
+    dup 1 = [ drop ] [ 2array ] if ;
 
 SYMBOL: padding-no
 padding-no [ 0 ] initialize
@@ -250,11 +250,10 @@ padding-no [ 0 ] initialize
     "(" ")" surround
     padding-no inc ;
 
-: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
+: vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
-    [
+    [ name>> [ padding-name ] unless* ]
-        [ component-type>> component-type>c-type ]
+    [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
-        [ dim>> c-array-dim ] bi append
+    { } <struct-slot-spec> ;
-    ] [ name>> [ padding-name ] unless* ] bi 2array ;
 
 : shader-filename ( shader/program -- filename )
     dup filename>> [ nip ] [ name>> where first ] if* file-name ;
@@ -303,13 +302,12 @@ SYNTAX: VERTEX-FORMAT:
     [ first4 vertex-attribute boa ] map
     define-vertex-format ;
 
-: define-vertex-struct ( struct-name vertex-format -- )
+: define-vertex-struct ( class vertex-format -- )
-    [ current-vocab ] dip
+    "vertex-format-attributes" word-prop [ vertex-attribute>struct-slot ] map
-    "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
+    define-struct-class ;
-    define-struct ;
 
 SYNTAX: VERTEX-STRUCT:
-    scan scan-word define-vertex-struct ;
+    CREATE-CLASS scan-word define-vertex-struct ;
 
 TUPLE: vertex-array < gpu-object
     { program-instance program-instance read-only }

extra/system-info/linux/linux.factor

@@ -1,14 +1,15 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: unix alien alien.c-types kernel math sequences strings
-io.backend.unix splitting io.encodings.utf8 io.encodings.string ;
+io.backend.unix splitting io.encodings.utf8 io.encodings.string
+specialized-arrays.char ;
 IN: system-info.linux
 
 : (uname) ( buf -- int )
     "int" f "uname" { "char*" } alien-invoke ;
 
 : uname ( -- seq )
-    65536 "char" <c-array> [ (uname) io-error ] keep
+    65536 <char-array> [ (uname) io-error ] keep
     "\0" split harvest [ utf8 decode ] map
     6 "" pad-tail ;
 

extra/system-info/windows/windows.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types classes.struct accessors kernel
 math namespaces windows windows.kernel32 windows.advapi32 words
 combinators vocabs.loader system-info.backend system
-alien.strings windows.errors ;
+alien.strings windows.errors specialized-arrays.ushort ;
 IN: system-info.windows
 
 : system-info ( -- SYSTEM_INFO )
@@ -49,11 +49,8 @@ IN: system-info.windows
 : sse3? ( -- ? )
     PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
 
-: <u16-string-object> ( n -- obj )
-    "ushort" <c-array> ;
-
 : get-directory ( word -- str )
-    [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
+    [ MAX_UNICODE_PATH [ <ushort-array> ] keep dupd ] dip
     execute win32-error=0/f alien>native-string ; inline
 
 : windows-directory ( -- str )