From d5bc1ceca239682ee23f20c781782606c5182f6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Sep 2009 15:59:27 -0500 Subject: [PATCH] classes.struct: fix some bugs - STRUCT: foo in listener threw an error - S{ did not throw an error when used with non-struct types - attempting to subclass a struct class now fails - forgetting a struct class now removes the corresponding C type - 'see'ing a struct class now indents correctly --- .../struct/prettyprint/prettyprint.factor | 4 +- basis/classes/struct/struct-tests.factor | 58 +++++++++---------- basis/classes/struct/struct.factor | 49 ++++++++-------- core/classes/tuple/tuple.factor | 9 ++- 4 files changed, 64 insertions(+), 56 deletions(-) diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index 58c923e6d0..e88834530c 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -18,12 +18,12 @@ IN: classes.struct.prettyprint : pprint-struct-slot ( slot -- ) > text ] [ c-type>> dup string? [ text ] [ pprint* ] if ] [ read-only>> [ \ read-only pprint-word ] when ] [ initial>> [ \ initial: pprint-word pprint* ] when* ] - } cleave + } cleave block> \ } pprint-word block> ; : pprint-struct ( struct -- ) diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 22d194d2a4..8508230bb2 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,31 +1,16 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.libraries -alien.structs.fields alien.syntax ascii assocs byte-arrays -classes.struct classes.tuple.private combinators -compiler.tree.debugger compiler.units destructors +USING: accessors alien alien.c-types alien.structs.fields ascii +assocs byte-arrays classes.struct classes.tuple.private +combinators compiler.tree.debugger compiler.units destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc literals math mirrors multiline namespaces prettyprint -prettyprint.config see sequences specialized-arrays -system tools.test ; +prettyprint.config see sequences specialized-arrays system +tools.test parser lexer eval ; SPECIALIZED-ARRAY: char SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: ushort 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 ->> - SYMBOL: struct-test-empty [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ] @@ -278,15 +263,6 @@ STRUCT: struct-test-equality-2 ] with-destructors ] unit-test -STRUCT: struct-test-ffi-foo - { x int } - { y int } ; - -LIBRARY: f-cdecl -FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ; - -[ 14 ] [ 1 2 3 struct-test-ffi-foo 4 ffi_test_11 ] unit-test - STRUCT: struct-test-array-slots { x int } { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } } @@ -350,3 +326,27 @@ STRUCT: struct-that's-a-word { x int } ; [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test +! Interactive parsing of struct slot definitions +[ + "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" + "struct-class-test-1" parse-stream +] [ error>> error>> unexpected-eof? ] must-fail-with + +! S{ with non-struct type +[ + "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }" + eval( -- value ) +] must-fail + +! Subclassing a struct class should not be allowed +[ + "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;" + eval( -- ) +] must-fail + +! Remove c-type when struct class is forgotten +[ ] [ + "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- ) +] unit-test + +[ f ] [ "a-struct" c-types get key? ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 24d7e592bd..893bc5a257 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -6,7 +6,7 @@ combinators combinators.short-circuit combinators.smart definitions functors.backend fry generalizations generic.parser kernel kernel.private lexer libc locals macros make math math.order parser quotations sequences slots slots.private -specialized-arrays vectors words +specialized-arrays vectors words summary namespaces assocs compiler.tree.propagation.transforms ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -15,16 +15,23 @@ SPECIALIZED-ARRAY: uchar ERROR: struct-must-have-slots ; +M: struct-must-have-slots summary + drop "Struct definitions must have slots" ; + TUPLE: struct { (underlying) c-ptr read-only } ; TUPLE: struct-slot-spec < slot-spec c-type ; -PREDICATE: struct-class < tuple-class \ struct subclass-of? ; +PREDICATE: struct-class < tuple-class + superclass \ struct eq? ; -: struct-slots ( struct-class -- slots ) - "struct-slots" word-prop ; +M: struct-class valid-superclass? drop f ; + +GENERIC: struct-slots ( struct-class -- slots ) + +M: struct-class struct-slots "struct-slots" word-prop ; ! struct allocation @@ -175,36 +182,27 @@ M: struct-class writer-quot [ c-type>> c-type-align ] [ max ] map-reduce ; PRIVATE> -M: struct-class c-type - name>> c-type ; +M: struct-class c-type name>> c-type ; -M: struct-class c-type-align - "struct-align" word-prop ; +M: struct-class c-type-align c-type c-type-align ; -M: struct-class c-type-getter - drop [ swap ] ; +M: struct-class c-type-getter c-type c-type-getter ; -M: struct-class c-type-setter - [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri - '[ @ swap @ _ memcpy ] ; +M: struct-class c-type-setter c-type c-type-setter ; -M: struct-class c-type-boxer-quot - (boxer-quot) ; +M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ; -M: struct-class c-type-unboxer-quot - (unboxer-quot) ; +M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ; -M: struct-class heap-size - "struct-size" word-prop ; +M: struct-class heap-size c-type heap-size ; -M: struct byte-length - class "struct-size" word-prop ; foldable +M: struct byte-length class "struct-size" word-prop ; foldable ! class definition ] + [ "struct-size" word-prop ] [ memory>struct ] [ struct-slots ] tri [ @@ -237,8 +235,9 @@ M: struct byte-length : (define-struct-class) ( class slots offsets-quot -- ) [ + empty? [ struct-must-have-slots ] - [ drop redefine-struct-tuple-class ] if-empty + [ redefine-struct-tuple-class ] if ] swap '[ make-slots dup @@ -254,6 +253,9 @@ PRIVATE> : define-union-struct-class ( class slots -- ) [ union-struct-offsets ] (define-struct-class) ; +M: struct-class reset-class + [ call-next-method ] [ name>> c-types get delete-at ] bi ; + ERROR: invalid-struct-slot token ; : struct-slot-class ( c-type -- class' ) @@ -277,6 +279,7 @@ ERROR: invalid-struct-slot token ; scan { { ";" [ f ] } { "{" [ parse-struct-slot over push t ] } + { f [ unexpected-eof ] } [ invalid-struct-slot ] } case ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 44eae9038f..0b1cd513b7 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -252,8 +252,13 @@ M: tuple-class update-class [ [ "slots" word-prop ] dip = ] bi-curry* bi and ; -: valid-superclass? ( class -- ? ) - [ tuple-class? ] [ tuple eq? ] bi or ; +GENERIC: valid-superclass? ( class -- ? ) + +M: tuple-class valid-superclass? drop t ; + +M: builtin-class valid-superclass? tuple eq? ; + +M: class valid-superclass? drop f ; : check-superclass ( superclass -- ) dup valid-superclass? [ bad-superclass ] unless drop ;