Merge classes.struct.packed into classes.struct and remove duplication

basis/classes/struct/authors.txt

@@ -1 +1,4 @@
 Joe Groff
+Daniel Ehrenberg
+John Benediktsson
+Slava Pestov

basis/classes/struct/prettyprint/prettyprint.factor

@@ -1,17 +1,22 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
+USING: accessors alien alien.c-types alien.data
-assocs classes classes.struct combinators combinators.short-circuit
+alien.prettyprint arrays assocs classes classes.struct
-continuations fry kernel libc make math math.parser mirrors
+combinators combinators.short-circuit continuations fry kernel
-prettyprint.backend prettyprint.custom prettyprint.sections
+libc make math math.parser mirrors prettyprint.backend
-see.private sequences slots strings summary words ;
+prettyprint.custom prettyprint.sections see.private sequences
+slots strings summary words ;
 IN: classes.struct.prettyprint
 
 <PRIVATE
 
 : struct-definer-word ( class -- word )
-    struct-slots dup length 2 >=
+    struct-slots
-    [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+    {
-    [ drop \ STRUCT: ] if ;
+        { [ dup length 1 <= ] [ drop \ STRUCT: ] }
+        { [ dup [ offset>> 0 = ] all? ] [ drop \ UNION-STRUCT: ] }
+        { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] }
+        [ drop \ STRUCT: ]
+    } cond ;
 
 : struct>assoc ( struct -- assoc )
     [ class struct-slots ] [ struct-slot-values ] bi zip ;

basis/classes/struct/struct-docs.factor

