From 56ca6ceeefb7c11e82cee77528eb891884d79e31 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 13:03:43 -0500 Subject: [PATCH] classes.c-types is kinda half-baked. get rid of it, and make classes.struct parse c types directly --- extra/classes/c-types/c-types-docs.factor | 86 ------------ extra/classes/c-types/c-types.factor | 127 ------------------ .../struct/prettyprint/prettyprint.factor | 18 ++- extra/classes/struct/struct-docs.factor | 2 +- extra/classes/struct/struct-tests.factor | 41 ++++-- extra/classes/struct/struct.factor | 59 +++++--- 6 files changed, 83 insertions(+), 250 deletions(-) delete mode 100644 extra/classes/c-types/c-types-docs.factor delete mode 100644 extra/classes/c-types/c-types.factor diff --git a/extra/classes/c-types/c-types-docs.factor b/extra/classes/c-types/c-types-docs.factor deleted file mode 100644 index df21db0104..0000000000 --- a/extra/classes/c-types/c-types-docs.factor +++ /dev/null @@ -1,86 +0,0 @@ -! (c)Joe Groff bsd license -USING: alien arrays classes help.markup help.syntax kernel -specialized-arrays.direct ; -QUALIFIED: math -IN: classes.c-types - -HELP: c-type-class -{ $class-description "This metaclass encompasses the " { $link "classes.c-types" } "." } ; - -HELP: char -{ $class-description "A signed one-byte integer quantity." } ; - -HELP: direct-array-of -{ $values - { "alien" c-ptr } { "len" math:integer } { "class" c-type-class } - { "array" "a direct array" } -} -{ $description "Constructs one of the " { $link "specialized-arrays.direct" } " over " { $snippet "len" } " elements of type " { $snippet "class" } " located at the referenced location in raw memory." } ; - -HELP: int -{ $class-description "A signed four-byte integer quantity." } ; - -HELP: long -{ $class-description "A signed integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ; - -HELP: longlong -{ $class-description "A signed eight-byte integer quantity." } ; - -HELP: short -{ $class-description "A signed two-byte integer quantity." } ; - -HELP: complex-float -{ $class-description "A single-precision complex floating point quantity." } ; - -HELP: complex-double -{ $class-description "A double-precision complex floating point quantity. This is an alias for the Factor " { $link math:complex } " type." } ; - -HELP: float -{ $class-description "A single-precision floating point quantity." } ; - -HELP: double -{ $class-description "A double-precision floating point quantity. This is an alias for the Factor " { $link math:float } " type." } ; - -HELP: uchar -{ $class-description "An unsigned one-byte integer quantity." } ; - -HELP: uint -{ $class-description "An unsigned four-byte integer quantity." } ; - -HELP: ulong -{ $class-description "An unsigned integer quantity. On 64-bit Unix platforms, this is an eight-byte type; on Windows and on 32-bit Unix platforms, it is four bytes." } ; - -HELP: ulonglong -{ $class-description "An unsigned eight-byte integer quantity." } ; - -HELP: ushort -{ $class-description "An unsigned two-byte integer quantity." } ; - -HELP: bool -{ $class-description "A boolean value. This is an alias to the Factor " { $link boolean } " class." } ; - -HELP: void* -{ $class-description "A pointer to raw C memory. This is an alias to the Factor " { $link pinned-c-ptr } " class." } ; - -ARTICLE: "classes.c-types" "C type classes" -"The " { $vocab-link "classes.c-types" } " vocabulary defines Factor classes that correspond to C types in the FFI." -{ $subsection char } -{ $subsection uchar } -{ $subsection short } -{ $subsection ushort } -{ $subsection int } -{ $subsection uint } -{ $subsection long } -{ $subsection ulong } -{ $subsection longlong } -{ $subsection ulonglong } -{ $subsection float } -{ $subsection double } -{ $subsection complex-float } -{ $subsection complex-double } -{ $subsection bool } -{ $subsection void* } -"The vocabulary also provides a word for constructing " { $link "specialized-arrays.direct" } " of C types over raw memory:" -{ $subsection direct-array-of } ; - -ABOUT: "classes.c-types" diff --git a/extra/classes/c-types/c-types.factor b/extra/classes/c-types/c-types.factor deleted file mode 100644 index 97cf20d4fc..0000000000 --- a/extra/classes/c-types/c-types.factor +++ /dev/null @@ -1,127 +0,0 @@ -! (c)Joe Groff bsd license -USING: alien alien.c-types classes classes.predicate kernel -math.bitwise math.order namespaces sequences words -specialized-arrays.direct.alien -specialized-arrays.direct.bool -specialized-arrays.direct.char -specialized-arrays.direct.complex-double -specialized-arrays.direct.complex-float -specialized-arrays.direct.double -specialized-arrays.direct.float -specialized-arrays.direct.int -specialized-arrays.direct.long -specialized-arrays.direct.longlong -specialized-arrays.direct.short -specialized-arrays.direct.uchar -specialized-arrays.direct.uint -specialized-arrays.direct.ulong -specialized-arrays.direct.ulonglong -specialized-arrays.direct.ushort ; -QUALIFIED: math -IN: classes.c-types - -PREDICATE: char < math:fixnum - HEX: -80 HEX: 7f between? ; - -PREDICATE: uchar < math:fixnum - HEX: 0 HEX: ff between? ; - -PREDICATE: short < math:fixnum - HEX: -8000 HEX: 7fff between? ; - -PREDICATE: ushort < math:fixnum - HEX: 0 HEX: ffff between? ; - -PREDICATE: int < math:integer - HEX: -8000,0000 HEX: 7fff,ffff between? ; - -PREDICATE: uint < math:integer - HEX: 0 HEX: ffff,ffff between? ; - -PREDICATE: longlong < math:integer - HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ; - -PREDICATE: ulonglong < math:integer - HEX: 0 HEX: ffff,ffff,ffff,ffff between? ; - -UNION: double math:float ; -UNION: complex-double math:complex ; - -UNION: bool boolean ; -UNION: void* pinned-c-ptr ; - -UNION: float math:float ; -UNION: complex-float math:complex ; - -SYMBOLS: long ulong long-bits ; - -<< - "long" heap-size 8 = - [ - \ long math:integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class - \ ulong math:integer [ HEX: 0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class - 64 \ long-bits set-global - ] [ - \ long math:integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class - \ ulong math:integer [ HEX: 0 HEX: ffff,ffff between? ] define-predicate-class - 32 \ long-bits set-global - ] if ->> - -: set-class-c-type ( class initial c-type -- ) - [ "initial-value" set-word-prop ] - [ c-type "class-c-type" set-word-prop ] - [ "class-direct-array" set-word-prop ] tri-curry* tri ; - -: class-c-type ( class -- c-type ) - "class-c-type" word-prop ; -: class-direct-array ( class -- ) - "class-direct-array" word-prop ; - -\ f f "void*" \ set-class-c-type -void* f "void*" \ set-class-c-type -pinned-c-ptr f "void*" \ set-class-c-type -bool f "bool" \ set-class-c-type -boolean f "bool" \ set-class-c-type -char 0 "char" \ set-class-c-type -uchar 0 "uchar" \ set-class-c-type -short 0 "short" \ set-class-c-type -ushort 0 "ushort" \ set-class-c-type -int 0 "int" \ set-class-c-type -uint 0 "uint" \ set-class-c-type -long 0 "long" \ set-class-c-type -ulong 0 "ulong" \ set-class-c-type -longlong 0 "longlong" \ set-class-c-type -ulonglong 0 "ulonglong" \ set-class-c-type -float 0.0 "float" \ set-class-c-type -double 0.0 "double" \ set-class-c-type -complex-float C{ 0.0 0.0 } "complex-float" \ set-class-c-type -complex-double C{ 0.0 0.0 } "complex-double" \ set-class-c-type - -char [ 8 bits 8 >signed ] "coercer" set-word-prop -uchar [ 8 bits ] "coercer" set-word-prop -short [ 16 bits 16 >signed ] "coercer" set-word-prop -ushort [ 16 bits ] "coercer" set-word-prop -int [ 32 bits 32 >signed ] "coercer" set-word-prop -uint [ 32 bits ] "coercer" set-word-prop -long [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop -ulong [ bits ] long-bits get-global prefix "coercer" set-word-prop -longlong [ 64 bits 64 >signed ] "coercer" set-word-prop -ulonglong [ 64 bits ] "coercer" set-word-prop - -PREDICATE: c-type-class < class - "class-c-type" word-prop ; - -GENERIC: direct-array-of ( alien len class -- array ) inline - -M: c-type-class direct-array-of - class-direct-array execute( alien len -- array ) ; inline - -M: c-type-class c-type class-c-type ; -M: c-type-class c-type-align class-c-type c-type-align ; -M: c-type-class c-type-getter class-c-type c-type-getter ; -M: c-type-class c-type-setter class-c-type c-type-setter ; -M: c-type-class c-type-boxer-quot class-c-type c-type-boxer-quot ; -M: c-type-class c-type-unboxer-quot class-c-type c-type-unboxer-quot ; -M: c-type-class heap-size class-c-type heap-size ; - diff --git a/extra/classes/struct/prettyprint/prettyprint.factor b/extra/classes/struct/prettyprint/prettyprint.factor index 6bf62f694c..feeecd881b 100644 --- a/extra/classes/struct/prettyprint/prettyprint.factor +++ b/extra/classes/struct/prettyprint/prettyprint.factor @@ -1,7 +1,7 @@ ! (c)Joe Groff bsd license -USING: accessors assocs classes classes.struct kernel math -prettyprint.backend prettyprint.custom prettyprint.sections -see.private sequences words ; +USING: accessors assocs classes classes.struct combinators +kernel math prettyprint.backend prettyprint.custom +prettyprint.sections see.private sequences words ; IN: classes.struct.prettyprint assoc ( struct -- assoc ) [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ; +: pprint-struct-slot ( slot -- ) + > text ] + [ c-type>> text ] + [ read-only>> [ \ read-only pprint-word ] when ] + [ initial>> [ \ initial: pprint-word pprint* ] when* ] + } cleave + \ } pprint-word block> ; + PRIVATE> M: struct-class see-class* pprint-; block> ; M: struct pprint-delims diff --git a/extra/classes/struct/struct-docs.factor b/extra/classes/struct/struct-docs.factor index 83d5859f7c..2b27672018 100644 --- a/extra/classes/struct/struct-docs.factor +++ b/extra/classes/struct/struct-docs.factor @@ -24,7 +24,7 @@ HELP: STRUCT: { $description "Defines a new " { $link struct } " type. The syntax is nearly identical to " { $link POSTPONE: TUPLE: } "; however, there are some additional restrictions on struct types:" { $list { "Struct classes cannot have a superclass defined." } -{ "The slots of a struct must all have a type declared. The type must be either another struct class, or one of the " { $link "classes.c-types" } "." } +{ "The slots of a struct must all have a type declared. The type must be a C type." } { { $link read-only } " slots on structs are not enforced, though they may be declared." } } } ; diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor index 467f9da67b..536737d2d0 100644 --- a/extra/classes/struct/struct-tests.factor +++ b/extra/classes/struct/struct-tests.factor @@ -1,11 +1,25 @@ ! (c)Joe Groff bsd license -USING: accessors alien.c-types alien.structs.fields alien.syntax -classes.c-types classes.struct combinators io.streams.string kernel -libc literals math multiline namespaces prettyprint prettyprint.config -see tools.test ; -FROM: classes.c-types => float ; +USING: accessors alien.c-types alien.libraries +alien.structs.fields alien.syntax classes.struct combinators +io.pathnames io.streams.string kernel libc literals math +multiline namespaces prettyprint prettyprint.config see system +tools.test ; IN: classes.struct.tests +<< +: libfactor-ffi-tests-path ( -- string ) + "resource:" (normalize-path) + { + { [ os winnt? ] [ "libfactor-ffi-test.dll" ] } + { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] } + { [ os unix? ] [ "libfactor-ffi-test.so" ] } + } cond append-path ; + +"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library + +"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library +>> + STRUCT: struct-test-foo { x char } { y int initial: 123 } @@ -56,15 +70,14 @@ UNION-STRUCT: struct-test-float-and-bits with-variable ] unit-test -[ <" USING: classes.c-types classes.struct kernel ; +[ <" USING: classes.struct ; IN: classes.struct.tests STRUCT: struct-test-foo - { x char initial: 0 } { y int initial: 123 } - { z boolean initial: f } ; + { x char initial: 0 } { y int initial: 123 } { z bool } ; "> ] [ [ struct-test-foo see ] with-string-writer ] unit-test -[ <" USING: classes.c-types classes.struct ; +[ <" USING: classes.struct ; IN: classes.struct.tests UNION-STRUCT: struct-test-float-and-bits { f float initial: 0.0 } { bits uint initial: 0 } ; @@ -75,21 +88,21 @@ UNION-STRUCT: struct-test-float-and-bits T{ field-spec { name "x" } { offset 0 } - { type char } + { type "char" } { reader x>> } { writer (>>x) } } T{ field-spec { name "y" } { offset 4 } - { type int } + { type "int" } { reader y>> } { writer (>>y) } } T{ field-spec { name "z" } { offset 8 } - { type bool } + { type "bool" } { reader z>> } { writer (>>z) } } @@ -99,14 +112,14 @@ UNION-STRUCT: struct-test-float-and-bits T{ field-spec { name "f" } { offset 0 } - { type float } + { type "float" } { reader f>> } { writer (>>f) } } T{ field-spec { name "bits" } { offset 0 } - { type uint } + { type "uint" } { reader bits>> } { writer (>>bits) } } diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index 02d0a056a8..33e5ba89ae 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -1,10 +1,11 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays -byte-arrays classes classes.c-types classes.parser classes.tuple +byte-arrays classes classes.parser classes.tuple classes.tuple.parser classes.tuple.private combinators combinators.smart fry generalizations generic.parser kernel -kernel.private libc macros make math math.order parser -quotations sequences slots slots.private struct-arrays words ; +kernel.private lexer libc macros make math math.order parser +quotations sequences slots slots.private struct-arrays +vectors words ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -13,6 +14,9 @@ IN: classes.struct TUPLE: struct { (underlying) c-ptr read-only } ; +TUPLE: struct-slot-spec < slot-spec + c-type ; + PREDICATE: struct-class < tuple-class \ struct subclass-of? ; @@ -52,11 +56,11 @@ MACRO: ( class -- quot: ( ... -- struct ) ) [ struct-slots [ initial>> ] map over length tail append ] keep ; : (reader-quot) ( slot -- quot ) - [ class>> c-type-getter-boxer ] + [ c-type>> c-type-getter-boxer ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (writer-quot) ( slot -- quot ) - [ class>> c-setter ] + [ c-type>> c-setter ] [ offset>> [ >c-ptr ] swap suffix ] bi prepend ; : (boxer-quot) ( class -- quot ) @@ -96,7 +100,7 @@ M: struct-class writer-quot field-spec new swap { [ name>> >>name ] [ offset>> >>offset ] - [ class>> >>type ] + [ c-type>> >>type ] [ name>> reader-word >>reader ] [ name>> writer-word >>writer ] } cleave ; @@ -111,9 +115,12 @@ M: struct-class writer-quot } cleave (define-struct) ] [ - [ name>> c-type ] - [ (unboxer-quot) >>unboxer-quot ] - [ (boxer-quot) >>boxer-quot ] tri drop + { + [ name>> c-type ] + [ (unboxer-quot) >>unboxer-quot ] + [ (boxer-quot) >>boxer-quot ] + [ >>boxed-class ] + } cleave drop ] bi ; : align-offset ( offset class -- offset' ) @@ -121,15 +128,15 @@ M: struct-class writer-quot : struct-offsets ( slots -- size ) 0 [ - [ class>> align-offset ] keep - [ (>>offset) ] [ class>> heap-size + ] 2bi + [ c-type>> align-offset ] keep + [ (>>offset) ] [ c-type>> heap-size + ] 2bi ] reduce ; : union-struct-offsets ( slots -- size ) - [ 0 >>offset class>> heap-size ] [ max ] map-reduce ; + [ 0 >>offset c-type>> heap-size ] [ max ] map-reduce ; : struct-align ( slots -- align ) - [ class>> c-type-align ] [ max ] map-reduce ; + [ c-type>> c-type-align ] [ max ] map-reduce ; M: struct-class c-type name>> c-type ; @@ -153,9 +160,6 @@ M: struct-class c-type-unboxer-quot M: struct-class heap-size "struct-size" word-prop ; -M: struct-class direct-array-of - ; - ! class definition : struct-prototype ( class -- prototype ) @@ -180,7 +184,7 @@ M: struct-class direct-array-of [ (define-struct-slot-values-method) ] tri ; : check-struct-slots ( slots -- ) - [ class>> c-type drop ] each ; + [ c-type>> c-type drop ] each ; : (define-struct-class) ( class slots offsets-quot -- ) [ drop struct f define-tuple-class ] @@ -197,8 +201,27 @@ M: struct-class direct-array-of : define-union-struct-class ( class slots -- ) [ union-struct-offsets ] (define-struct-class) ; +ERROR: invalid-struct-slot token ; + +: struct-slot-class ( c-type -- class' ) + c-type boxed-class>> + dup \ byte-array = [ drop \ c-ptr ] when ; + +: parse-struct-slot ( -- slot ) + struct-slot-spec new + scan >>name + scan [ >>c-type ] [ struct-slot-class >>class ] bi + \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ; + +: parse-struct-slots ( slots -- slots' more? ) + scan { + { ";" [ f ] } + { "{" [ parse-struct-slot over push t ] } + [ invalid-struct-slot ] + } case ; + : parse-struct-definition ( -- class slots ) - CREATE-CLASS [ parse-tuple-slots ] { } make ; + CREATE-CLASS 8 [ parse-struct-slots ] [ ] while >array ; SYNTAX: STRUCT: parse-struct-definition define-struct-class ;