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

basis/alien/parser/parser.factor

@@ -1,18 +1,30 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces ;
+parser sequences splitting words fry locals lexer namespaces
+summary math ;
 IN: alien.parser
 
+: normalize-c-arg ( type name -- type' name' )
+    [ length ]
+    [
+        [ CHAR: * = ] trim-head
+        [ length - CHAR: * <array> append ] keep
+    ] bi ;
+
 : parse-arglist ( parameters return -- types effect )
-    [ 2 group unzip [ "," ?tail drop ] map ]
+    [
+        2 group [ first2 normalize-c-arg 2array ] map
+        unzip [ "," ?tail drop ] map
+    ]
     [ [ { } ] [ 1array ] if-void ]
     bi* <effect> ;
 
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: make-function ( return library function parameters -- word quot effect )
+:: make-function ( return! library function! parameters -- word quot effect )
+    return function normalize-c-arg function! return!
     function create-in dup reset-generic
     return library function
     parameters return parse-arglist [ function-quot ] dip ;

basis/cairo/ffi/ffi.factor

@@ -896,7 +896,7 @@ FUNCTION: cairo_status_t
 cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
 
 FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
 
 FUNCTION: cairo_status_t
 cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;

basis/calendar/unix/unix.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time namespaces system ;
+kernel math unix unix.time unix.types namespaces system ;
 IN: calendar.unix
 
 : timeval>seconds ( timeval -- seconds )
@@ -19,7 +19,7 @@ IN: calendar.unix
     timespec>seconds since-1970 ;
 
 : get-time ( -- alien )
-    f time <uint> localtime ;
+    f time <time_t> localtime ;
 
 : timezone-name ( -- string )
     get-time tm-zone ;

basis/math/bitwise/bitwise.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math sequences accessors
+USING: arrays assocs combinators combinators.smart fry kernel
-math.bits sequences.private words namespaces macros
+macros math math.bits sequences sequences.private words ;
-hints combinators fry io.binary combinators.smart ;
 IN: math.bitwise
 
 ! utilities
@@ -104,14 +103,6 @@ PRIVATE>
 : bit-count ( x -- n )
     dup 0 < [ bitnot ] when (bit-count) ; inline
 
-! Signed byte array to integer conversion
-: signed-le> ( bytes -- x )
-    [ le> ] [ length 8 * 1 - on-bits ] bi
-    2dup > [ bitnot bitor ] [ drop ] if ;
-
-: signed-be> ( bytes -- x )
-    <reversed> signed-le> ;
-
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 

basis/opengl/capabilities/capabilities-docs.factor

