diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index b6b28d0a95..ac9a959d4c 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -49,7 +49,7 @@ HELP: c-setter { $errors "Throws an error if the type does not exist." } ; HELP: -{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } } +{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } } { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." } { $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } { $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index d9d2a6f677..0de56f4ce6 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -1,9 +1,9 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types arrays assocs classes -classes.struct combinators continuations fry kernel make math -math.parser mirrors prettyprint.backend prettyprint.custom -prettyprint.sections see.private sequences strings -summary words ; +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 > ] bi 2array 1array +TUPLE: struct-mirror { object read-only } ; +C: struct-mirror + +: get-struct-slot ( struct slot -- value present? ) + over class struct-slots slot-named + [ name>> reader-word execute( struct -- value ) t ] + [ drop f f ] if* ; +: set-struct-slot ( value struct slot -- ) + over class struct-slots slot-named + [ name>> writer-word execute( value struct -- ) ] + [ 2drop ] if* ; +: reset-struct-slot ( struct slot -- ) + over class struct-slots slot-named + [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ] + [ drop ] if* ; +: reset-struct-slots ( struct -- ) + dup class struct-prototype + dup byte-length memcpy ; + +M: struct-mirror at* + object>> { + { [ over "underlying" = ] [ nip >c-ptr t ] } + { [ over { [ array? ] [ length 1 >= ] } 1&& ] [ swap first get-struct-slot ] } + [ 2drop f f ] + } cond ; + +M: struct-mirror set-at + object>> { + { [ over "underlying" = ] [ 3drop ] } + { [ over array? ] [ swap first set-struct-slot ] } + [ 3drop ] + } cond ; + +M: struct-mirror delete-at + object>> { + { [ over "underlying" = ] [ 2drop ] } + { [ over array? ] [ swap first reset-struct-slot ] } + [ 2drop ] + } cond ; + +M: struct-mirror clear-assoc + object>> reset-struct-slots ; + +M: struct-mirror >alist ( mirror -- alist ) + object>> [ + [ drop "underlying" ] [ >c-ptr ] bi 2array 1array ] [ '[ _ struct>assoc [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map ] [ drop { } ] recover ] bi append ; + +M: struct make-mirror ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 55f67c398b..9387d932c6 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,12 +1,13 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types alien.libraries -alien.structs.fields alien.syntax ascii byte-arrays classes.struct -combinators destructors io.encodings.utf8 io.pathnames io.streams.string -kernel libc literals math multiline namespaces prettyprint -prettyprint.config see sequences specialized-arrays.ushort -system tools.test compiler.tree.debugger struct-arrays -classes.tuple.private specialized-arrays.direct.int -compiler.units specialized-arrays.char ; +alien.structs.fields alien.syntax 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.char +specialized-arrays.direct.int specialized-arrays.ushort +struct-arrays system tools.test ; IN: classes.struct.tests << @@ -56,6 +57,89 @@ STRUCT: struct-test-bar [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test +[ { + { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } } + { { "x" "char" } 98 } + { { "y" "int" } HEX: 7F00007F } + { { "z" "bool" } f } +} ] [ + B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct + make-mirror >alist +] unit-test + +[ { { "underlying" f } } ] [ + f struct-test-foo memory>struct + make-mirror >alist +] unit-test + +[ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test +[ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test +[ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test +[ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test +[ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test +[ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test +[ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test + +[ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror { "y" "int" } swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror { "x" "char" } swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror { "nonexist" "char" } swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror "underlying" swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z f } } + [ make-mirror "nonsense" swap delete-at ] keep +] unit-test + +[ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [ + S{ struct-test-foo { x 1 } { y 2 } { z t } } + [ make-mirror clear-assoc ] keep +] unit-test + UNION-STRUCT: struct-test-float-and-bits { f float } { bits uint } ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 731f305748..2ba2ff2067 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -97,7 +97,7 @@ PRIVATE> M: struct-class boa>object swap pad-struct-slots - [ (struct) ] [ struct-slots ] bi + [ ] [ struct-slots ] bi [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; ! Struct slot accessors diff --git a/basis/struct-arrays/struct-arrays-docs.factor b/basis/struct-arrays/struct-arrays-docs.factor index 7b49d6ef42..3e7582f8cd 100644 --- a/basis/struct-arrays/struct-arrays-docs.factor +++ b/basis/struct-arrays/struct-arrays-docs.factor @@ -15,7 +15,7 @@ HELP: { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ; HELP: struct-array-on -{ $value { "struct" struct } { "length" integer } } +{ $values { "struct" struct } { "length" integer } { "struct-array" struct-array } } { $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." } { $examples "This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:" diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 4ee31936a9..2b9fd7b89b 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -142,3 +142,14 @@ TUPLE: parsing-corner-case x ; " x 3 }" } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with + +TUPLE: bad-inheritance-tuple ; +[ + "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple < bad-inheritance-tuple ;" eval( -- ) +] [ error>> bad-inheritance? ] must-fail-with + +TUPLE: bad-inheritance-tuple2 ; +TUPLE: bad-inheritance-tuple3 < bad-inheritance-tuple2 ; +[ + "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple2 < bad-inheritance-tuple3 ;" eval( -- ) +] [ error>> bad-inheritance? ] must-fail-with diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 7ba850f744..0a57ad34f3 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sets namespaces make sequences parser lexer combinators words classes.parser classes.tuple arrays -slots math assocs parser.notes ; +slots math assocs parser.notes classes.algebra ; IN: classes.tuple.parser : slot-names ( slots -- seq ) @@ -56,11 +56,18 @@ ERROR: invalid-slot-name name ; : parse-tuple-slots ( -- ) ";" parse-tuple-slots-delim ; +ERROR: bad-inheritance class superclass ; + +: check-inheritance ( class1 class2 -- class1 class2 ) + 2dup swap class<= [ bad-inheritance ] when ; + : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS - scan { + scan 2dup = [ ] when { { ";" [ tuple f ] } - { "<" [ scan-word [ parse-tuple-slots ] { } make ] } + { "<" [ + scan-word check-inheritance [ parse-tuple-slots ] { } make + ] } [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] } case dup check-duplicate-slots diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index 8ccc65da43..3ffe8e96bb 100755 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff bsd license USING: classes classes.struct gpu.buffers help.markup help.syntax -images kernel math multiline quotations sequences strings ; +images kernel math multiline quotations sequences strings words ; IN: gpu.shaders HELP: @@ -86,7 +86,7 @@ HELP: define-vertex-format HELP: define-vertex-struct { $values - { "struct-name" string } { "vertex-format" vertex-format } + { "class" word } { "vertex-format" vertex-format } } { $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;