@@ -55,12 +55,23 @@ HELP: UNION-STRUCT:
 { $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
 { $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
 
+HELP: PACKED-STRUCT:
+{ $syntax "PACKED-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type with no alignment padding between slots or at the end. In all other respects, behaves like " { $link POSTPONE: STRUCT: } "." } ;
+
 HELP: define-struct-class
 { $values
     { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
 }
 { $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
 
+HELP: define-packed-struct-class
+{ $values
+    { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: PACKED-STRUCT: } " syntax." } ;
+
 HELP: define-union-struct-class
 { $values
     { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
@@ -121,7 +132,7 @@ ARTICLE: "classes.struct.examples" "Struct class examples"
 
 ARTICLE: "classes.struct.define" "Defining struct classes"
 "Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:"
-{ $subsections POSTPONE: STRUCT: }
+{ $subsections POSTPONE: STRUCT: POSTPONE: PACKED-STRUCT: }
 "Union structs are also supported, which behave like structs but share the same memory for all the slots."
 { $subsections POSTPONE: UNION-STRUCT: } ;
 

basis/classes/struct/struct-tests.factor

@@ -1,11 +1,13 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.syntax ascii
+USING: accessors alien alien.c-types alien.data alien.syntax
-assocs byte-arrays classes.struct classes.tuple.parser
+ascii assocs byte-arrays classes.struct
-classes.tuple.private classes.tuple combinators compiler.tree.debugger
+classes.struct.prettyprint classes.struct.prettyprint.private
-compiler.units delegate destructors io.encodings.utf8 io.pathnames
+classes.tuple.parser classes.tuple.private classes.tuple
-io.streams.string kernel libc literals math mirrors namespaces
+combinators compiler.tree.debugger compiler.units delegate
-prettyprint prettyprint.config see sequences specialized-arrays
+destructors io.encodings.utf8 io.pathnames io.streams.string
-system tools.test parser lexer eval layouts generic.single classes
+kernel libc literals math mirrors namespaces prettyprint
+prettyprint.config see sequences specialized-arrays system
+tools.test parser lexer eval layouts generic.single classes
 vocabs ;
 FROM: math => float ;
 FROM: specialized-arrays.private => specialized-array-vocab ;
@@ -131,6 +133,9 @@ STRUCT: struct-test-bar
     [ make-mirror clear-assoc ] keep
 ] unit-test
 
+[ POSTPONE: STRUCT: ]
+[ struct-test-foo struct-definer-word ] unit-test
+
 UNION-STRUCT: struct-test-float-and-bits
     { f c:float }
     { bits uint } ;
@@ -140,6 +145,9 @@ UNION-STRUCT: struct-test-float-and-bits
 
 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 
+[ POSTPONE: UNION-STRUCT: ]
+[ struct-test-float-and-bits struct-definer-word ] unit-test
+
 STRUCT: struct-test-string-ptr
     { x c-string } ;
 
@@ -487,3 +495,22 @@ SPECIALIZED-ARRAY: void*
 STRUCT: silly-array-field-test { x int*[3] } ;
 
 [ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
+
+! Packed structs
+PACKED-STRUCT: packed-struct-test
+    { d c:int }
+    { e c:short }
+    { f c:int }
+    { g c:char }
+    { h c:int } ;
+
+[ 15 ] [ packed-struct-test heap-size ] unit-test
+
+[ 0 ] [ "d" packed-struct-test offset-of ] unit-test
+[ 4 ] [ "e" packed-struct-test offset-of ] unit-test
+[ 6 ] [ "f" packed-struct-test offset-of ] unit-test
+[ 10 ] [ "g" packed-struct-test offset-of ] unit-test
+[ 11 ] [ "h" packed-struct-test offset-of ] unit-test
+
+[ POSTPONE: PACKED-STRUCT: ]
+[ packed-struct-test struct-definer-word ] unit-test

basis/classes/struct/struct.factor

@@ -1,4 +1,6 @@
-! (c)Joe Groff, Daniel Ehrenberg bsd license
+! Copyright (C) 2010, 2011 Joe Groff, Daniel Ehrenberg,
+! John Benediktsson, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
 USING: accessors alien alien.c-types alien.data alien.parser
 arrays byte-arrays classes classes.private classes.parser
 classes.tuple classes.tuple.parser classes.tuple.private
@@ -24,8 +26,11 @@ M: struct-must-have-slots summary
 TUPLE: struct
     { (underlying) c-ptr read-only } ;
 
+! We hijack the core slots vocab's slot-spec type for struct
+! fields. Note that 'offset' is in bits, not bytes, to support
+! bitfields.
 TUPLE: struct-slot-spec < slot-spec
-    type ;
+    type packed? ;
 
 ! For a struct-bit-slot-spec, offset is in bits, not bytes
 TUPLE: struct-bit-slot-spec < struct-slot-spec
@@ -213,11 +218,14 @@ M: struct-c-type base-type ;
 
 GENERIC: compute-slot-offset ( offset class -- offset' )
 
-: c-type-align-at ( class offset -- n )
+: c-type-align-at ( slot-spec offset -- n )
-    0 = [ c-type-align-first ] [ c-type-align ] if ;
+    over packed?>> [ 2drop 1 ] [
+        [ type>> ] dip
+        0 = [ c-type-align-first ] [ c-type-align ] if
+    ] if ;
 
 M: struct-slot-spec compute-slot-offset
-    [ type>> over c-type-align-at 8 * align ] keep
+    [ over c-type-align-at 8 * align ] keep
     [ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
 
 M: struct-bit-slot-spec compute-slot-offset
@@ -231,7 +239,7 @@ M: struct-bit-slot-spec compute-slot-offset
 
 : struct-alignment ( slots -- align )
     [ struct-bit-slot-spec? not ] filter
-    1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
+    1 [ dup offset>> c-type-align-at max ] reduce ;
 
 PRIVATE>
 
@@ -267,12 +275,12 @@ M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
 : redefine-struct-tuple-class ( class -- )
     [ struct f define-tuple-class ] [ make-final ] bi ;
 
-:: (define-struct-class) ( class slots offsets-quot -- )
+:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- )
-    slots empty? [ struct-must-have-slots ] when
+    slot-specs check-struct-slots
+    slot-specs empty? [ struct-must-have-slots ] when
     class redefine-struct-tuple-class
-    slots make-slots dup check-struct-slots :> slot-specs
     slot-specs offsets-quot call :> unaligned-size
-    slot-specs struct-alignment :> alignment
+    slot-specs alignment-quot call :> alignment
     unaligned-size alignment align :> size
 
     class slot-specs size alignment c-type-for-class :> c-type
@@ -282,13 +290,26 @@ M: struct binary-zero? binary-object <direct-uchar-array> [ 0 = ] all? ; inline
     class size "struct-size" set-word-prop
     class dup make-struct-prototype "prototype" set-word-prop
     class (struct-methods) ; inline
+
+: make-packed-slots ( slots -- slot-specs )
+    make-slots [ t >>packed? ] map! ;
+
 PRIVATE>
 
 : define-struct-class ( class slots -- )
-    [ compute-struct-offsets ] (define-struct-class) ;
+    make-slots
+    [ compute-struct-offsets ] [ struct-alignment ]
+    (define-struct-class) ;
+
+: define-packed-struct-class ( class slots -- )
+    make-packed-slots
+    [ compute-struct-offsets ] [ drop 1 ]
+    (define-struct-class) ;
 
 : define-union-struct-class ( class slots -- )
-    [ compute-union-offsets ] (define-struct-class) ;
+    make-slots
+    [ compute-union-offsets ] [ struct-alignment ]
+    (define-struct-class) ;
 
 ERROR: invalid-struct-slot token ;
 
@@ -352,6 +373,10 @@ PRIVATE>
 
 SYNTAX: STRUCT:
     parse-struct-definition define-struct-class ;
+
+SYNTAX: PACKED-STRUCT:
+    parse-struct-definition define-packed-struct-class ;
+
 SYNTAX: UNION-STRUCT:
     parse-struct-definition define-union-struct-class ;
 
@@ -377,6 +402,7 @@ SYNTAX: S@
         { "{" [ parse-struct-slot` t ] }
         [ invalid-struct-slot ]
     } case ;
+
 PRIVATE>
 
 FUNCTOR-SYNTAX: STRUCT:

extra/classes/struct/packed/authors.txt

@@ -1 +0,0 @@
-John Benediktsson

extra/classes/struct/packed/packed-tests.factor

@@ -1,17 +0,0 @@
-
-USING: alien.c-types classes.struct.packed tools.test words ;
-
-IN: classes.struct.packed
-
-PACKED-STRUCT: abcd
-    { a int }
-    { b int }
-    { c int }
-    { d int }
-    { e short }
-    { f int }
-    { g int }
-    { h int }
-;
-
-[ 30 ] [ \ abcd "struct-size" word-prop ] unit-test

extra/classes/struct/packed/packed.factor

@@ -1,50 +0,0 @@
-! Copyright (C) 2011 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors alien.c-types classes.struct
-classes.struct.private kernel locals math sequences slots
-words ;
-
-IN: classes.struct.packed
-
-<PRIVATE
-
-CONSTANT: ALIGNMENT 1
-
-GENERIC: compute-packed-offset ( offset class -- offset' )
-
-M: struct-slot-spec compute-packed-offset
-    [ ALIGNMENT 8 * align ] dip
-    [ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
-
-M: struct-bit-slot-spec compute-packed-offset
-    [ offset<< ] [ bits>> + ] 2bi ;
-
-: compute-packed-offsets ( slots -- size )
-    0 [ compute-packed-offset ] reduce 8 align 8 /i ;
-
-:: (define-packed-class) ( class slots offsets-quot -- )
-    slots empty? [ struct-must-have-slots ] when
-    class redefine-struct-tuple-class
-    slots make-slots dup check-struct-slots :> slot-specs
-    slot-specs offsets-quot call :> unaligned-size
-    ALIGNMENT :> alignment
-    unaligned-size :> size
-
-    class  slot-specs  size  alignment  c-type-for-class :> c-type
-
-    c-type class typedef
-    class slot-specs define-accessors
-    class size "struct-size" set-word-prop
-    class dup make-struct-prototype "prototype" set-word-prop
-    class (struct-methods) ; inline
-
-: define-packed-struct-class ( class slots -- )
-    [ compute-packed-offsets ] (define-packed-class) ;
-
-PRIVATE>
-
-SYNTAX: PACKED-STRUCT:
-    parse-struct-definition define-packed-struct-class ;
-
-

extra/classes/struct/packed/summary.txt

@@ -1 +0,0 @@
-Support for packed structures

extra/io/files/trash/windows/windows.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license
 
 USING: accessors alien.c-types alien.data alien.strings
-alien.syntax classes.struct classes.struct.packed destructors
+alien.syntax classes.struct destructors kernel
-kernel io.encodings.utf16n io.files.trash libc math sequences system
+io.encodings.utf16n io.files.trash libc math sequences system
 windows.types ;
 
 IN: io.files.trash.windows