Joe Groff
+Daniel Ehrenberg
+John Benediktsson
+Slava Pestov
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
-assocs classes classes.struct combinators combinators.short-circuit
-continuations fry kernel libc make math math.parser mirrors
-prettyprint.backend prettyprint.custom prettyprint.sections
-see.private sequences slots strings summary words ;
+USING: accessors alien alien.c-types alien.data
+alien.prettyprint arrays assocs classes classes.struct
+combinators combinators.short-circuit continuations fry kernel
+libc make math math.parser mirrors prettyprint.backend
+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 >=
- [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
- [ drop \ STRUCT: ] if ;
+ struct-slots
+ {
+ { [ 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 ;
{ $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" }
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: } ;
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.syntax ascii
-assocs byte-arrays classes.struct classes.tuple.parser
-classes.tuple.private classes.tuple combinators compiler.tree.debugger
-compiler.units delegate destructors io.encodings.utf8 io.pathnames
-io.streams.string kernel libc literals math mirrors namespaces
-prettyprint prettyprint.config see sequences specialized-arrays
-system tools.test parser lexer eval layouts generic.single classes
+USING: accessors alien alien.c-types alien.data alien.syntax
+ascii assocs byte-arrays classes.struct
+classes.struct.prettyprint classes.struct.prettyprint.private
+classes.tuple.parser classes.tuple.private classes.tuple
+combinators compiler.tree.debugger compiler.units delegate
+destructors io.encodings.utf8 io.pathnames io.streams.string
+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 ;
[ 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 } ;
[ 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 } ;
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
-! (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
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
GENERIC: compute-slot-offset ( offset class -- offset' )
-: c-type-align-at ( class offset -- n )
- 0 = [ c-type-align-first ] [ c-type-align ] if ;
+: c-type-align-at ( slot-spec offset -- n )
+ 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
: 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>
: redefine-struct-tuple-class ( class -- )
[ struct f define-tuple-class ] [ make-final ] bi ;
-:: (define-struct-class) ( class slots offsets-quot -- )
- slots empty? [ struct-must-have-slots ] when
+:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- )
+ 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
+ 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
+
+: 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 ;
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 ;
{ "{" [ parse-struct-slot` t ] }
[ invalid-struct-slot ]
} case ;
+
PRIVATE>
FUNCTOR-SYNTAX: STRUCT:
+++ /dev/null
-John Benediktsson
+++ /dev/null
-
-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
+++ /dev/null
-! 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 ;
-
-
+++ /dev/null
-Support for packed structures
! 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
-kernel io.encodings.utf16n io.files.trash libc math sequences system
+alien.syntax classes.struct destructors kernel
+io.encodings.utf16n io.files.trash libc math sequences system
windows.types ;
IN: io.files.trash.windows
projects / factor.git / commitdiff