Merge branch 'master' of git://factorcode.org/git/factor

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: <c-array>
-{ $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." } ;

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
+classes.struct combinators combinators.short-circuit continuations
-math.parser mirrors prettyprint.backend prettyprint.custom
+fry kernel libc make math math.parser mirrors prettyprint.backend
-prettyprint.sections see.private sequences strings
+prettyprint.custom prettyprint.sections see.private sequences
-summary words ;
+slots strings summary words ;
 IN: classes.struct.prettyprint
 
 <PRIVATE
@@ -62,12 +62,57 @@ M: struct summary
         " bytes " %
     ] "" make ;
 
-M: struct make-mirror
+TUPLE: struct-mirror { object read-only } ;
-    [
+C: <struct-mirror> struct-mirror
-        [ drop "underlying" ] [ (underlying)>> ] bi 2array 1array
+
+: 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 <struct-mirror> ;

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
+alien.structs.fields alien.syntax ascii assocs byte-arrays
-combinators destructors io.encodings.utf8 io.pathnames io.streams.string
+classes.struct classes.tuple.private combinators
-kernel libc literals math multiline namespaces prettyprint
+compiler.tree.debugger compiler.units destructors
-prettyprint.config see sequences specialized-arrays.ushort
+io.encodings.utf8 io.pathnames io.streams.string kernel libc
-system tools.test compiler.tree.debugger struct-arrays
+literals math mirrors multiline namespaces prettyprint
-classes.tuple.private specialized-arrays.direct.int
+prettyprint.config see sequences specialized-arrays.char
-compiler.units 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 } ;

basis/classes/struct/struct.factor

@@ -97,7 +97,7 @@ PRIVATE>
 
 M: struct-class boa>object
     swap pad-struct-slots
-    [ (struct) ] [ struct-slots ] bi 
+    [ <struct> ] [ struct-slots ] bi 
     [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
 
 ! Struct slot accessors

basis/struct-arrays/struct-arrays-docs.factor

@@ -15,7 +15,7 @@ HELP: <direct-struct-array>
 { $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:"

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

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

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: <program-instance>
@@ -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." } ;