steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2011-08-25 21:02:13 -07:00
parent 7432797251
commit 01eeabbcbd
10 changed files with 103 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
basis/classes/struct/authors.txt
View File

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

21
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -1,17 +1,22 @@
! (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 ;

13
basis/classes/struct/struct-docs.factor
View File

@ -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: } ;

41
basis/classes/struct/struct-tests.factor
View File

@ -1,11 +1,13 @@
! (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 ;
@ -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

52
basis/classes/struct/struct.factor
View File

@ -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 )
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
@ -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,28 +275,41 @@ 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 -- )
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 ;
@ -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:

1
extra/classes/struct/packed/authors.txt
View File

@ -1 +0,0 @@
John Benediktsson

17
extra/classes/struct/packed/packed-tests.factor
View File

@ -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

50
extra/classes/struct/packed/packed.factor
View File

@ -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 ;

1
extra/classes/struct/packed/summary.txt
View File

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

4
extra/io/files/trash/windows/windows.factor
View File

@ -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
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