@@ -40,7 +40,13 @@ HELP: gl-extensions
 
 HELP: has-gl-extensions?
 { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
+{ $examples "Testing for framebuffer object and pixel buffer support:"
+    { $code <" {
+    { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
+    "GL_ARB_pixel_buffer_object"
+} has-gl-extensions? "> }
+} ;
 
 HELP: has-gl-version-or-extensions?
 { $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }

basis/opengl/capabilities/capabilities-tests.factor

@@ -0,0 +1,21 @@
+! (c)2009 Joe Groff bsd license
+USING: opengl.capabilities tools.test ;
+IN: opengl.capabilities.tests
+
+CONSTANT: test-extensions
+    {
+        "GL_ARB_vent_core_frogblast"
+        "GL_EXT_resonance_cascade"
+        "GL_EXT_slipgate"
+    }
+
+[ t ]
+[ "GL_ARB_vent_core_frogblast" test-extensions (has-extension?) ] unit-test
+
+[ f ]
+[ "GL_ARB_wallhack" test-extensions (has-extension?) ] unit-test
+
+[ t ] [
+    { "GL_EXT_dimensional_portal" "GL_EXT_slipgate" }
+    test-extensions (has-extension?)
+] unit-test

basis/opengl/capabilities/capabilities.factor

@@ -1,16 +1,19 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order fry ;
+continuations math.parser math arrays sets strings math.order fry ;
 IN: opengl.capabilities
 
 : (require-gl) ( thing require-quot make-error-quot -- )
     [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
 
+: (has-extension?) ( query-extension(s) available-extensions -- ? )
+    over string?  [ member? ] [ [ member? ] curry any? ] if ;
+
 : gl-extensions ( -- seq )
     GL_EXTENSIONS glGetString " " split ;
 : has-gl-extensions? ( extensions -- ? )
-    gl-extensions swap [ over member? ] all? nip ;
+    gl-extensions [ (has-extension?) ] curry all? ;
 : (make-gl-extensions-error) ( required-extensions -- )
     gl-extensions diff
     "Required OpenGL extensions not supported:\n" %

basis/opengl/shaders/shaders.factor

@@ -61,22 +61,18 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
 
 ! Programs
 
-: <mrt-gl-program> ( shaders frag-data-locations -- program )
+: (gl-program) ( shaders quot: ( gl-program -- ) -- program )
     glCreateProgram 
     [
         [ swap [ glAttachShader ] with each ]
-        [ swap [ first2 swap glBindFragDataLocation ] with each ] bi-curry bi*
+        [ swap call ] bi-curry bi*
-    ]
+    ] [ glLinkProgram ] [ ] tri gl-error ; inline
-    [ glLinkProgram ]
+
-    [ ] tri
+: <mrt-gl-program> ( shaders frag-data-locations -- program )
-    gl-error ;
+    [ [ first2 swap glBindFragDataLocation ] with each ] curry (gl-program) ;
 
 : <gl-program> ( shaders -- program )
-    glCreateProgram 
+    [ drop ] (gl-program) ;
-    [ swap [ glAttachShader ] with each ]
-    [ glLinkProgram ]
-    [ ] tri
-    gl-error ;
     
 : (gl-program?) ( object -- ? )
     dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;

basis/tools/scaffold/scaffold.factor

@@ -124,7 +124,7 @@ M: bad-developer-name summary
         { "str" string }
         { "hash" hashtable }
         { "hashtable" hashtable }
-        { "?" "a boolean" }
+        { "?" boolean }
         { "ch" "a character" }
         { "word" word }
         { "array" array }

basis/unix/types/freebsd/freebsd.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 
 IN: unix.types
 
@@ -22,3 +22,5 @@ TYPEDEF: __uint32_t     fflags_t
 TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
+
+ALIAS: <time_t> <int>

basis/unix/types/linux/linux.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 TYPEDEF: ulonglong __uquad_type
@@ -31,3 +31,5 @@ TYPEDEF: ulonglong __fsblkcnt64_t
 TYPEDEF: ulonglong __fsfilcnt64_t
 TYPEDEF: ulonglong ino64_t
 TYPEDEF: ulonglong off64_t
+
+ALIAS: <time_t> <long>

basis/unix/types/macosx/macosx.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 ! Darwin 9.1.0
@@ -21,3 +21,5 @@ TYPEDEF: __int32_t  blksize_t
 TYPEDEF: long       ssize_t
 TYPEDEF: __int32_t  pid_t
 TYPEDEF: long       time_t
+
+ALIAS: <time_t> <long>

basis/unix/types/netbsd/netbsd.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax combinators layouts vocabs.loader ;
+USING: alien.syntax alien.c-types combinators layouts vocabs.loader ;
 IN: unix.types
 
 ! NetBSD 4.0
@@ -17,6 +17,8 @@ TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
 
+ALIAS: <time_t> <int>
+
 cell-bits {
     { 32 [ "unix.types.netbsd.32" require ] }
     { 64 [ "unix.types.netbsd.64" require ] }

basis/unix/types/openbsd/openbsd.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 ! OpenBSD 4.2
@@ -17,3 +17,5 @@ TYPEDEF: __uint32_t     fflags_t
 TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
+
+ALIAS: <time_t> <int>

basis/x11/xlib/xlib.factor

@@ -477,7 +477,7 @@ C-STRUCT: XImage
     { "XImage-funcs" "f" } ;
 
 X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
 
 : XImage-size ( ximage -- size )
     [ XImage-height ] [ XImage-bytes_per_line ] bi * ;

core/io/binary/binary.factor

@@ -24,3 +24,10 @@ IN: io.binary
 : h>b/b ( h -- b1 b2 )
     [ mask-byte ]
     [ -8 shift mask-byte ] bi ;
+
+: signed-le> ( bytes -- x )
+    [ le> ] [ length 8 * 1 - 2^ 1 - ] bi
+    2dup > [ bitnot bitor ] [ drop ] if ;
+
+: signed-be> ( bytes -- x )
+    <reversed> signed-le> ;

core/math/floats/floats-docs.factor

@@ -1,26 +1,6 @@
 USING: help.markup help.syntax math math.private ;
 IN: math.floats
 
-ARTICLE: "floats" "Floats"
-{ $subsection float }
-"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers."
-$nl
-"Introducing a floating point number in a computation forces the result to be expressed in floating point."
-{ $example "5/4 1/2 + ." "1+3/4" }
-{ $example "5/4 0.5 + ." "1.75" }
-"Integers and rationals can be converted to floats:"
-{ $subsection >float }
-"Two real numbers can be divided yielding a float result:"
-{ $subsection /f }
-"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
-{ $subsection float>bits }
-{ $subsection double>bits }
-{ $subsection bits>float }
-{ $subsection bits>double }
-{ $see-also "syntax-floats" } ;
-
-ABOUT: "floats"
-
 HELP: float
 { $class-description "The class of double-precision floating point numbers." } ;
 
@@ -29,21 +9,21 @@ HELP: >float
 { $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;
 
 HELP: bits>double ( n -- x )
-{ $values { "n" "a 64-bit integer representing an 754 double-precision float" } { "x" float } }
+{ $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } }
 { $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
 
 { bits>double bits>float double>bits float>bits } related-words
 
 HELP: bits>float ( n -- x )
-{ $values { "n" "a 32-bit integer representing an 754 single-precision float" } { "x" float } }
+{ $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } }
 { $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
 
 HELP: double>bits ( x -- n )
-{ $values { "x" float } { "n" "a 64-bit integer representing an 754 double-precision float" } }
+{ $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } }
 { $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
 
 HELP: float>bits ( x -- n )
-{ $values { "x" float } { "n" "a 32-bit integer representing an 754 single-precision float" } }
+{ $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } }
 { $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
 
 ! Unsafe primitives
@@ -91,3 +71,37 @@ HELP: float>= ( x y -- ? )
 { $values { "x" float } { "y" float } { "?" "a boolean" } }
 { $description "Primitive version of " { $link >= } "." }
 { $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
+
+ARTICLE: "floats" "Floats"
+{ $subsection float }
+"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+$nl
+"Introducing a floating point number in a computation forces the result to be expressed in floating point."
+{ $example "5/4 1/2 + ." "1+3/4" }
+{ $example "5/4 0.5 + ." "1.75" }
+"Integers and rationals can be converted to floats:"
+{ $subsection >float }
+"Two real numbers can be divided yielding a float result:"
+{ $subsection /f }
+"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
+{ $subsection float>bits }
+{ $subsection double>bits }
+{ $subsection bits>float }
+{ $subsection bits>double }
+"Constructing floating point NaNs:"
+{ $subsection <fp-nan> }
+"Floating point numbers are discrete:"
+{ $subsection prev-float }
+{ $subsection next-float }
+"Introspection on floating point numbers:"
+{ $subsection fp-special? }
+{ $subsection fp-nan? }
+{ $subsection fp-qnan? }
+{ $subsection fp-snan? }
+{ $subsection fp-infinity? }
+{ $subsection fp-nan-payload }
+"Comparing two floating point numbers:"
+{ $subsection fp-bitwise= }
+{ $see-also "syntax-floats" } ;
+
+ABOUT: "floats"

core/math/math-docs.factor

@@ -12,19 +12,19 @@ HELP: number=
 } ;
 
 HELP: <
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
 { $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
 
 HELP: <=
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
 { $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
 
 HELP: >
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
 { $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
 
 HELP: >=
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
 { $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
 
 
@@ -245,6 +245,13 @@ HELP: times
     { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
 } ;
 
+HELP: fp-bitwise=
+{ $values
+    { "x" float } { "y" float }
+    { "?" boolean }
+}
+{ $description "Compares two floating point numbers for bit equality." } ;
+
 HELP: fp-special?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
@@ -282,11 +289,11 @@ HELP: <fp-nan>
 
 HELP: next-float
 { $values { "m" float } { "n" float } }
-{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } ", or in the case of " { $snippet "-0.0" } ", returns " { $snippet "+0.0" } "." } ;
 
 HELP: prev-float
 { $values { "m" float } { "n" float } }
-{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } ", or in the case of " { $snippet "+0.0" } ", returns " { $snippet "-0.0" } "." } ;
 
 { next-float prev-float } related-words
 

core/sequences/sequences-docs.factor

@@ -627,7 +627,7 @@ HELP: slice-error
 } ;
 
 HELP: slice
-{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } "."
+{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } ". Convenience words are also provided for creating slices where one endpoint is the start or end of the sequence; see " { $link "sequences-slices" } " for a list."
 $nl
 "Slices are mutable if the underlying sequence is mutable, and mutating a slice changes the underlying sequence. However, slices cannot be resized after creation." } ;
 
@@ -1311,6 +1311,20 @@ HELP: iota
   }
 } ;
 
+HELP: assert-sequence=
+{ $values
+    { "a" sequence } { "b" sequence }
+}
+{ $description "Throws an error if all the elements of two sequences, taken pairwise, are not equal." }
+{ $notes "The sequences need not be of the same type." }
+{ $examples
+  { $example
+    "USING: prettyprint sequences ;"
+    "{ 1 2 3 } V{ 1 2 3 } assert-sequence="
+    ""
+  }
+} ;
+
 ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
 "The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
 $nl
@@ -1357,7 +1371,15 @@ ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
 { $subsection virtual@ } ;
 
 ARTICLE: "virtual-sequences" "Virtual sequences"
-"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "."
+"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
+$nl
+"Implementations include the following:"
+{ $list
+  { $link reversed }
+  { $link slice }
+  { $link iota }
+}
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence:"
 { $subsection "virtual-sequences-protocol" } ;
 
 ARTICLE: "sequences-integers" "Counted loops"
@@ -1422,6 +1444,16 @@ ARTICLE: "sequences-appending" "Appending sequences"
 { $subsection pad-tail } ;
 
 ARTICLE: "sequences-slices" "Subsequences and slices"
+"There are two ways to extract a subrange of elements from a sequence. The first approach creates a new sequence of the same type as the input, which does not share storage with the underlying sequence. This takes time proportional to the number of elements being extracted. The second approach creates a " { $emphasis "slice" } ", which is a virtual sequence (see " { $link "virtual-sequences" } ") sharing storage with the original sequence. Slices are constructed in constant time."
+$nl
+"Some general guidelines for choosing between the two approaches:"
+{ $list
+  "If you are using mutable state, the choice has to be made one way or another because of semantics; mutating a slice will change the underlying sequence."
+  { "Using a slice can improve algorithmic complexity. For example, if each iteration of a loop decomposes a sequence using " { $link first } " and " { $link rest } ", then the loop will run in quadratic time, relative to the length of the sequence. Using " { $link rest-slice } " changes the loop to run in linear time, since " { $link rest-slice } " does not copy any elements. Taking a slice of a slice will “collapse” the slice so to avoid the double indirection, so it is safe to use slices in recursive code." }
+  "Accessing elements from a concrete sequence (such as a string or an array) is often faster than accessing elements from a slice, because slice access entails additional indirection. However, in some cases, if the slice is immediately consumed by an iteration combinator, the compiler can eliminate the slice allocation and indirect altogether."
+  "If the slice outlives the original sequence, the original sequence will still remain in memory, since the slice will reference it. This can increase memory consumption unnecessarily."
+}
+{ $heading "Subsequence operations" }
 "Extracting a subsequence:"
 { $subsection subseq }
 { $subsection head }
@@ -1436,7 +1468,8 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 { $subsection unclip-last }
 { $subsection cut }
 { $subsection cut* }
-"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
+{ $heading "Slice operations" }
+"The slice data type:"
 { $subsection slice }
 { $subsection slice? }
 "Extracting a slice:"
@@ -1591,6 +1624,7 @@ ARTICLE: "sequences-comparing" "Comparing sequences"
 { $subsection sequence= }
 { $subsection mismatch }
 { $subsection drop-prefix }
+{ $subsection assert-sequence= }
 "The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
 
 ARTICLE: "sequences-f" "The f object as a sequence"

extra/alien/cxx/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/cxx.factor

@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+    create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+    "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+    [ drop class-wrapper { } define-tuple-class ]
+    [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+    [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+    add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+    [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make           :> name'
+    effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+    types class-name "*" append suffix                  :> types'
+    effect in>> "," join                                :> args
+    class-name virtual [ "#" append ] unless current-vocab lookup                  :> class
+    SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+    name' types' effect' body define-c-marshalled
+    class generic create-method name' current-vocab lookup 1quotation define ;

extra/alien/cxx/parser/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/parser/parser.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+    scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+    scan scan-word function-types-effect ;

extra/alien/cxx/syntax/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/syntax/syntax-tests.factor

@@ -0,0 +1,113 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+    return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+<RAW-C
+class alpha {
+    public:
+    alpha(const char* s) {
+        str = s;
+    };
+    const char* render() {
+        return str;
+    };
+    virtual const char* chop() {
+        return str;
+    };
+    virtual int length() {
+        return strlen(str);
+    };
+    const char* str;
+};
+
+class beta : alpha {
+    public:
+    beta(const char* s) : alpha(s + 1) { };
+    const char* render() {
+        return str + 1;
+    };
+    virtual const char* chop() {
+        return str + 2;
+    };
+};
+RAW-C>
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+    return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+    return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test

extra/alien/cxx/syntax/syntax.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+    parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+    parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+    parse-c++-method-definition t define-c++-method ;

extra/alien/inline/inline.factor

@@ -65,7 +65,7 @@ PRIVATE>
     concat make-function ;
 
 : define-c-library ( name -- )
-    c-library-name c-library set
+    c-library-name [ c-library set ] [ "c-library" set ] bi
     V{ } clone c-strings set
     V{ } clone linker-args set ;
 

extra/alien/inline/syntax/syntax-docs.factor

@@ -95,6 +95,6 @@ HELP: DELETE-C-LIBRARY:
 }
 { $see-also POSTPONE: delete-inline-library } ;
 
-HELP: RAW-C:
+HELP: <RAW-C
-{ $syntax "RAW-C:" "body" ";" }
+{ $syntax "<RAW-C code RAW-C>" }
-{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;

extra/alien/inline/syntax/syntax.factor

@@ -28,4 +28,4 @@ SYNTAX: ;C-LIBRARY compile-c-library ;
 
 SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
 
-SYNTAX: RAW-C: parse-here raw-c ;
+SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;

extra/alien/inline/types/types.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types assocs combinators.short-circuit
 continuations effects fry kernel math memoize sequences
-splitting ;
+splitting strings peg.ebnf make ;
 IN: alien.inline.types
 
 : cify-type ( str -- str' )
@@ -21,6 +21,9 @@ IN: alien.inline.types
 : pointer-to-const? ( str -- ? )
     cify-type "const " head? ;
 
+: template-class? ( str -- ? )
+    [ CHAR: < = ] any? ;
+
 MEMO: resolved-primitives ( -- seq )
     primitive-types [ resolve-typedef ] map ;
 
@@ -57,3 +60,42 @@ MEMO: resolved-primitives ( -- seq )
         [ over pointer-to-primitive? [ ">" prepend ] when ]
         assoc-map unzip
     ] dip <effect> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig  = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+    factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+    [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+    [
+        [ name>> % ]
+        [ params>> [ params>string % ] when* ]
+        [ ptr>> [ "*" % ] when ]
+        tri
+    ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;

extra/alien/marshall/marshall-docs.factor

@@ -327,10 +327,10 @@ HELP: out-arg-unmarshaller
     "for all types except pointers to non-const primitives."
 } ;
 
-HELP: pointer-unmarshaller
+HELP: class-unmarshaller
 { $values
     { "type" " a C type string" }
-    { "quot" quotation }
+    { "quot/f" quotation }
 }
 { $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
     " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
@@ -376,7 +376,7 @@ HELP: struct-primitive-unmarshaller
 HELP: struct-unmarshaller
 { $values
     { "type" "a C type string" }
-    { "quot" quotation }
+    { "quot/f" quotation }
 }
 { $description "Returns a quotation which wraps its argument in the subclass of "
     { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
@@ -604,7 +604,7 @@ ARTICLE: "alien.marshall" "C marshalling"
 "Wrap an alien:" { $subsection alien-wrapper }
 "Wrap a struct:" { $subsection struct-wrapper }
 "Get the marshaller for a C type:" { $subsection marshaller }
-"Get the unmarshaller for a C type:" { $subsection marshaller }
+"Get the unmarshaller for a C type:" { $subsection unmarshaller }
 "Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
 "Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
 $nl

extra/alien/marshall/marshall.factor

@@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong
 specialized-arrays.short specialized-arrays.uchar
 specialized-arrays.uint specialized-arrays.ulong
 specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays ;
+unix.utilities vocabs.parser words libc.private struct-arrays
+locals generalizations math ;
 IN: alien.marshall
 
 << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
@@ -19,6 +20,9 @@ filter [ define-primitive-marshallers ] each >>
 
 TUPLE: alien-wrapper { underlying alien } ;
 TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
 
 GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
 
@@ -27,6 +31,8 @@ M: struct-wrapper unmarshall-cast ;
 
 M: struct-wrapper dispose* underlying>> free ;
 
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
 : marshall-pointer ( obj -- alien )
     {
         { [ dup alien? ] [ ] }
@@ -269,33 +275,43 @@ ALIAS: marshall-void* marshall-pointer
 : ?malloc-byte-array ( c-type -- alien )
     dup alien? [ malloc-byte-array ] unless ;
 
-: struct-unmarshaller ( type -- quot )
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
-    current-vocab lookup [
+    type type-quot call current-vocab lookup [
-        dup superclasses [ \ struct-wrapper = ] any? [
+        dup superclasses superclass swap member?
-            '[ ?malloc-byte-array _ new swap >>underlying ]
+        [ def call ] [ drop clean call f ] if
-        ] [ drop [ ] ] if
+    ] [ clean call f ] if* ; inline
-    ] [ [ ] ] if* ;
 
-: pointer-unmarshaller ( type -- quot )
+: struct-unmarshaller ( type -- quot/f )
-    type-sans-pointer current-vocab lookup [
+    [ ] \ struct-wrapper
-        dup superclasses [ \ alien-wrapper = ] any? [
+    [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
-            '[ _ new swap >>underlying unmarshall-cast ]
+    [ ]
-        ] [ drop [ ] ] if
+    x-unmarshaller ;
-    ] [ [ ] ] if* ;
+
+: class-unmarshaller ( type -- quot/f )
+    [ type-sans-pointer "#" append ] \ class-wrapper
+    [ '[ _ new swap >>underlying ] ]
+    [ ]
+    x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+    {
+        { [ dup pointer? ] [ class-unmarshaller ] }
+        [ struct-unmarshaller ]
+    } cond ;
 
 : unmarshaller ( type -- quot )
-    factorize-type dup primitive-unmarshaller [ nip ] [
+    factorize-type {
-        dup pointer?
+        [ primitive-unmarshaller ]
-        [ pointer-unmarshaller ]
+        [ non-primitive-unmarshaller ]
-        [ struct-unmarshaller ] if
+        [ drop [ ] ]
-    ] if* ;
+    } 1|| ;
 
 : struct-field-unmarshaller ( type -- quot )
-    factorize-type dup struct-primitive-unmarshaller [ nip ] [
+    factorize-type {
-        dup pointer?
+        [ struct-primitive-unmarshaller ]
-        [ pointer-unmarshaller ]
+        [ non-primitive-unmarshaller ]
-        [ struct-unmarshaller ] if
+        [ drop [ ] ]
-    ] if* ;
+    } 1|| ;
 
 : out-arg-unmarshaller ( type -- quot )
     dup pointer-to-non-const-primitive?

extra/combinators/tuple/tuple-docs.factor

@@ -0,0 +1,43 @@
+! (c)2009 Joe Groff bsd license
+USING: assocs classes help.markup help.syntax kernel math
+quotations strings ;
+IN: combinators.tuple
+
+HELP: 2make-tuple
+{ $values
+    { "x" object } { "y" object } { "class" class } { "assoc" assoc }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: 3make-tuple
+{ $values
+    { "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: make-tuple
+{ $values
+    { "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: nmake-tuple
+{ $values
+    { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ;
+
+{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words
+
+ARTICLE: "combinators.tuple" "Tuple-constructing combinators"
+"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects."
+{ $subsection make-tuple }
+{ $subsection 2make-tuple }
+{ $subsection 3make-tuple }
+{ $subsection nmake-tuple }
+;
+
+ABOUT: "combinators.tuple"

extra/combinators/tuple/tuple.factor

@@ -0,0 +1,29 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs classes.tuple generalizations kernel
+locals quotations sequences ;
+IN: combinators.tuple
+
+<PRIVATE
+
+:: (tuple-slot-quot) ( slot assoc n -- quot )
+    slot name>> assoc at [
+        slot initial>> :> initial
+        { n ndrop initial } >quotation
+    ] unless* ;
+
+PRIVATE>
+
+MACRO:: nmake-tuple ( class assoc n -- )
+    class all-slots [ assoc n (tuple-slot-quot) ] map :> quots
+    class <wrapper> :> \class
+    { quots n ncleave \class boa } >quotation ;
+    
+: make-tuple ( x class assoc -- tuple )
+    1 nmake-tuple ; inline
+
+: 2make-tuple ( x y class assoc -- tuple )
+    2 nmake-tuple ; inline
+
+: 3make-tuple ( x y z class assoc -- tuple )
+    3 nmake-tuple ; inline
+

extra/constructors/constructors-tests.factor

@@ -29,58 +29,15 @@ CONSTRUCTOR: ct1 ( a -- obj )
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct2 ( a b -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct3 ( a b c -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct4 ( a b c d -- obj )
-    initialize-ct3
     [ 1 + ] change-a ;
 
 [ 1001 ] [ 1000 <ct1> a>> ] unit-test
 [ 2 ] [ 0 0 <ct2> a>> ] unit-test
-[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: rofl a b c ;
-CONSTRUCTOR: rofl ( b c a  -- obj ) ;
-
-[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
-
-
-TUPLE: default { a integer initial: 0 } ;
-
-CONSTRUCTOR: default ( -- obj ) ;
-
-[ 0 ] [ <default> a>> ] unit-test
-
-
-TUPLE: inherit1 a ;
-TUPLE: inherit2 < inherit1 a ;
-
-CONSTRUCTOR: inherit2 ( a -- obj ) ;
-
-[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
-
-
-TUPLE: inherit3 hp max-hp ;
-TUPLE: inherit4 < inherit3 ;
-TUPLE: inherit5 < inherit3 ;
-
-CONSTRUCTOR: inherit3 ( -- obj )
-    dup max-hp>> >>hp ;
-
-BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
-    10 >>max-hp ;
-
-[ 10 ] [ <inherit4> hp>> ] unit-test
-
-FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
-    5 >>hp
-    10 >>max-hp ;
-
-[ 5 ] [ <inherit5> hp>> ] unit-test

extra/constructors/constructors.factor

@@ -43,12 +43,7 @@ MACRO:: slots>constructor ( class slots -- quot )
     class def define-initializer
     class effect in>> '[ _ _ slots>constructor ] ;
 
-:: define-constructor ( constructor-word class effect def -- )
+:: define-constructor ( constructor-word class effect def reverse? -- )
-    constructor-word class effect def (define-constructor)
-    class lookup-initializer
-    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
-
-:: define-auto-constructor ( constructor-word class effect def reverse? -- )
     constructor-word class effect def (define-constructor)
     class superclasses [ lookup-initializer ] map sift
     reverse? [ reverse ] when
@@ -60,9 +55,6 @@ MACRO:: slots>constructor ( class slots -- quot )
 : parse-constructor ( -- class word effect def )
     scan-constructor complete-effect parse-definition ;
 
-SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
+SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
-SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
-SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
 
 "initializers" create-vocab drop

extra/gpu/buffers/buffers-docs.factor

@@ -10,6 +10,13 @@ HELP: <buffer-ptr>
 }
 { $description "Constructs a " { $link buffer-ptr } " tuple." } ;
 
+HELP: <buffer-range>
+{ $values
+    { "buffer" buffer } { "offset" integer } { "size" integer }
+    { "buffer-range" buffer-range }
+}
+{ $description "Constructs a " { $link buffer-range } " tuple." } ;
+
 HELP: <buffer>
 { $values
     { "upload" buffer-upload-pattern }
@@ -52,6 +59,7 @@ HELP: buffer-kind
 { "An " { $link index-buffer } " is used to store indexes into a vertex array." }
 { "A " { $link pixel-unpack-buffer } " is used as a source for updating texture image data." }
 { "A " { $link pixel-pack-buffer } " is used as a destination for reading texture or framebuffer image data." }
+{ "A " { $link transform-feedback-buffer } " is used as a destination for transform feedback output from a vertex shader." }
 } }
 { $notes "The " { $snippet "pixel-unpack-buffer" } " and " { $snippet "pixel-pack-buffer" } " kinds require OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
 
@@ -62,6 +70,30 @@ HELP: buffer-ptr
 { { $snippet "offset" } " is an integer offset from the beginning of the buffer." }
 } } ;
 
+HELP: buffer-ptr>range
+{ $values
+    { "buffer-ptr" buffer-ptr }
+    { "buffer-range" buffer-range }
+}
+{ $description "Converts a " { $link buffer-ptr } " into a " { $link buffer-range } " spanning from the " { $snippet "offset" } " referenced by the " { $snippet "buffer-ptr" } " to the end of the underlying " { $link buffer } "." } ;
+
+HELP: buffer-range
+{ $class-description "A " { $snippet "buffer-range" } " references a subset of a " { $link buffer } " object's memory. " { $snippet "buffer-range" } "s are tuples with the following slots:"
+{ $list
+{ { $snippet "buffer" } " is the " { $link buffer } " object being referenced." }
+{ { $snippet "offset" } " is an integer offset from the beginning of the buffer to the beginning of the referenced range." }
+{ { $snippet "size" } " is the integer length from the beginning offset to the end of the referenced range." }
+} } ;
+
+{ buffer-ptr buffer-range } related-words
+
+HELP: buffer-size
+{ $values
+    { "buffer" buffer }
+    { "size" integer }
+}
+{ $description "Returns the size in bytes of the memory currently allocated for a " { $link buffer } " object." } ;
+
 HELP: buffer-upload-pattern
 { $class-description { $snippet "buffer-upload-pattern" } " values aid the graphics driver in optimizing access to " { $link buffer } " objects by declaring the frequency with which the buffer will be supplied new data."
 { $list
@@ -148,6 +180,10 @@ HELP: stream-upload
 
 { dynamic-upload static-upload stream-upload } related-words
 
+HELP: transform-feedback-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to receive transform feedback output from a render job." }
+{ $notes "Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
+
 HELP: update-buffer
 { $values
     { "buffer-ptr" buffer-ptr } { "size" integer } { "data" { $maybe c-ptr } }
@@ -157,7 +193,7 @@ HELP: update-buffer
 HELP: vertex-buffer
 { $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to provide vertex attribute information to a vertex array." } ;
 
-{ index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer } related-words
+{ index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer transform-feedback-buffer } related-words
 
 HELP: with-mapped-buffer
 { $values
@@ -165,7 +201,7 @@ HELP: with-mapped-buffer
 }
 { $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
 
-{ allocate-buffer update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
+{ allocate-buffer buffer-size update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
 
 HELP: write-access
 { $class-description "This " { $link buffer-access-mode } " value requests write-only access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
@@ -183,6 +219,7 @@ ARTICLE: "gpu.buffers" "Buffer objects"
 { $subsection buffer-usage-pattern }
 "Referencing buffer data:"
 { $subsection buffer-ptr }
+{ $subsection buffer-range }
 "Manipulating buffer data:"
 { $subsection allocate-buffer }
 { $subsection update-buffer }

extra/gpu/buffers/buffers.factor

@@ -15,7 +15,8 @@ VARIANT: buffer-access-mode
 
 VARIANT: buffer-kind
     vertex-buffer index-buffer
-    pixel-unpack-buffer pixel-pack-buffer ;
+    pixel-unpack-buffer pixel-pack-buffer
+    transform-feedback-buffer ;
 
 TUPLE: buffer < gpu-object 
     { upload-pattern buffer-upload-pattern }
@@ -52,8 +53,15 @@ TUPLE: buffer < gpu-object
         { index-buffer [ GL_ELEMENT_ARRAY_BUFFER ] }
         { pixel-unpack-buffer [ GL_PIXEL_UNPACK_BUFFER ] }
         { pixel-pack-buffer [ GL_PIXEL_PACK_BUFFER ] }
+        { transform-feedback-buffer [ GL_TRANSFORM_FEEDBACK_BUFFER ] }
     } case ; inline
 
+: get-buffer-int ( target enum -- value )
+    0 <int> [ glGetBufferParameteriv ] keep *int ;
+
+: bind-buffer ( buffer -- target )
+    [ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ;
+
 PRIVATE>
 
 M: buffer dispose
@@ -64,11 +72,22 @@ TUPLE: buffer-ptr
     { offset integer read-only } ;
 C: <buffer-ptr> buffer-ptr
 
+TUPLE: buffer-range < buffer-ptr
+    { size integer read-only } ;
+C: <buffer-range> buffer-range
+
 UNION: gpu-data-ptr buffer-ptr c-ptr ;
 
+: buffer-size ( buffer -- size )
+    bind-buffer GL_BUFFER_SIZE get-buffer-int ;
+
+: buffer-ptr>range ( buffer-ptr -- buffer-range )
+    [ buffer>> ] [ offset>> ] bi
+    2dup [ buffer-size ] dip -
+    buffer-range boa ; inline
+
 :: allocate-buffer ( buffer size initial-data -- )
-    buffer kind>> gl-target :> target
+    buffer bind-buffer :> target
-    target buffer handle>> glBindBuffer
     target size initial-data buffer gl-buffer-usage glBufferData ;
 
 : <buffer> ( upload usage kind size initial-data -- buffer )
@@ -81,15 +100,13 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ;
 
 :: update-buffer ( buffer-ptr size data -- )
     buffer-ptr buffer>> :> buffer
-    buffer kind>> gl-target :> target
+    buffer bind-buffer :> target
-    target buffer handle>> glBindBuffer
     target buffer-ptr offset>> size data glBufferSubData ;
 
 :: read-buffer ( buffer-ptr size -- data )
     buffer-ptr buffer>> :> buffer
-    buffer kind>> gl-target :> target
+    buffer bind-buffer :> target
     size <byte-array> :> data
-    target buffer handle>> glBindBuffer
     target buffer-ptr offset>> size data glGetBufferSubData
     data ;
 
@@ -102,9 +119,7 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ;
     size glCopyBufferSubData ;
 
 :: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
-    buffer kind>> gl-target :> target
+    buffer bind-buffer :> target
-
-    target buffer handle>> glBindBuffer
     target access gl-access glMapBuffer
 
     quot call

extra/gpu/demos/bunny/bunny.factor

@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
 USING: accessors alien.c-types arrays combinators combinators.short-circuit
 game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
 gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
@@ -52,22 +53,22 @@ VERTEX-FORMAT: bunny-vertex
 VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
 
 UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms
-    { "light_position" float-uniform 3 }
+    { "light-position" vec3-uniform  f }
-    { "color"          float-uniform 4 }
+    { "color"          vec4-uniform  f }
-    { "ambient"        float-uniform 4 }
+    { "ambient"        vec4-uniform  f }
-    { "diffuse"        float-uniform 4 }
+    { "diffuse"        vec4-uniform  f }
-    { "shininess"      float-uniform 1 } ;
+    { "shininess"      float-uniform f } ;
 
 UNIFORM-TUPLE: sobel-uniforms
-    { "texcoord_scale" float-uniform   2 }
+    { "texcoord-scale" vec2-uniform    f }
-    { "color_texture"  texture-uniform 1 }
+    { "color-texture"  texture-uniform f }
-    { "normal_texture" texture-uniform 1 }
+    { "normal-texture" texture-uniform f }
-    { "depth_texture"  texture-uniform 1 }
+    { "depth-texture"  texture-uniform f }
-    { "line_color"     float-uniform   4 } ; 
+    { "line-color"     vec4-uniform    f } ; 
 
 UNIFORM-TUPLE: loading-uniforms
-    { "texcoord_scale"  float-uniform   2 }
+    { "texcoord-scale"  vec2-uniform    f }
-    { "loading_texture" texture-uniform 1 } ;
+    { "loading-texture" texture-uniform f } ;
 
 : numbers ( str -- seq )
     " " split [ string>number ] map sift ;
@@ -229,16 +230,14 @@ BEFORE: bunny-world begin-world
             { depth-attachment 1.0 }
         } clear-framebuffer
     ] [
-        render-set new
+        {
-            triangles-mode >>primitive-mode
+            { "primitive-mode"     [ drop triangles-mode ] }
-            { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments
+            { "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] }
-            swap {
+            { "uniforms"           [ <bunny-uniforms> ] }
-                [ <bunny-uniforms> >>uniforms ]
+            { "vertex-array"       [ bunny>> vertex-array>> ] }
-                [ bunny>> vertex-array>> >>vertex-array ]
+            { "indexes"            [ bunny>> index-elements>> ] }
-                [ bunny>> index-elements>> >>indexes ]
+            { "framebuffer"        [ sobel>> framebuffer>> ] }
-                [ sobel>> framebuffer>> >>framebuffer ]
+        } <render-set> render
-            } cleave
-        render
     ] bi ;
 
 : <sobel-uniforms> ( sobel -- uniforms )
@@ -250,13 +249,12 @@ BEFORE: bunny-world begin-world
 : draw-sobel ( world -- )
     T{ depth-state { comparison f } } set-gpu-state*
 
-    render-set new
+    sobel>> {
-        triangle-strip-mode >>primitive-mode
+        { "primitive-mode" [ drop triangle-strip-mode ] }
-        T{ index-range f 0 4 } >>indexes
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
-        swap sobel>>
+        { "uniforms"       [ <sobel-uniforms> ] }
-        [ <sobel-uniforms> >>uniforms ]
+        { "vertex-array"   [ vertex-array>> ] }
-        [ vertex-array>> >>vertex-array ] bi
+    } <render-set> render ;
-    render ;
 
 : draw-sobeled-bunny ( world -- )
     [ draw-bunny ] [ draw-sobel ] bi ;
@@ -264,13 +262,12 @@ BEFORE: bunny-world begin-world
 : draw-loading ( world -- )
     T{ depth-state { comparison f } } set-gpu-state*
 
-    render-set new
+    loading>> {
-        triangle-strip-mode >>primitive-mode
+        { "primitive-mode" [ drop triangle-strip-mode ] }
-        T{ index-range f 0 4 } >>indexes
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
-        swap loading>>
+        { "uniforms"       [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] }
-        [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ]
+        { "vertex-array"   [ vertex-array>> ] }
-        [ vertex-array>> >>vertex-array ] bi
+    } <render-set> render ;
-    render ;
 
 M: bunny-world draw-world*
     dup bunny>>

extra/gpu/demos/raytrace/raytrace.factor

@@ -1,7 +1,7 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays game-loop game-worlds generalizations
+USING: accessors arrays combinators.tuple game-loop game-worlds
-gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel
+generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd
-literals math math.matrices math.order math.vectors
+kernel literals math math.matrices math.order math.vectors
 method-chains sequences ui ui.gadgets ui.gadgets.worlds
 ui.pixel-formats ;
 IN: gpu.demos.raytrace
@@ -11,31 +11,21 @@ GLSL-SHADER-FILE: raytrace-fragment-shader fragment-shader "raytrace.f.glsl"
 GLSL-PROGRAM: raytrace-program
     raytrace-vertex-shader raytrace-fragment-shader ;
 
+UNIFORM-TUPLE: sphere-uniforms
+    { "center" vec3-uniform  f }
+    { "radius" float-uniform f }
+    { "color"  vec4-uniform  f } ;
+
 UNIFORM-TUPLE: raytrace-uniforms
-    { "mv_inv_matrix" float-uniform { 4 4 } }
+    { "mv-inv-matrix"    mat4-uniform f }
-    { "fov" float-uniform 2 }
+    { "fov"              vec2-uniform f }
-
-    { "spheres[0].center" float-uniform 3 }
-    { "spheres[0].radius" float-uniform 1 }
-    { "spheres[0].color"  float-uniform 4 }
-
-    { "spheres[1].center" float-uniform 3 }
-    { "spheres[1].radius" float-uniform 1 }
-    { "spheres[1].color"  float-uniform 4 }
-
-    { "spheres[2].center" float-uniform 3 }
-    { "spheres[2].radius" float-uniform 1 }
-    { "spheres[2].color"  float-uniform 4 }
-
-    { "spheres[3].center" float-uniform 3 }
-    { "spheres[3].radius" float-uniform 1 }
-    { "spheres[3].color"  float-uniform 4 }
     
-    { "floor_height"   float-uniform 1 }
+    { "spheres"          sphere-uniforms 4 }
-    { "floor_color[0]" float-uniform 4 }
+
-    { "floor_color[1]" float-uniform 4 }
+    { "floor-height"     float-uniform f }
-    { "background_color" float-uniform 4 }
+    { "floor-color"      vec4-uniform 2 }
-    { "light_direction" float-uniform 3 } ;
+    { "background-color" vec4-uniform f }
+    { "light-direction"  vec3-uniform f } ;
 
 CONSTANT: reflection-color { 1.0 0.0 1.0 0.0 }
 
@@ -64,12 +54,10 @@ TUPLE: raytrace-world < wasd-world
     [ fov>> ]
     [
         spheres>>
-        [ [ sphere-center ] [ radius>> ] [ color>> ] tri 3array ] map
+        [ [ sphere-center ] [ radius>> ] [ color>> ] tri sphere-uniforms boa ] map
-        first4 [ first3 ] 4 napply
     ] tri
     -30.0 ! floor_height
-    { 1.0 0.0 0.0 1.0 } ! floor_color[0]
+    { { 1.0 0.0 0.0 1.0 } { 1.0 1.0 1.0 1.0 } } ! floor_color
-    { 1.0 1.0 1.0 1.0 } ! floor_color[1]
     { 0.15 0.15 1.0 1.0 } ! background_color
     { 0.0 -1.0 -0.1 } ! light_direction
     raytrace-uniforms boa ;
@@ -97,13 +85,12 @@ AFTER: raytrace-world tick*
     spheres>> [ tick-sphere ] each ;
 
 M: raytrace-world draw-world*
-    render-set new
+    {
-        triangle-strip-mode >>primitive-mode
+        { "primitive-mode" [ drop triangle-strip-mode    ] }
-        T{ index-range f 0 4 } >>indexes
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
-        swap
+        { "uniforms"       [ <sphere-uniforms>           ] }
-        [ <sphere-uniforms> >>uniforms ]
+        { "vertex-array"   [ vertex-array>>              ] }
-        [ vertex-array>> >>vertex-array ] bi
+    } <render-set> render ;
-    render ;
 
 M: raytrace-world pref-dim* drop { 1024 768 } ;
 M: raytrace-world tick-length drop 1000 30 /i ;

extra/gpu/render/render-docs.factor

@@ -34,20 +34,13 @@ HELP: <multi-index-range>
 }
 { $description "Constructs a " { $link multi-index-range } " tuple." } ;
 
-HELP: <vertex-array>
-{ $values
-    { "program-instance" program-instance } { "vertex-formats" "a list of " { $link buffer-ptr } "/" { $link vertex-format } " pairs" }
-    { "vertex-array" vertex-array }
-}
-{ $description "Creates a new " { $link vertex-array } " to feed data to " { $snippet "program-instance" } " from the set of " { $link buffer } "s specified in " { $snippet "vertex-formats" } "." } ;
-
 HELP: UNIFORM-TUPLE:
 { $syntax <" UNIFORM-TUPLE: class-name
     { "slot" uniform-type dimension }
     { "slot" uniform-type dimension }
     ...
     { "slot" uniform-type dimension } ; "> }
-{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " defines the vector or matrix dimensions; for example, a slot " { $snippet "{ \"foo\" float-uniform { 2 2 } }" } " will define a slot " { $snippet "foo" } " as a 2x2 matrix of floats."
+{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " specifies an array length if not " { $link f } "."
 $nl
 "Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
 { $list
@@ -55,34 +48,40 @@ $nl
 { { $link float-uniform } "s take their values from Factor " { $link float } "s." }
 { { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
 { { $link texture-uniform } "s take their values from " { $link texture } " objects." }
-{ "Vector uniforms are passed as Factor " { $link sequence } "s of the corresponding component type." }
+{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type."
-{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } }
+    { $list
+    { "Float vector types: " { $link vec2-uniform } ", " { $link vec3-uniform } ", " { $link vec4-uniform } }
+    { "Integer vector types: " { $link ivec2-uniform } ", " { $link ivec3-uniform } ", " { $link ivec4-uniform } }
+    { "Unsigned integer vector types: " { $link uvec2-uniform } ", " { $link uvec3-uniform } ", " { $link uvec4-uniform } }
+    { "Boolean vector types: " { $link bvec2-uniform } ", " { $link bvec3-uniform } ", " { $link bvec4-uniform } }
+    }
+}
+{ "Matrix uniforms take their values from row-major Factor " { $link sequence } "s of sequences of floats. Matrix types are:" 
+    { $list
+    { { $link mat2-uniform } ", " { $link mat2x3-uniform } ", " { $link mat2x4-uniform } }
+    { { $link mat3x2-uniform } ", " { $link mat3-uniform } ", " { $link mat3x4-uniform } }
+    { { $link mat4x2-uniform } ", " { $link mat4x3-uniform } ", " { $link mat4-uniform } }
+    }
+"Rectangular matrix type names are column x row."
+}
+{ "Uniform slots can also be defined as other " { $snippet "uniform-tuple" } " types to bind uniform structures. The uniform structure will take its value from the slots of a tuple of the given type." }
+{ "Array uniforms are passed as Factor sequences of the corresponding value type above." }
+}
+$nl
 "A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors."
 } ;
 
-HELP: VERTEX-FORMAT:
-{ $syntax <" VERTEX-FORMAT: format-name
-    { "attribute"/f component-type dimension normalize? }
-    { "attribute"/f component-type dimension normalize? }
-    ...
-    { "attribute"/f component-type dimension normalize? } ; "> }
-{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
-
-HELP: VERTEX-STRUCT:
-{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
-{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
-
 HELP: bool-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "bool" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ;
 
-HELP: buffer>vertex-array
+HELP: bvec2-uniform
-{ $values
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ;
-    { "vertex-buffer" buffer } { "program-instance" program-instance } { "format" vertex-format }
-    { "vertex-array" vertex-array }
-}
-{ $description "Creates a new " { $link vertex-array } " from the entire contents of a single " { $link buffer } " in a single " { $link vertex-format } " for use with " { $snippet "program-instance" } "." } ;
 
-{ vertex-array <vertex-array> buffer>vertex-array } related-words
+HELP: bvec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component boolean vector uniform parameter." } ;
+
+HELP: bvec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component boolean vector uniform parameter." } ;
 
 HELP: define-uniform-tuple
 { $values
@@ -90,22 +89,8 @@ HELP: define-uniform-tuple
 }
 { $description "Defines a new " { $link uniform-tuple } " as a subclass of " { $snippet "superclass" } " with the slots specified by the " { $link uniform } " tuple values in " { $snippet "uniforms" } ". The runtime equivalent of " { $link POSTPONE: UNIFORM-TUPLE: } ". This word must be called inside a compilation unit." } ;
 
-HELP: define-vertex-format
-{ $values
-    { "class" class } { "vertex-attributes" sequence }
-}
-{ $description "Defines a new " { $link vertex-format } " with the binary format specified by the " { $link vertex-attribute } " tuple values in " { $snippet "vertex-attributes" } ". The runtime equivalent of " { $link POSTPONE: VERTEX-FORMAT: } ". This word must be called inside a compilation unit." } ;
-
-HELP: define-vertex-struct
-{ $values
-    { "struct-name" string } { "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." } ;
-
 HELP: float-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ;
-
-{ bool-uniform int-uniform float-uniform texture-uniform } related-words
 
 { index-elements index-range multi-index-elements multi-index-range } related-words
 
@@ -130,7 +115,7 @@ HELP: index-type
 { index-type ubyte-indexes ushort-indexes uint-indexes } related-words
 
 HELP: int-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "int" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a signed integer uniform parameter." } ;
 
 HELP: invalid-uniform-type
 { $values
@@ -138,6 +123,15 @@ HELP: invalid-uniform-type
 }
 { $description "Throws an error indicating that a slot of a " { $link uniform-tuple } " has been declared to have an invalid type." } ;
 
+HELP: ivec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component integer vector uniform parameter." } ;
+
+HELP: ivec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component integer vector uniform parameter." } ;
+
+HELP: ivec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component integer vector uniform parameter." } ;
+
 HELP: lines-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a line from each pair of indexed vertex array elements." } ;
 
@@ -147,6 +141,33 @@ HELP: line-loop-mode
 HELP: line-strip-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected strip of lines from each consecutive pair of indexed vertex array elements." } ;
 
+HELP: mat2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2x2 square float matrix uniform parameter." } ;
+
+HELP: mat2x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat2x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat3x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3x3 square float matrix uniform parameter." } ;
+
+HELP: mat3x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat4x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat4x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4x4 square float matrix uniform parameter." } ;
+
 HELP: multi-index-elements
 { $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple arrays of indexes in CPU or GPU memory."
 { $list
@@ -193,14 +214,16 @@ HELP: render-set
 { "The " { $snippet "uniforms" } " slot contains a " { $link uniform-tuple } " with values for the shader program's uniform parameters." }
 { "The " { $snippet "indexes" } " slot contains one of the " { $link vertex-indexes } " types and selects elements from the vertex array to be rendered." }
 { "The " { $snippet "instances" } " slot, if not " { $link f } ", instructs the GPU to render several instances of the same set of vertexes. Instancing requires OpenGL 3.1 or one of the " { $snippet "GL_EXT_draw_instanced" } " or " { $snippet "GL_ARB_draw_instanced" } " extensions." }
-{ "The " { $snippet "framebuffer" } " slot determines the target for the rendering output. Either the " { $link system-framebuffer } " or a user-created " { $link framebuffer } " object can be specified. User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions." }
+{ "The " { $snippet "framebuffer" } " slot determines the target for the rendering output. Either the " { $link system-framebuffer } " or a user-created " { $link framebuffer } " object can be specified. " { $link f } " can also be specified to disable rasterization and only run the vertex transformation rendering stage." }
-{ "The " { $snippet "output-attachments" } " slot specifies which of the framebuffer's " { $link color-attachment-ref } "s to write the fragment shader's color output to. If the shader uses " { $snippet "gl_FragColor" } " or " { $snippet "gl_FragData[n]" } " to write its output, then " { $snippet "output-attachments" } " should be an array of " { $link color-attachment-ref } "s, and the output to color attachment binding is determined positionally. If the shader uses named output values, then " { $snippet "output-attachments" } " should be a list of string/" { $link color-attachment-ref } " pairs, mapping output names to color attachments. Named output values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension." }
+{ "The " { $snippet "output-attachments" } " slot specifies which of the framebuffer's " { $link color-attachment-ref } "s to write the fragment shader's color output to. If the shader uses " { $snippet "gl_FragColor" } " or " { $snippet "gl_FragData[n]" } " to write its output, then " { $snippet "output-attachments" } " should be an array of " { $link color-attachment-ref } "s, and the output to color attachment binding is determined positionally. If the shader uses named output values, then " { $snippet "output-attachments" } " should be a list of string/" { $link color-attachment-ref } " pairs, mapping output names to color attachments." }
-} } ;
+{ "The " { $snippet "transform-feedback-output" } " slot specifies a target for transform feedback output from the vertex shader: either an entire " { $link buffer } ", a " { $link buffer-range } " subset, or a " { $link buffer-ptr } " offset into the buffer. If " { $link f } ", no transform feedback output is collected. The shader program associated with " { $snippet "vertex-array" } " must have a transform feedback output format specified." }
+} }
+{ $notes "User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions. Disabling rasterization requires OpenGL 3.0 or the " { $snippet "GL_EXT_transform_feedback" } " extension. Named output-attachment values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension. Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
 
 { render render-set } related-words
 
 HELP: texture-uniform
-{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a texture. The dimension of the corresponding " { $link uniform } " slot must be " { $snippet "1" } "." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a texture uniform parameter." } ;
 
 HELP: triangle-fan-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a fan of triangles using the first indexed vertex array element and every subsequent consecutive pair of elements." } ;
@@ -218,7 +241,7 @@ HELP: uint-indexes
 { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of four-byte unsigned int indexes." } ;
 
 HELP: uint-uniform
-{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a scalar or vector of unsigned integers." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to an unsigned integer uniform parameter." } ;
 
 HELP: uniform
 { $class-description "Values of this tuple type are passed to " { $link define-uniform-tuple } " to define a new " { $link uniform-tuple } " type." } ;
@@ -229,35 +252,28 @@ HELP: uniform-tuple
 HELP: uniform-type
 { $class-description { $snippet "uniform-type" } " values are used as part of a " { $link POSTPONE: UNIFORM-TUPLE: } " definition to define the types of uniform slots." } ;
 
-{ uniform-type bool-uniform int-uniform float-uniform texture-uniform uint-uniform } related-words
-
 HELP: ushort-indexes
 { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of two-byte unsigned short indexes." } ;
 
 { index-type ubyte-indexes ushort-indexes uint-indexes } related-words
 
-HELP: vertex-array
+HELP: uvec2-uniform
-{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <vertex-array> } " or " { $link buffer>vertex-array } " words." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component unsigned integer vector uniform parameter." } ;
 
-HELP: vertex-array-buffer
+HELP: uvec3-uniform
-{ $values
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component unsigned integer vector uniform parameter." } ;
-    { "vertex-array" vertex-array }
-    { "vertex-buffer" buffer }
-}
-{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
 
-HELP: vertex-attribute
+HELP: uvec4-uniform
-{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component unsigned integer vector uniform parameter." } ;
 
-HELP: vertex-format
+HELP: vec2-uniform
-{ $class-description "This class encompasses all vertex formats defined by " { $link POSTPONE: VERTEX-FORMAT: } ". A vertex format defines the binary layout of vertex attribute data in a " { $link buffer } " for use as part of a " { $link vertex-array } ". See the " { $link POSTPONE: VERTEX-FORMAT: } " documentation for details on how vertex formats are defined." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component float vector uniform parameter." } ;
 
-HELP: vertex-format-size
+HELP: vec3-uniform
-{ $values
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component float vector uniform parameter." } ;
-    { "format" vertex-format }
+
-    { "size" integer }
+HELP: vec4-uniform
-}
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component float vector uniform parameter." } ;
-{ $description "Returns the size in bytes of a set of vertex attributes in " { $snippet "format" } "." } ;
 
 HELP: vertex-indexes
 { $class-description "This class is a union of the following tuple types, any of which can be used as the " { $snippet "indexes" } " slot of a " { $link render-set } " to select elements from a " { $link vertex-array } " for rendering."
@@ -272,11 +288,6 @@ ARTICLE: "gpu.render" "Rendering"
 "The " { $vocab-link "gpu.render" } " vocabulary contains words for organizing and submitting data to the GPU for rendering."
 { $subsection render }
 { $subsection render-set }
-"Render data inside GPU " { $link buffer } "s is organized into " { $link vertex-array } "s for consumption by shader code:"
-{ $subsection vertex-array }
-{ $subsection <vertex-array> }
-{ $subsection buffer>vertex-array }
-{ $subsection POSTPONE: VERTEX-FORMAT: }
 { $link uniform-tuple } "s provide Factor types for containing and submitting shader uniform parameters:"
 { $subsection POSTPONE: UNIFORM-TUPLE: }
 ;

extra/gpu/render/render-tests.factor

@@ -0,0 +1,117 @@
+USING: accessors combinators gpu.render gpu.render.private kernel sequences tools.test ;
+IN: gpu.render.tests
+
+UNIFORM-TUPLE: two-textures
+    { "argyle"       texture-uniform f }
+    { "thread-count" float-uniform   f }
+    { "tweed"        texture-uniform f } ;
+
+UNIFORM-TUPLE: inherited-textures < two-textures
+    { "paisley" texture-uniform f } ;
+
+UNIFORM-TUPLE: array-of-textures < two-textures
+    { "plaids" texture-uniform 4 } ;
+
+UNIFORM-TUPLE: struct-containing-texture
+    { "threads" two-textures f } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-texture
+    { "threads" inherited-textures 3 } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-array-of-texture
+    { "threads" array-of-textures 2 } ;
+
+[  1 ] [ texture-uniform uniform-type-texture-units ] unit-test
+[  0 ] [ float-uniform uniform-type-texture-units ] unit-test
+[  2 ] [ two-textures uniform-type-texture-units ] unit-test
+[  3 ] [ inherited-textures uniform-type-texture-units ] unit-test
+[  6 ] [ array-of-textures uniform-type-texture-units ] unit-test
+[  2 ] [ struct-containing-texture uniform-type-texture-units ] unit-test
+[  9 ] [ array-of-struct-containing-texture uniform-type-texture-units ] unit-test
+[ 12 ] [ array-of-struct-containing-array-of-texture uniform-type-texture-units ] unit-test
+
+[ { [ ] } ] [ texture-uniform f uniform-texture-accessors ] unit-test
+
+[ { } ] [ float-uniform f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] } ] [ two-textures f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] [ paisley>> ] } ]
+[ inherited-textures f uniform-texture-accessors ] unit-test
+
+[ {
+    [ argyle>> ]
+    [ tweed>> ]
+    [ plaids>> {
+        [ 0 swap nth ]
+        [ 1 swap nth ]
+        [ 2 swap nth ]
+        [ 3 swap nth ]
+    } ]
+} ] [ array-of-textures f uniform-texture-accessors ] unit-test
+
+[ {
+    [ threads>> {
+        [ argyle>> ]
+        [ tweed>> ]
+    } ]
+} ] [ struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+    [ threads>> {
+        [ 0 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ paisley>> ]
+        } ]
+        [ 1 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ paisley>> ]
+        } ]
+        [ 2 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ paisley>> ]
+        } ]
+    } ]
+} ] [ array-of-struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+    [ threads>> {
+        [ 0 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ plaids>> {
+                [ 0 swap nth ]
+                [ 1 swap nth ]
+                [ 2 swap nth ]
+                [ 3 swap nth ]
+            } ]
+        } ]
+        [ 1 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ plaids>> {
+                [ 0 swap nth ]
+                [ 1 swap nth ]
+                [ 2 swap nth ]
+                [ 3 swap nth ]
+            } ]
+        } ]
+    } ]
+} ] [ array-of-struct-containing-array-of-texture f uniform-texture-accessors ] unit-test
+
+[ [
+    nip {
+        [ argyle>> 0 (bind-texture-unit) ]
+        [ tweed>> 1 (bind-texture-unit) ]
+        [ plaids>> {
+            [ 0 swap nth 2 (bind-texture-unit) ]
+            [ 1 swap nth 3 (bind-texture-unit) ]
+            [ 2 swap nth 4 (bind-texture-unit) ]
+            [ 3 swap nth 5 (bind-texture-unit) ]
+        } cleave ]
+    } cleave
+] ] [ array-of-textures [bind-uniform-textures] ] unit-test
+

extra/gpu/render/render.factor

@@ -1,37 +1,59 @@
 ! (c)2009 Joe Groff bsd license
 USING: accessors alien alien.c-types alien.structs arrays
-assocs classes.mixin classes.parser classes.singleton
+assocs classes classes.mixin classes.parser classes.singleton
-classes.tuple classes.tuple.private combinators destructors fry
+classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
 generic generic.parser gpu gpu.buffers gpu.framebuffers
-gpu.framebuffers.private gpu.shaders gpu.state gpu.textures
+gpu.framebuffers.private gpu.shaders gpu.shaders.private gpu.state
-gpu.textures.private half-floats images kernel lexer locals
+gpu.textures gpu.textures.private half-floats images kernel
-math math.order math.parser namespaces opengl opengl.gl parser
+lexer locals math math.order math.parser namespaces opengl
-quotations sequences slots sorting specialized-arrays.alien
+opengl.gl parser quotations sequences slots sorting
-specialized-arrays.float specialized-arrays.int
+specialized-arrays.alien specialized-arrays.float specialized-arrays.int
-specialized-arrays.uint strings ui.gadgets.worlds variants
+specialized-arrays.uint strings tr ui.gadgets.worlds variants
 vocabs.parser words ;
 IN: gpu.render
 
-UNION: ?string string POSTPONE: f ;
+UNION: ?integer integer POSTPONE: f ;
-UNION: uniform-dim integer sequence ;
-
-TUPLE: vertex-attribute
-    { name            ?string        read-only initial: f }
-    { component-type  component-type read-only initial: float-components }
-    { dim             integer        read-only initial: 4 }
-    { normalize?      boolean        read-only initial: f } ;
 
 VARIANT: uniform-type
     bool-uniform
+    bvec2-uniform
+    bvec3-uniform
+    bvec4-uniform
     uint-uniform
+    uvec2-uniform
+    uvec3-uniform
+    uvec4-uniform
     int-uniform
+    ivec2-uniform
+    ivec3-uniform
+    ivec4-uniform
     float-uniform
+    vec2-uniform
+    vec3-uniform
+    vec4-uniform
+
+    mat2-uniform
+    mat2x3-uniform
+    mat2x4-uniform
+
+    mat3x2-uniform
+    mat3-uniform
+    mat3x4-uniform
+
+    mat4x2-uniform
+    mat4x3-uniform
+    mat4-uniform
+
     texture-uniform ;
 
+ALIAS: mat2x2-uniform mat2-uniform
+ALIAS: mat3x3-uniform mat3-uniform
+ALIAS: mat4x4-uniform mat4-uniform
+
 TUPLE: uniform
-    { name         string       read-only initial: "" }
+    { name         string   read-only initial: "" }
-    { uniform-type uniform-type read-only initial: float-uniform }
+    { uniform-type class    read-only initial: float-uniform }
-    { dim          uniform-dim  read-only initial: 4 } ;
+    { dim          ?integer read-only initial: f } ;
 
 VARIANT: index-type
     ubyte-indexes
@@ -50,8 +72,6 @@ TUPLE: multi-index-range
 
 C: <multi-index-range> multi-index-range
 
-UNION: ?integer integer POSTPONE: f ;
-
 TUPLE: index-elements
     { ptr gpu-data-ptr read-only }
     { count integer read-only }
@@ -84,52 +104,12 @@ VARIANT: primitive-mode
     triangle-strip-mode
     triangle-fan-mode ;
 
-MIXIN: vertex-format
-
 TUPLE: uniform-tuple ;
 
-GENERIC: vertex-format-size ( format -- size )
-
 ERROR: invalid-uniform-type uniform ;
 
 <PRIVATE
 
-: gl-vertex-type ( component-type -- gl-type )
-    {
-        { ubyte-components          [ GL_UNSIGNED_BYTE  ] }
-        { ushort-components         [ GL_UNSIGNED_SHORT ] }
-        { uint-components           [ GL_UNSIGNED_INT   ] }
-        { half-components           [ GL_HALF_FLOAT     ] }
-        { float-components          [ GL_FLOAT          ] }
-        { byte-integer-components   [ GL_BYTE           ] }
-        { short-integer-components  [ GL_SHORT          ] }
-        { int-integer-components    [ GL_INT            ] }
-        { ubyte-integer-components  [ GL_UNSIGNED_BYTE  ] }
-        { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
-        { uint-integer-components   [ GL_UNSIGNED_INT   ] }
-    } case ;
-
-: vertex-type-size ( component-type -- size ) 
-    {
-        { ubyte-components          [ 1 ] }
-        { ushort-components         [ 2 ] }
-        { uint-components           [ 4 ] }
-        { half-components           [ 2 ] }
-        { float-components          [ 4 ] }
-        { byte-integer-components   [ 1 ] }
-        { short-integer-components  [ 2 ] }
-        { int-integer-components    [ 4 ] }
-        { ubyte-integer-components  [ 1 ] }
-        { ushort-integer-components [ 2 ] }
-        { uint-integer-components   [ 4 ] }
-    } case ;
-
-: vertex-attribute-size ( vertex-attribute -- size )
-    [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
-
-: vertex-attributes-size ( vertex-attributes -- size )
-    [ vertex-attribute-size ] [ + ] map-reduce ;
-
 : gl-index-type ( index-type -- gl-index-type )
     {
         { ubyte-indexes  [ GL_UNSIGNED_BYTE  ] }
@@ -180,58 +160,8 @@ M: multi-index-elements render-vertex-indexes
     bi*
     GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
 
-: (bind-texture-unit) ( texture-unit texture -- )
+: (bind-texture-unit) ( texture texture-unit -- )
-    [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
+    swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
-
-:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
-    vertex-attribute name>>                 :> name
-    vertex-attribute component-type>>       :> type
-    type gl-vertex-type                     :> gl-type
-    vertex-attribute dim>>                  :> dim
-    vertex-attribute normalize?>> >c-bool   :> normalize?
-    vertex-attribute vertex-attribute-size  :> size
-
-    stride offset size +
-    {
-        { [ name not ] [ [ 2drop ] ] }
-        {
-            [ type unnormalized-integer-components? ]
-            [
-                {
-                    name attribute-index [ glEnableVertexAttribArray ] keep
-                    dim gl-type stride offset
-                } >quotation :> dip-block
-                
-                { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
-            ]
-        }
-        [
-            {
-                name attribute-index [ glEnableVertexAttribArray ] keep
-                dim gl-type normalize? stride offset
-            } >quotation :> dip-block
-
-            { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
-        ]
-    } cond ;
-
-:: [bind-vertex-format] ( vertex-attributes -- quot )
-    vertex-attributes vertex-attributes-size :> stride
-    stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
-    { attributes-cleave 2cleave } >quotation :> with-block
-
-    { drop vertex-buffer with-block with-buffer-ptr } >quotation ; 
-
-GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
-
-: define-vertex-format-methods ( class vertex-attributes -- )
-    [
-        [ \ bind-vertex-format create-method-in ] dip
-        [bind-vertex-format] define
-    ] [
-        [ \ vertex-format-size create-method-in ] dip
-        [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
-    ] 2bi ;
 
 GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
 GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
@@ -242,96 +172,204 @@ M: uniform-tuple bind-uniforms
     2drop ;
 
 : uniform-slot-type ( uniform -- type )
-    dup dim>> 1 = [
+    dup dim>> [ drop sequence ] [
         uniform-type>> {
             { bool-uniform    [ boolean ] }
             { uint-uniform    [ integer ] }
             { int-uniform     [ integer ] }
             { float-uniform   [ float   ] }
             { texture-uniform [ texture ] }
+            [ drop sequence ]
         } case
-    ] [ drop sequence ] if ;
+    ] if ;
 
 : uniform>slot ( uniform -- slot )
     [ name>> ] [ uniform-slot-type ] bi 2array ;
 
-:: [bind-uniform-texture] ( uniform index -- quot )
+: uniform-type-texture-units ( uniform-type -- units )
-    uniform name>> reader-word :> value>>-word
+    dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
-    { index swap value>>-word (bind-texture-unit) } >quotation ;
 
-:: [bind-uniform-textures] ( superclass uniforms -- quot )
+: all-uniform-tuple-slots ( class -- slots )
-    superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
+    dup "uniform-tuple-slots" word-prop 
-    superclass \ bind-uniform-textures method :> next-method
+    [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
-    uniforms
-        [ uniform-type>> texture-uniform = ] filter
-        [ first-texture-unit + [bind-uniform-texture] ] map-index
-        :> texture-uniforms-cleave
 
-    {
+DEFER: uniform-texture-accessors
-        2dup next-method
-        nip texture-uniforms-cleave cleave
-    } >quotation ;
 
-:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
+: uniform-type-texture-accessors ( uniform-type -- accessors )
-    uniform name>> :> name
+    texture-uniform = [ { [ ] } ] [ { } ] if ;
+
+: uniform-slot-texture-accessor ( uniform -- accessor )
+    [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi
+    dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ;
+
+: uniform-tuple-texture-accessors ( uniform-type -- accessors )
+    all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter
+    [ uniform-slot-texture-accessor ] map ;
+
+: uniform-texture-accessors ( uniform-type dim -- accessors )
+    [
+        dup uniform-type?
+        [ uniform-type-texture-accessors ]
+        [ uniform-tuple-texture-accessors ] if
+    ] [
+        2dup swap empty? not and [
+            iota [
+                [ swap nth ] swap prefix
+                over length 1 = [ swap first append ] [ swap suffix ] if
+            ] with map
+        ] [ drop ] if
+    ] bi* ;
+
+: texture-accessor>cleave ( unit accessors -- unit' cleaves )
+    dup last sequence?
+    [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
+    [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
+
+: [bind-uniform-textures] ( class -- quot )
+    f uniform-texture-accessors
+    0 swap [ texture-accessor>cleave ] map nip
+    \ nip swap \ cleave [ ] 3sequence ;
+
+DEFER: [bind-uniform-tuple]
+
+:: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
     { name uniform-index } >quotation :> index-quot
-    uniform name>> reader-word 1quotation :> value>>-quot
     { index-quot value>>-quot bi* } >quotation :> pre-quot
 
-    uniform [ uniform-type>> ] [ dim>> ] bi 2array H{
+    type H{
-        { { bool-uniform  1 } [ >c-bool glUniform1i  ] }
+        { bool-uniform  { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv  } }
-        { { int-uniform   1 } [ glUniform1i  ] }
+        { int-uniform   { dim swap >int-array   glUniform1iv  } }
-        { { uint-uniform  1 } [ glUniform1ui ] }
+        { uint-uniform  { dim swap >uint-array  glUniform1uiv } }
-        { { float-uniform 1 } [ glUniform1f  ] }
+        { float-uniform { dim swap >float-array glUniform1fv  } }
 
-        { { bool-uniform  2 } [ [ >c-bool ] map first2 glUniform2i  ] }
+        { bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv  } }
-        { { int-uniform   2 } [ first2 glUniform2i  ] }
+        { ivec2-uniform { dim swap int-array{ }   concat-as glUniform2i  } }
-        { { uint-uniform  2 } [ first2 glUniform2ui ] }
+        { uvec2-uniform { dim swap uint-array{ }  concat-as glUniform2ui } }
-        { { float-uniform 2 } [ first2 glUniform2f  ] }
+        { vec2-uniform  { dim swap float-array{ } concat-as glUniform2f  } }
 
-        { { bool-uniform  3 } [ [ >c-bool ] map first3 glUniform3i  ] }
+        { bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv  } }
-        { { int-uniform   3 } [ first3 glUniform3i  ] }
+        { ivec3-uniform { dim swap int-array{ }   concat-as glUniform3i  } }
-        { { uint-uniform  3 } [ first3 glUniform3ui ] }
+        { uvec3-uniform { dim swap uint-array{ }  concat-as glUniform3ui } }
-        { { float-uniform 3 } [ first3 glUniform3f  ] }
+        { vec3-uniform  { dim swap float-array{ } concat-as glUniform3f  } }
 
-        { { bool-uniform  4 } [ [ >c-bool ] map first4 glUniform4i  ] }
+        { bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv  } }
-        { { int-uniform   4 } [ first4 glUniform4i  ] }
+        { ivec4-uniform { dim swap int-array{ }   concat-as glUniform4iv  } }
-        { { uint-uniform  4 } [ first4 glUniform4ui ] }
+        { uvec4-uniform { dim swap uint-array{ }  concat-as glUniform4uiv } }
-        { { float-uniform 4 } [ first4 glUniform4f  ] }
+        { vec4-uniform  { dim swap float-array{ } concat-as glUniform4fv  } }
 
-        { { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv   ] }
+        { mat2-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv   } }
-        { { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] }
+        { mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } }
-        { { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] }
+        { mat2x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x4fv } }
+                                                                 
+        { mat3x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x2fv } }
+        { mat3-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3fv   } }
+        { mat3x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x4fv } }
+                                                                  
+        { mat4x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x2fv } }
+        { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } }
+        { mat4-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv   } }
 
-        { { float-uniform { 2 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x2fv ] }
+        { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
-        { { float-uniform { 3 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3fv   ] }
-        { { float-uniform { 4 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x4fv ] }
-
-        { { float-uniform { 2 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x2fv ] }
-        { { float-uniform { 3 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x3fv ] }
-        { { float-uniform { 4 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4fv   ] }
-
-        { { texture-uniform 1 } { drop texture-unit glUniform1i } }
     } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
 
-    uniform uniform-type>> texture-uniform =
+    type uniform-type-texture-units dim * texture-unit +
-    [ texture-unit 1 + ] [ texture-unit ] if
     pre-quot value-quot append ;
 
+:: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot )
+    { name uniform-index } >quotation :> index-quot
+    { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+    type H{
+        { bool-uniform  [ >c-bool glUniform1i  ] }
+        { int-uniform   [ glUniform1i  ] }
+        { uint-uniform  [ glUniform1ui ] }
+        { float-uniform [ glUniform1f  ] }
+
+        { bvec2-uniform [ [ >c-bool ] map first2 glUniform2i  ] }
+        { ivec2-uniform [ first2 glUniform2i  ] }
+        { uvec2-uniform [ first2 glUniform2ui ] }
+        { vec2-uniform  [ first2 glUniform2f  ] }
+
+        { bvec3-uniform [ [ >c-bool ] map first3 glUniform3i  ] }
+        { ivec3-uniform [ first3 glUniform3i  ] }
+        { uvec3-uniform [ first3 glUniform3ui ] }
+        { vec3-uniform  [ first3 glUniform3f  ] }
+
+        { bvec4-uniform [ [ >c-bool ] map first4 glUniform4i  ] }
+        { ivec4-uniform [ first4 glUniform4i  ] }
+        { uvec4-uniform [ first4 glUniform4ui ] }
+        { vec4-uniform  [ first4 glUniform4f  ] }
+
+        { mat2-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2fv   ] }
+        { mat2x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x3fv ] }
+        { mat2x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x4fv ] }
+
+        { mat3x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x2fv ] }
+        { mat3-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3fv   ] }
+        { mat3x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x4fv ] }
+
+        { mat4x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x2fv ] }
+        { mat4x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x3fv ] }
+        { mat4-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4fv   ] }
+
+        { texture-uniform { drop texture-unit glUniform1i } }
+    } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+    type uniform-type-texture-units texture-unit +
+    pre-quot value-quot append ;
+
+:: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
+    dim
+    [
+        iota
+        [ [ [ swap nth ] swap prefix ] map ]
+        [ [ number>string name "[" append "]." surround ] map ] bi
+    ] [
+        { [ ] }
+        name "." append 1array
+    ] if* :> name-prefixes :> quot-prefixes
+    type all-uniform-tuple-slots :> uniforms
+
+    texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
+        uniforms name-prefix [bind-uniform-tuple]
+        quot-prefix prepend
+    ] 2map :> value-cleave :> texture-unit'
+
+    texture-unit' 
+    value>>-quot { value-cleave 2cleave } append ;
+
+TR: hyphens>underscores "-" "_" ;
+
+:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
+    prefix uniform name>> append hyphens>underscores :> name
+    uniform uniform-type>> :> type
+    uniform dim>> :> dim
+    uniform name>> reader-word 1quotation :> value>>-quot
+
+    value>>-quot type texture-unit name {
+        { [ type uniform-type? dim     and ] [ dim [bind-uniform-array] ] }
+        { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] }
+        [ dim [bind-uniform-struct] ]
+    } cond ;
+
+:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
+    texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
+
+    texture-unit'
+    { uniforms-cleave 2cleave } >quotation ;
+
 :: [bind-uniforms] ( superclass uniforms -- quot )
     superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
     superclass \ bind-uniforms method :> next-method
-    first-texture-unit uniforms [ [bind-uniform] ] map nip :> uniforms-cleave
+    first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
-    
+
-    {
+    { 2dup next-method } bind-quot [ ] append-as ;
-        2dup next-method
-        uniforms-cleave 2cleave
-    } >quotation ;
 
 : define-uniform-tuple-methods ( class superclass uniforms -- )
     [
-        [ \ bind-uniform-textures create-method-in ] 2dip
+        2drop
-        [bind-uniform-textures] define
+        [ \ bind-uniform-textures create-method-in ]
+        [ [bind-uniform-textures] ] bi define
     ] [
         [ \ bind-uniforms create-method-in ] 2dip
         [bind-uniforms] define
@@ -348,110 +386,32 @@ M: uniform-tuple bind-uniforms
         ] }
     } case ;
 
-: component-type>c-type ( component-type -- c-type )
-    {
-        { ubyte-components [ "uchar" ] }
-        { ushort-components [ "ushort" ] }
-        { uint-components [ "uint" ] }
-        { half-components [ "half" ] }
-        { float-components [ "float" ] }
-        { byte-integer-components [ "char" ] }
-        { ubyte-integer-components [ "uchar" ] }
-        { short-integer-components [ "short" ] }
-        { ushort-integer-components [ "ushort" ] }
-        { int-integer-components [ "int" ] }
-        { uint-integer-components [ "uint" ] }
-    } case ;
-
-: c-array-dim ( dim -- string )
-    dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
-
-SYMBOL: padding-no
-padding-no [ 0 ] initialize
-
-: padding-name ( -- name )
-    "padding-"
-    padding-no get number>string append
-    "(" ")" surround
-    padding-no inc ;
-
-: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
-    [
-        [ component-type>> component-type>c-type ]
-        [ dim>> c-array-dim ] bi append
-    ] [ name>> [ padding-name ] unless* ] bi 2array ;
-
 : (define-uniform-tuple) ( class superclass uniforms -- )
     {
         [ [ uniform>slot ] map define-tuple-class ]
-        [ define-uniform-tuple-methods ]
         [
-            [ "uniform-tuple-texture-units" word-prop 0 or ]
+            [ uniform-type-texture-units ]
-            [ [ uniform-type>> texture-uniform = ] filter length ] bi* +
+            [
+                [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ]
+                [ + ] map-reduce
+            ] bi* +
             "uniform-tuple-texture-units" set-word-prop
         ]
         [ nip "uniform-tuple-slots" set-word-prop ]
+        [ define-uniform-tuple-methods ]
     } 3cleave ;
 
 : true-subclasses ( class -- seq )
     [ subclasses ] keep [ = not ] curry filter ;
 
-: redefine-uniform-tuple-subclass-methods ( class -- )
-    [ true-subclasses ] keep
-    [ over "uniform-tuple-slots" word-prop (define-uniform-tuple) ] curry each ;
-
 PRIVATE>
 
-: define-vertex-format ( class vertex-attributes -- )
-    [
-        [
-            [ define-singleton-class ]
-            [ vertex-format add-mixin-instance ]
-            [ ] tri
-        ] [ define-vertex-format-methods ] bi*
-    ]
-    [ "vertex-format-attributes" set-word-prop ] 2bi ;
-
-SYNTAX: VERTEX-FORMAT:
-    CREATE-CLASS parse-definition
-    [ first4 vertex-attribute boa ] map
-    define-vertex-format ;
-
-: define-vertex-struct ( struct-name vertex-format -- )
-    [ current-vocab ] dip
-    "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
-    define-struct ;
-
-SYNTAX: VERTEX-STRUCT:
-    scan scan-word define-vertex-struct ;
-
 : define-uniform-tuple ( class superclass uniforms -- )
-    [ (define-uniform-tuple) ]
+    (define-uniform-tuple) ; inline
-    [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ;
 
 SYNTAX: UNIFORM-TUPLE:
     parse-uniform-tuple-definition define-uniform-tuple ;
 
-TUPLE: vertex-array < gpu-object
-    { program-instance program-instance read-only }
-    { vertex-buffers sequence read-only } ;
-
-M: vertex-array dispose
-    [ [ delete-vertex-array ] when* f ] change-handle drop ;
-
-: <vertex-array> ( program-instance vertex-formats -- vertex-array )
-    gen-vertex-array
-    [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
-    [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
-    window-resource ;
-
-: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
-    [ swap ] dip
-    [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
-
-: vertex-array-buffer ( vertex-array -- vertex-buffer )
-    vertex-buffers>> first ;
-
 <PRIVATE 
 
 : bind-vertex-array ( vertex-array -- )
@@ -471,16 +431,52 @@ M: vertex-array dispose
     dup first sequence?
     [ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ;
 
+GENERIC: bind-transform-feedback-output ( output -- )
+
+M: buffer bind-transform-feedback-output
+    [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip handle>> glBindBufferBase ; inline
+
+M: buffer-range bind-transform-feedback-output
+    [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip
+    [ handle>> ] [ offset>> ] [ size>> ] tri glBindBufferRange ; inline
+
+M: buffer-ptr bind-transform-feedback-output
+    buffer-ptr>range bind-transform-feedback-output ; inline
+
+: gl-feedback-primitive-mode ( primitive-mode -- gl-mode )
+    {
+        { points-mode         [ GL_POINTS    ] }
+        { lines-mode          [ GL_LINES     ] }
+        { line-strip-mode     [ GL_LINES     ] }
+        { line-loop-mode      [ GL_LINES     ] }
+        { triangles-mode      [ GL_TRIANGLES ] }
+        { triangle-strip-mode [ GL_TRIANGLES ] }
+        { triangle-fan-mode   [ GL_TRIANGLES ] }
+    } case ;
+
 PRIVATE>
 
+UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
+UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
+
 TUPLE: render-set
-    { primitive-mode primitive-mode }
+    { primitive-mode primitive-mode read-only }
-    { vertex-array vertex-array }
+    { vertex-array vertex-array read-only }
-    { uniforms uniform-tuple }
+    { uniforms uniform-tuple read-only }
-    { indexes vertex-indexes initial: T{ index-range } } 
+    { indexes vertex-indexes initial: T{ index-range } read-only } 
-    { instances ?integer initial: f }
+    { instances ?integer initial: f read-only }
-    { framebuffer any-framebuffer initial: system-framebuffer }
+    { framebuffer ?any-framebuffer initial: system-framebuffer read-only }
-    { output-attachments sequence initial: { default-attachment } } ;
+    { output-attachments sequence initial: { default-attachment } read-only }
+    { transform-feedback-output transform-feedback-output initial: f read-only } ;
+
+: <render-set> ( x quot-assoc -- render-set )
+    render-set swap make-tuple ; inline
+
+: 2<render-set> ( x y quot-assoc -- render-set )
+    render-set swap 2make-tuple ; inline
+
+: 3<render-set> ( x y z quot-assoc -- render-set )
+    render-set swap 3make-tuple ; inline
 
 : render ( render-set -- )
     {
@@ -489,7 +485,11 @@ TUPLE: render-set
             [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
             [ bind-uniform-textures ] [ bind-uniforms ] 2bi
         ]
-        [ GL_DRAW_FRAMEBUFFER swap framebuffer>> framebuffer-handle glBindFramebuffer ]
+        [
+            framebuffer>> 
+            [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
+            [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
+        ]
         [
             [ vertex-array>> program-instance>> ]
             [ framebuffer>> ]
@@ -497,10 +497,20 @@ TUPLE: render-set
             bind-output-attachments
         ]
         [ vertex-array>> bind-vertex-array ]
+        [
+            dup transform-feedback-output>> [
+                [ primitive-mode>> gl-feedback-primitive-mode glBeginTransformFeedback ]
+                [ bind-transform-feedback-output ] bi*
+            ] [ drop ] if*
+        ]
+
         [
             [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
             [ render-vertex-indexes-instanced ]
             [ render-vertex-indexes ] if*
         ]
+
+        [ transform-feedback-output>> [ glEndTransformFeedback ] when ]
+        [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]
     } cleave ; inline
 

extra/gpu/shaders/prettyprint/prettyprint.factor

@@ -3,10 +3,22 @@ IN: gpu.shaders.prettyprint
 
 M: compile-shader-error error.
     "The GLSL shader " write
-    [ shader>> name>> pprint-short " failed to compile." write nl ]
+    [ shader>> name>> pprint-short " failed to compile." print ]
-    [ log>> write nl ] bi ;
+    [ log>> print ] bi ;
 
 M: link-program-error error.
     "The GLSL program " write
-    [ shader>> name>> pprint-short " failed to link." write nl ]
+    [ shader>> name>> pprint-short " failed to link." print ]
-    [ log>> write nl ] bi ;
+    [ log>> print ] bi ;
+
+M: too-many-feedback-formats-error error.
+    drop
+    "Only one transform feedback format can be specified for a program." print ;
+
+M: invalid-link-feedback-format-error error.
+    drop
+    "Vertex formats used for transform feedback can't contain padding fields." print ;
+
+M: inaccurate-feedback-attribute-error error.
+    drop
+    "The types of the transform feedback attributes don't match those specified by the program's vertex format." print ;

extra/gpu/shaders/shaders-docs.factor

@@ -1,5 +1,6 @@
 ! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax kernel math multiline quotations strings ;
+USING: alien.syntax classes gpu.buffers help.markup help.syntax
+images kernel math multiline quotations sequences strings ;
 IN: gpu.shaders
 
 HELP: <program-instance>
@@ -16,9 +17,17 @@ HELP: <shader-instance>
 }
 { $description "Compiles an instance of " { $snippet "shader" } " for the current graphics context. If an instance already exists for " { $snippet "shader" } " in the current context, it is reused." } ;
 
+HELP: <vertex-array>
+{ $values
+    { "program-instance" program-instance } { "vertex-formats" "a list of " { $link buffer-ptr } "/" { $link vertex-format } " pairs" }
+    { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " to feed data to " { $snippet "program-instance" } " from the set of " { $link buffer } "s specified in " { $snippet "vertex-formats" } "." } ;
+
 HELP: GLSL-PROGRAM:
-{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader ;" }
+{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader [vertex-format] ;" }
-{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance." } ;
+{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance. A single " { $link vertex-array } " may optionally be specified; if the program is used to collect transform feedback, this format will be used for the output." }
+{ $notes "Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
 
 HELP: GLSL-SHADER-FILE:
 { $syntax "GLSL-SHADER-FILE: shader-name shader-kind \"filename\"" }
@@ -32,6 +41,18 @@ shader source
 ; "> }
 { $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from the current Factor source file between the " { $snippet "GLSL-SHADER:" } " line and the first subsequent line with a single semicolon on it." } ;
 
+HELP: VERTEX-FORMAT:
+{ $syntax <" VERTEX-FORMAT: format-name
+    { "attribute"/f component-type dimension normalize? }
+    { "attribute"/f component-type dimension normalize? }
+    ...
+    { "attribute"/f component-type dimension normalize? } ; "> }
+{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
+
+HELP: VERTEX-STRUCT:
+{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
+{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
+
 { POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
 
 HELP: attribute-index
@@ -41,6 +62,15 @@ HELP: attribute-index
 }
 { $description "Returns the numeric index of the vertex attribute named " { $snippet "attribute-name" } " in " { $snippet "program-instance" } "." } ;
 
+HELP: buffer>vertex-array
+{ $values
+    { "vertex-buffer" buffer } { "program-instance" program-instance } { "format" vertex-format }
+    { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " from the entire contents of a single " { $link buffer } " in a single " { $link vertex-format } " for use with " { $snippet "program-instance" } "." } ;
+
+{ vertex-array <vertex-array> buffer>vertex-array } related-words
+
 HELP: compile-shader-error
 { $class-description "An error compiling the source for a " { $link shader } "."
 { $list
@@ -48,6 +78,18 @@ HELP: compile-shader-error
 { "The " { $snippet "log" } " slot contains the error string from the GLSL compiler." }
 } } ;
 
+HELP: define-vertex-format
+{ $values
+    { "class" class } { "vertex-attributes" sequence }
+}
+{ $description "Defines a new " { $link vertex-format } " with the binary format specified by the " { $link vertex-attribute } " tuple values in " { $snippet "vertex-attributes" } ". The runtime equivalent of " { $link POSTPONE: VERTEX-FORMAT: } ". This word must be called inside a compilation unit." } ;
+
+HELP: define-vertex-struct
+{ $values
+    { "struct-name" string } { "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." } ;
+
 HELP: fragment-shader
 { $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a fragment shader." } ;
 
@@ -93,6 +135,15 @@ HELP: shader-kind
 { { $link fragment-shader } "s run as part of rasterization and decide the final rendered output of a primitive as the outputs of the vertex shader are interpolated across its surface." }
 } } ;
 
+HELP: too-many-feedback-formats-error
+{ $class-description "This error is thrown when a " { $link POSTPONE: GLSL-PROGRAM: } " definition attempts to include more than one " { $link vertex-format } " for transform feedback formatting." } ;
+
+HELP: invalid-link-feedback-format-error
+{ $class-description "This error is thrown when the " { $link vertex-format } " specified as the transform feedback output format of a " { $link program } " is not suitable for the purpose. Transform feedback formats do not support padding (fields with a name of " { $link f } ")." } ;
+
+HELP: inaccurate-feedback-attribute-error
+{ $class-description "This error is thrown when the " { $link vertex-format } " specified as the transform feedback output format of a " { $link program } " does not match the format of the output attributes linked into a " { $link program-instance } "." } ;
+
 HELP: uniform-index
 { $values
     { "program-instance" program-instance } { "uniform-name" string }
@@ -103,6 +154,29 @@ HELP: uniform-index
 HELP: vertex-shader
 { $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a vertex shader." } ;
 
+HELP: vertex-array
+{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <vertex-array> } " or " { $link buffer>vertex-array } " words." } ;
+
+HELP: vertex-array-buffer
+{ $values
+    { "vertex-array" vertex-array }
+    { "vertex-buffer" buffer }
+}
+{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
+
+HELP: vertex-attribute
+{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
+
+HELP: vertex-format
+{ $class-description "This class encompasses all vertex formats defined by " { $link POSTPONE: VERTEX-FORMAT: } ". A vertex format defines the binary layout of vertex attribute data in a " { $link buffer } " for use as part of a " { $link vertex-array } ". See the " { $link POSTPONE: VERTEX-FORMAT: } " documentation for details on how vertex formats are defined." } ;
+
+HELP: vertex-format-size
+{ $values
+    { "format" vertex-format }
+    { "size" integer }
+}
+{ $description "Returns the size in bytes of a set of vertex attributes in " { $snippet "format" } "." } ;
+
 ARTICLE: "gpu.shaders" "Shader objects"
 "The " { $vocab-link "gpu.shaders" } " vocabulary supports defining, compiling, and linking " { $link shader } "s into " { $link program } "s that run on the GPU and control rendering."
 { $subsection POSTPONE: GLSL-PROGRAM: }
@@ -111,6 +185,11 @@ ARTICLE: "gpu.shaders" "Shader objects"
 "A program must be instantiated for each graphics context it is used in:"
 { $subsection <program-instance> }
 "Program instances can be updated on the fly, allowing for interactive development of shaders:"
-{ $subsection refresh-program } ;
+{ $subsection refresh-program }
+"Render data inside GPU " { $link buffer } "s is organized into " { $link vertex-array } "s for consumption by shader code:"
+{ $subsection vertex-array }
+{ $subsection <vertex-array> }
+{ $subsection buffer>vertex-array }
+{ $subsection POSTPONE: VERTEX-FORMAT: } ;
 
 ABOUT: "gpu.shaders"

extra/gpu/shaders/shaders.factor

@@ -1,17 +1,35 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays assocs combinators
+USING: accessors alien alien.c-types alien.strings
-combinators.short-circuit definitions destructors gpu
+alien.structs arrays assocs byte-arrays classes.mixin
-io.encodings.ascii io.files io.pathnames kernel lexer
+classes.parser classes.singleton combinators
-locals math math.parser memoize multiline namespaces
+combinators.short-circuit definitions destructors
-opengl.gl opengl.shaders parser sequences
+generic.parser gpu gpu.buffers hashtables images
-specialized-arrays.int splitting strings ui.gadgets.worlds
+io.encodings.ascii io.files io.pathnames kernel lexer literals
-variants hashtables vectors vocabs vocabs.loader words
+locals math math.parser memoize multiline namespaces opengl
-words.constant ;
+opengl.gl opengl.shaders parser quotations sequences
+specialized-arrays.alien specialized-arrays.int splitting
+strings ui.gadgets.worlds variants vectors vocabs vocabs.loader
+vocabs.parser words words.constant ;
 IN: gpu.shaders
 
 VARIANT: shader-kind
     vertex-shader fragment-shader ;
 
+UNION: ?string string POSTPONE: f ;
+
+ERROR: too-many-feedback-formats-error formats ;
+ERROR: invalid-link-feedback-format-error format ;
+ERROR: inaccurate-feedback-attribute-error attribute ;
+
+TUPLE: vertex-attribute
+    { name            ?string        read-only initial: f }
+    { component-type  component-type read-only initial: float-components }
+    { dim             integer        read-only initial: 4 }
+    { normalize?      boolean        read-only initial: f } ;
+
+MIXIN: vertex-format
+UNION: ?vertex-format vertex-format POSTPONE: f ;
+
 TUPLE: shader
     { name word read-only initial: t }
     { kind shader-kind read-only }
@@ -25,6 +43,7 @@ TUPLE: program
     { filename read-only }
     { line integer read-only }
     { shaders array read-only }
+    { feedback-format ?vertex-format read-only }
     { instances hashtable read-only } ;
 
 TUPLE: shader-instance < gpu-object
@@ -35,8 +54,206 @@ TUPLE: program-instance < gpu-object
     { program program }
     { world world } ;
 
+GENERIC: vertex-format-size ( format -- size )
+
+MEMO: uniform-index ( program-instance uniform-name -- index )
+    [ handle>> ] dip glGetUniformLocation ;
+MEMO: attribute-index ( program-instance attribute-name -- index )
+    [ handle>> ] dip glGetAttribLocation ;
+MEMO: output-index ( program-instance output-name -- index )
+    [ handle>> ] dip glGetFragDataLocation ;
+
 <PRIVATE
 
+: gl-vertex-type ( component-type -- gl-type )
+    {
+        { ubyte-components          [ GL_UNSIGNED_BYTE  ] }
+        { ushort-components         [ GL_UNSIGNED_SHORT ] }
+        { uint-components           [ GL_UNSIGNED_INT   ] }
+        { half-components           [ GL_HALF_FLOAT     ] }
+        { float-components          [ GL_FLOAT          ] }
+        { byte-integer-components   [ GL_BYTE           ] }
+        { short-integer-components  [ GL_SHORT          ] }
+        { int-integer-components    [ GL_INT            ] }
+        { ubyte-integer-components  [ GL_UNSIGNED_BYTE  ] }
+        { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
+        { uint-integer-components   [ GL_UNSIGNED_INT   ] }
+    } case ;
+
+: vertex-type-size ( component-type -- size ) 
+    {
+        { ubyte-components          [ 1 ] }
+        { ushort-components         [ 2 ] }
+        { uint-components           [ 4 ] }
+        { half-components           [ 2 ] }
+        { float-components          [ 4 ] }
+        { byte-integer-components   [ 1 ] }
+        { short-integer-components  [ 2 ] }
+        { int-integer-components    [ 4 ] }
+        { ubyte-integer-components  [ 1 ] }
+        { ushort-integer-components [ 2 ] }
+        { uint-integer-components   [ 4 ] }
+    } case ;
+
+: vertex-attribute-size ( vertex-attribute -- size )
+    [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
+
+: vertex-attributes-size ( vertex-attributes -- size )
+    [ vertex-attribute-size ] [ + ] map-reduce ;
+
+: feedback-type= ( component-type dim gl-type -- ? )
+    [ 2array ] dip {
+        { $ GL_FLOAT             [ { float-components 1 } ] }
+        { $ GL_FLOAT_VEC2        [ { float-components 2 } ] }
+        { $ GL_FLOAT_VEC3        [ { float-components 3 } ] }
+        { $ GL_FLOAT_VEC4        [ { float-components 4 } ] }
+        { $ GL_INT               [ { int-integer-components 1 } ] }
+        { $ GL_INT_VEC2          [ { int-integer-components 2 } ] }
+        { $ GL_INT_VEC3          [ { int-integer-components 3 } ] }
+        { $ GL_INT_VEC4          [ { int-integer-components 4 } ] }
+        { $ GL_UNSIGNED_INT      [ { uint-integer-components 1 } ] }
+        { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
+        { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
+        { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
+    } case = ;
+
+:: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
+    {
+        [ vertex-attribute name>> name = ] 
+        [ size 1 = ]
+        [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
+    } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
+
+:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
+    vertex-attribute name>>                 :> name
+    vertex-attribute component-type>>       :> type
+    type gl-vertex-type                     :> gl-type
+    vertex-attribute dim>>                  :> dim
+    vertex-attribute normalize?>> >c-bool   :> normalize?
+    vertex-attribute vertex-attribute-size  :> size
+
+    stride offset size +
+    {
+        { [ name not ] [ [ 2drop ] ] }
+        {
+            [ type unnormalized-integer-components? ]
+            [
+                {
+                    name attribute-index [ glEnableVertexAttribArray ] keep
+                    dim gl-type stride offset
+                } >quotation :> dip-block
+                
+                { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
+            ]
+        }
+        [
+            {
+                name attribute-index [ glEnableVertexAttribArray ] keep
+                dim gl-type normalize? stride offset
+            } >quotation :> dip-block
+
+            { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
+        ]
+    } cond ;
+
+:: [bind-vertex-format] ( vertex-attributes -- quot )
+    vertex-attributes vertex-attributes-size :> stride
+    stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
+    { attributes-cleave 2cleave } >quotation :> with-block
+
+    { drop vertex-buffer with-block with-buffer-ptr } >quotation ; 
+
+:: [link-feedback-format] ( vertex-attributes -- quot )
+    vertex-attributes [ name>> not ] any?
+    [ [ nip invalid-link-feedback-format-error ] ] [
+        vertex-attributes
+        [ name>> ascii malloc-string ]
+        void*-array{ } map-as :> varying-names
+        vertex-attributes length :> varying-count
+        { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
+        >quotation
+    ] if ;
+
+:: [verify-feedback-attribute] ( vertex-attribute index -- quot )
+    vertex-attribute name>> :> name
+    name length 1 + :> name-buffer-length
+    {
+        index name-buffer-length dup
+        [ f 0 <int> 0 <int> ] dip <byte-array>
+        [ glGetTransformFeedbackVarying ] 3keep
+        ascii alien>string
+        vertex-attribute assert-feedback-attribute    
+    } >quotation ;
+
+:: [verify-feedback-format] ( vertex-attributes -- quot )
+    vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
+    { drop verify-cleave cleave } >quotation ;
+
+GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
+
+GENERIC: link-feedback-format ( program-handle format -- )
+
+M: f link-feedback-format
+    2drop ;
+
+GENERIC: (verify-feedback-format) ( program-instance format -- )
+
+M: f (verify-feedback-format)
+    2drop ;
+
+: verify-feedback-format ( program-instance -- )
+    dup program>> feedback-format>> (verify-feedback-format) ;
+
+: define-vertex-format-methods ( class vertex-attributes -- )
+    {
+        [
+            [ \ bind-vertex-format create-method-in ] dip
+            [bind-vertex-format] define
+        ] [
+            [ \ link-feedback-format create-method-in ] dip
+            [link-feedback-format] define
+        ] [
+            [ \ (verify-feedback-format) create-method-in ] dip
+            [verify-feedback-format] define
+        ] [
+            [ \ vertex-format-size create-method-in ] dip
+            [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
+        ]
+    } 2cleave ;
+
+: component-type>c-type ( component-type -- c-type )
+    {
+        { ubyte-components [ "uchar" ] }
+        { ushort-components [ "ushort" ] }
+        { uint-components [ "uint" ] }
+        { half-components [ "half" ] }
+        { float-components [ "float" ] }
+        { byte-integer-components [ "char" ] }
+        { ubyte-integer-components [ "uchar" ] }
+        { short-integer-components [ "short" ] }
+        { ushort-integer-components [ "ushort" ] }
+        { int-integer-components [ "int" ] }
+        { uint-integer-components [ "uint" ] }
+    } case ;
+
+: c-array-dim ( dim -- string )
+    dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
+
+SYMBOL: padding-no
+padding-no [ 0 ] initialize
+
+: padding-name ( -- name )
+    "padding-"
+    padding-no get number>string append
+    "(" ")" surround
+    padding-no inc ;
+
+: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
+    [
+        [ component-type>> component-type>c-type ]
+        [ dim>> c-array-dim ] bi append
+    ] [ name>> [ padding-name ] unless* ] bi 2array ;
+
 : shader-filename ( shader/program -- filename )
     dup filename>> [ nip ] [ name>> where first ] if* file-name ;
 
@@ -69,6 +286,49 @@ TUPLE: program-instance < gpu-object
 
 PRIVATE>
 
+: define-vertex-format ( class vertex-attributes -- )
+    [
+        [
+            [ define-singleton-class ]
+            [ vertex-format add-mixin-instance ]
+            [ ] tri
+        ] [ define-vertex-format-methods ] bi*
+    ]
+    [ "vertex-format-attributes" set-word-prop ] 2bi ;
+
+SYNTAX: VERTEX-FORMAT:
+    CREATE-CLASS parse-definition
+    [ first4 vertex-attribute boa ] map
+    define-vertex-format ;
+
+: define-vertex-struct ( struct-name vertex-format -- )
+    [ current-vocab ] dip
+    "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
+    define-struct ;
+
+SYNTAX: VERTEX-STRUCT:
+    scan scan-word define-vertex-struct ;
+
+TUPLE: vertex-array < gpu-object
+    { program-instance program-instance read-only }
+    { vertex-buffers sequence read-only } ;
+
+M: vertex-array dispose
+    [ [ delete-vertex-array ] when* f ] change-handle drop ;
+
+: <vertex-array> ( program-instance vertex-formats -- vertex-array )
+    gen-vertex-array
+    [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
+    [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
+    window-resource ;
+
+: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
+    [ swap ] dip
+    [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
+
+: vertex-array-buffer ( vertex-array -- vertex-buffer )
+    vertex-buffers>> first ;
+
 TUPLE: compile-shader-error shader log ;
 TUPLE: link-program-error program log ;
 
@@ -82,13 +342,6 @@ TUPLE: link-program-error program log ;
 
 DEFER: <shader-instance>
 
-MEMO: uniform-index ( program-instance uniform-name -- index )
-    [ handle>> ] dip glGetUniformLocation ;
-MEMO: attribute-index ( program-instance attribute-name -- index )
-    [ handle>> ] dip glGetAttribLocation ;
-MEMO: output-index ( program-instance output-name -- index )
-    [ handle>> ] dip glGetFragDataLocation ;
-
 <PRIVATE
 
 : valid-handle? ( handle -- ? )
@@ -101,10 +354,12 @@ MEMO: output-index ( program-instance output-name -- index )
     [ compile-shader-error ] if ;
 
 : (link-program) ( program shader-instances -- program-instance )
-    [ handle>> ] map <gl-program>
+    [ [ handle>> ] map ] curry
-    dup gl-program-ok?
+    [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
-    [ swap world get \ program-instance boa window-resource ]
+    dup gl-program-ok?  [
-    [ link-program-error ] if ;
+        [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
+        with-destructors window-resource
+    ] [ link-program-error ] if ;
 
 : link-program ( program -- program-instance )
     dup shaders>> [ <shader-instance> ] map (link-program) ;
@@ -139,6 +394,14 @@ MEMO: output-index ( program-instance output-name -- index )
     world get over instances>> at*
     [ nip ] [ drop link-program ] if ;
 
+: shaders-and-feedback-format ( words -- shaders feedback-format )
+    [ vertex-format? ] partition swap
+    [ [ def>> first ] map ] [
+        dup length 1 <=
+        [ [ f ] [ first ] if-empty ]
+        [ too-many-feedback-formats-error ] if
+    ] bi* ;
+
 PRIVATE>
 
 :: refresh-program ( program -- )
@@ -191,7 +454,7 @@ SYNTAX: GLSL-PROGRAM:
     CREATE-WORD dup
     f
     lexer get line>>
-    \ ; parse-until >array [ def>> first ] map
+    \ ; parse-until >array shaders-and-feedback-format
     H{ } clone
     program boa
     define-constant ;

extra/gpu/textures/textures.factor

@@ -151,7 +151,7 @@ M: cube-map-face     texture-data-gl-target
 
 : get-texture-float ( target level enum -- value )
     0 <float> [ glGetTexLevelParameterfv ] keep *float ;
-: get-texture-int ( texture level enum -- value )
+: get-texture-int ( target level enum -- value )
     0 <int> [ glGetTexLevelParameteriv ] keep *int ;
 
 : ?product ( x -- y )

extra/gpu/util/util.factor

@@ -1,5 +1,5 @@
 ! (c)2009 Joe Groff bsd license
-USING: gpu.buffers gpu.render gpu.textures images kernel
+USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
 specialized-arrays.float ;
 IN: gpu.util
 

extra/gpu/util/wasd/wasd.factor

@@ -8,8 +8,8 @@ specialized-arrays.float ui ui.gadgets.worlds ;
 IN: gpu.util.wasd
 
 UNIFORM-TUPLE: mvp-uniforms
-    { "mv_matrix"  float-uniform   { 4 4 } }
+    { "mv_matrix"  mat4-uniform f }
-    { "p_matrix"   float-uniform   { 4 4 } } ;
+    { "p_matrix"   mat4-uniform f } ;
 
 CONSTANT: -pi/2 $[ pi -2.0 / ]
 CONSTANT:  pi/2 $[ pi  2.0 / ]