From 01eeabbcbd68c1e3511bc2e8846362985cde39ff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 25 Aug 2011 21:02:13 -0700 Subject: [PATCH] Merge classes.struct.packed into classes.struct and remove duplication --- basis/classes/struct/authors.txt | 3 ++ .../struct/prettyprint/prettyprint.factor | 21 +++++--- basis/classes/struct/struct-docs.factor | 13 ++++- basis/classes/struct/struct-tests.factor | 41 ++++++++++++--- basis/classes/struct/struct.factor | 52 ++++++++++++++----- extra/classes/struct/packed/authors.txt | 1 - .../classes/struct/packed/packed-tests.factor | 17 ------ extra/classes/struct/packed/packed.factor | 50 ------------------ extra/classes/struct/packed/summary.txt | 1 - extra/io/files/trash/windows/windows.factor | 4 +- 10 files changed, 103 insertions(+), 100 deletions(-) delete mode 100644 extra/classes/struct/packed/authors.txt delete mode 100644 extra/classes/struct/packed/packed-tests.factor delete mode 100644 extra/classes/struct/packed/packed.factor delete mode 100644 extra/classes/struct/packed/summary.txt diff --git a/basis/classes/struct/authors.txt b/basis/classes/struct/authors.txt index f13c9c1e77..b1b0eae445 100644 --- a/basis/classes/struct/authors.txt +++ b/basis/classes/struct/authors.txt @@ -1 +1,4 @@ Joe Groff +Daniel Ehrenberg +John Benediktsson +Slava Pestov diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index b7b51432dd..57b6b4fca5 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/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 -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 = - [ 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 ; diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 68a4876f92..13ac16a7bb 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/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: } ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 4bc567ce8b..46970c86f7 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/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 -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 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 diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 15a7b72c6c..c00746865b 100644 --- a/basis/classes/struct/struct.factor +++ b/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 ) - 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 [ 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: diff --git a/extra/classes/struct/packed/authors.txt b/extra/classes/struct/packed/authors.txt deleted file mode 100644 index e091bb8164..0000000000 --- a/extra/classes/struct/packed/authors.txt +++ /dev/null @@ -1 +0,0 @@ -John Benediktsson diff --git a/extra/classes/struct/packed/packed-tests.factor b/extra/classes/struct/packed/packed-tests.factor deleted file mode 100644 index 4ff264265e..0000000000 --- a/extra/classes/struct/packed/packed-tests.factor +++ /dev/null @@ -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 diff --git a/extra/classes/struct/packed/packed.factor b/extra/classes/struct/packed/packed.factor deleted file mode 100644 index 2f2b1ac8d8..0000000000 --- a/extra/classes/struct/packed/packed.factor +++ /dev/null @@ -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 - -> 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 ; - - diff --git a/extra/classes/struct/packed/summary.txt b/extra/classes/struct/packed/summary.txt deleted file mode 100644 index 29f80ee9e1..0000000000 --- a/extra/classes/struct/packed/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Support for packed structures diff --git a/extra/io/files/trash/windows/windows.factor b/extra/io/files/trash/windows/windows.factor index d0cf039296..ce14cfa6c2 100644 --- a/extra/io/files/trash/windows/windows.factor +++ b/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 -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