From 59091c6cf286764b4d94b1e18bd90e98f19b83d6 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 21 Jul 2009 17:09:32 +1200 Subject: [PATCH 01/38] alien.marshall: refactored unmarshalling words --- extra/alien/marshall/marshall-docs.factor | 2 +- extra/alien/marshall/marshall.factor | 65 +++++++++++++++-------- 2 files changed, 43 insertions(+), 24 deletions(-) diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor index 6002b0c1c3..deac9fd186 100644 --- a/extra/alien/marshall/marshall-docs.factor +++ b/extra/alien/marshall/marshall-docs.factor @@ -327,7 +327,7 @@ 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 } diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 85b157e4a0..deef94dc9b 100644 --- a/extra/alien/marshall/marshall.factor +++ b/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 ; IN: alien.marshall << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] @@ -269,33 +270,51 @@ ALIAS: marshall-void* marshall-pointer : ?malloc-byte-array ( c-type -- alien ) dup alien? [ malloc-byte-array ] unless ; -: struct-unmarshaller ( type -- quot ) - current-vocab lookup [ - dup superclasses [ \ struct-wrapper = ] any? [ - '[ ?malloc-byte-array _ new swap >>underlying ] - ] [ drop [ ] ] if - ] [ [ ] ] if* ; +:: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f ) + type type-quot call current-vocab lookup [ + dup superclasses wrapper-test any? + [ def call ] [ drop clean call f ] if + ] [ clean call f ] if* ; inline -: pointer-unmarshaller ( type -- quot ) - type-sans-pointer current-vocab lookup [ - dup superclasses [ \ alien-wrapper = ] any? [ - '[ _ new swap >>underlying unmarshall-cast ] - ] [ drop [ ] ] if - ] [ [ ] ] if* ; +: struct-unmarshaller ( type -- quot/f ) + [ ] [ \ struct-wrapper = ] + [ '[ ?malloc-byte-array _ new swap >>underlying ] ] + [ ] + x-unmarshaller ; + +: class-unmarshaller ( type -- quot/f ) + [ type-sans-pointer ] [ \ alien-wrapper = ] + [ '[ ?malloc-byte-array _ new swap >>underlying ] ] + [ ] + x-unmarshaller ; + +: template-class-unmarshaller ( type -- quot/f ) + [ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ] + [ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ] + [ drop ] + x-unmarshaller ; + +: non-primitive-unmarshaller ( type -- quot/f ) + { + { [ dup template-class? ] + [ template-class-unmarshaller ] } + { [ dup pointer? ] [ class-unmarshaller ] } + [ struct-unmarshaller ] + } cond ; : unmarshaller ( type -- quot ) - factorize-type dup primitive-unmarshaller [ nip ] [ - dup pointer? - [ pointer-unmarshaller ] - [ struct-unmarshaller ] if - ] if* ; + factorize-type { + [ primitive-unmarshaller ] + [ non-primitive-unmarshaller ] + [ drop [ ] ] + } 1|| ; : struct-field-unmarshaller ( type -- quot ) - factorize-type dup struct-primitive-unmarshaller [ nip ] [ - dup pointer? - [ pointer-unmarshaller ] - [ struct-unmarshaller ] if - ] if* ; + factorize-type { + [ struct-primitive-unmarshaller ] + [ non-primitive-unmarshaller ] + [ drop [ ] ] + } 1|| ; : out-arg-unmarshaller ( type -- quot ) dup pointer-to-non-const-primitive? From c780bb724d368a3e9cb82667efbb26089f2e27ad Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 12:25:45 +1200 Subject: [PATCH 02/38] alien.marshall: C++ type parsing --- extra/alien/inline/types/types.factor | 44 ++++++++++++++++++++++++++- extra/alien/marshall/marshall.factor | 13 +++----- 2 files changed, 47 insertions(+), 10 deletions(-) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index 94b98d1eb5..fe4f6a4180 100644 --- a/extra/alien/inline/types/types.factor +++ b/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 alien.c-types ; 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 ; + +TUPLE: c++-type name params ptr ; +C: 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 ]] +;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 ; diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index deef94dc9b..2aede320aa 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -12,7 +12,7 @@ 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 -locals generalizations ; +locals generalizations math ; IN: alien.marshall << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] @@ -20,6 +20,7 @@ filter [ define-primitive-marshallers ] each >> TUPLE: alien-wrapper { underlying alien } ; TUPLE: struct-wrapper < alien-wrapper disposed ; +TUPLE: class-wrapper < alien-wrapper disposed ; GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' ) @@ -28,6 +29,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? ] [ ] } @@ -288,16 +291,8 @@ ALIAS: marshall-void* marshall-pointer [ ] x-unmarshaller ; -: template-class-unmarshaller ( type -- quot/f ) - [ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ] - [ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ] - [ drop ] - x-unmarshaller ; - : non-primitive-unmarshaller ( type -- quot/f ) { - { [ dup template-class? ] - [ template-class-unmarshaller ] } { [ dup pointer? ] [ class-unmarshaller ] } [ struct-unmarshaller ] } cond ; From 8ae1fb66a3d9c6abf5ab16cfa882566c07acd2c8 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 15:57:29 +1200 Subject: [PATCH 03/38] alien.inline.types: fix parse-c++-type --- extra/alien/inline/types/types.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index fe4f6a4180..34162f422e 100644 --- a/extra/alien/inline/types/types.factor +++ b/extra/alien/inline/types/types.factor @@ -68,7 +68,7 @@ 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 ]] +name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]] ptr = [*&] => [[ empty? not ]] param = "," " "* type " "* => [[ third ]] @@ -79,7 +79,7 @@ type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 ;EBNF : parse-c++-type ( str -- c++-type ) - factorize-type parse-c++-type ; + factorize-type (parse-c++-type) ; DEFER: c++-type>string From 186cc7edb3476dd65351de484aca24932d58d8d5 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 16:00:38 +1200 Subject: [PATCH 04/38] added alien.cxx --- extra/alien/cxx/authors.txt | 1 + extra/alien/cxx/cxx.factor | 22 ++++++++++++++++++++ extra/alien/cxx/parser/authors.txt | 1 + extra/alien/cxx/parser/parser.factor | 7 +++++++ extra/alien/cxx/syntax/authors.txt | 1 + extra/alien/cxx/syntax/syntax-tests.factor | 24 ++++++++++++++++++++++ extra/alien/cxx/syntax/syntax.factor | 6 ++++++ extra/alien/marshall/marshall.factor | 2 ++ 8 files changed, 64 insertions(+) create mode 100644 extra/alien/cxx/authors.txt create mode 100644 extra/alien/cxx/cxx.factor create mode 100644 extra/alien/cxx/parser/authors.txt create mode 100644 extra/alien/cxx/parser/parser.factor create mode 100644 extra/alien/cxx/syntax/authors.txt create mode 100644 extra/alien/cxx/syntax/syntax-tests.factor create mode 100644 extra/alien/cxx/syntax/syntax.factor diff --git a/extra/alien/cxx/authors.txt b/extra/alien/cxx/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor new file mode 100644 index 0000000000..71144e6450 --- /dev/null +++ b/extra/alien/cxx/cxx.factor @@ -0,0 +1,22 @@ +! 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 ; +IN: alien.cxx + + + +: define-c++-class ( str superclass-mixin -- ) + [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip + add-mixin-instance define-class-tuple ; diff --git a/extra/alien/cxx/parser/authors.txt b/extra/alien/cxx/parser/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/parser/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor new file mode 100644 index 0000000000..4614a4a7b5 --- /dev/null +++ b/extra/alien/cxx/parser/parser.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: parser lexer ; +IN: alien.cxx.parser + +: parse-c++-class-definition ( -- class superclass-mixin ) + scan scan-word ; diff --git a/extra/alien/cxx/syntax/authors.txt b/extra/alien/cxx/syntax/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/syntax/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor new file mode 100644 index 0000000000..f9fb9a218f --- /dev/null +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -0,0 +1,24 @@ +! 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 ; +IN: alien.cxx.syntax.tests + +DELETE-C-LIBRARY: test +C-LIBRARY: test + +COMPILE-AS-C++ + +C-INCLUDE: + +C-TYPEDEF: std::string string + +C++-CLASS: std::string c++-root + +CM-FUNCTION: std::string* new_string ( const-char* s ) + return new std::string(s); +; + +;C-LIBRARY + +{ 1 1 } [ new_string ] must-infer-as diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor new file mode 100644 index 0000000000..741950f79b --- /dev/null +++ b/extra/alien/cxx/syntax/syntax.factor @@ -0,0 +1,6 @@ +! 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 ; diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 2aede320aa..eec0cadcbb 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -22,6 +22,8 @@ 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' ) M: alien-wrapper unmarshall-cast ; From 1218d3fa9d28e5ec4098f2cae7268d24a6ebccea Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 17:21:07 +1200 Subject: [PATCH 05/38] alien.cxx: C++ methods --- extra/alien/cxx/cxx.factor | 12 ++++++++++-- extra/alien/cxx/parser/parser.factor | 5 ++++- extra/alien/cxx/syntax/syntax-tests.factor | 8 ++++++++ extra/alien/cxx/syntax/syntax.factor | 6 +++++- 4 files changed, 27 insertions(+), 4 deletions(-) diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor index 71144e6450..ab7ff416fa 100644 --- a/extra/alien/cxx/cxx.factor +++ b/extra/alien/cxx/cxx.factor @@ -2,7 +2,8 @@ ! 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 ; +assocs sequences parser classes.parser alien.marshall.syntax +interpolate locals effects io strings ; IN: alien.cxx -: define-c++-class ( str superclass-mixin -- ) +: 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 name types effect -- ) + effect [ in>> "self" suffix ] [ out>> ] bi :> effect' + types class-name "*" append suffix :> types' + effect in>> "," join :> args + SBUF" " dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body + name types' effect' body define-c-marshalled ; diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor index 4614a4a7b5..84425649da 100644 --- a/extra/alien/cxx/parser/parser.factor +++ b/extra/alien/cxx/parser/parser.factor @@ -1,7 +1,10 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: parser lexer ; +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 name types effect ) + scan function-types-effect ; diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor index f9fb9a218f..4b853770c2 100644 --- a/extra/alien/cxx/syntax/syntax-tests.factor +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -15,10 +15,18 @@ C-TYPEDEF: std::string string C++-CLASS: std::string c++-root +C++-METHOD: std::string const-char* c_str ( ) + CM-FUNCTION: std::string* new_string ( const-char* s ) return new std::string(s); ; ;C-LIBRARY +ALIAS: new_string + +ALIAS: to-string c_str + { 1 1 } [ new_string ] must-infer-as +{ 1 1 } [ c_str ] must-infer-as +[ "abc" ] [ "abc" to-string ] unit-test diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor index 741950f79b..59cf10e7de 100644 --- a/extra/alien/cxx/syntax/syntax.factor +++ b/extra/alien/cxx/syntax/syntax.factor @@ -3,4 +3,8 @@ USING: alien.cxx alien.cxx.parser ; IN: alien.cxx.syntax -SYNTAX: C++-CLASS: parse-c++-class-definition define-c++-class ; +SYNTAX: C++-CLASS: + parse-c++-class-definition define-c++-class ; + +SYNTAX: C++-METHOD: + parse-c++-method-definition define-c++-method ; From 8d4585edefb2b6a32273af62f8bff9de1dd984ca Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 19:20:01 +1200 Subject: [PATCH 06/38] alien.marshall: tidy unmarshallers --- extra/alien/marshall/marshall.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index eec0cadcbb..547e37f78a 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -275,21 +275,21 @@ ALIAS: marshall-void* marshall-pointer : ?malloc-byte-array ( c-type -- alien ) dup alien? [ malloc-byte-array ] unless ; -:: x-unmarshaller ( type type-quot wrapper-test def clean -- quot/f ) +:: x-unmarshaller ( type type-quot superclass def clean -- quot/f ) type type-quot call current-vocab lookup [ - dup superclasses wrapper-test any? + dup superclasses superclass swap member? [ def call ] [ drop clean call f ] if ] [ clean call f ] if* ; inline : struct-unmarshaller ( type -- quot/f ) - [ ] [ \ struct-wrapper = ] + [ ] \ struct-wrapper [ '[ ?malloc-byte-array _ new swap >>underlying ] ] [ ] x-unmarshaller ; : class-unmarshaller ( type -- quot/f ) - [ type-sans-pointer ] [ \ alien-wrapper = ] - [ '[ ?malloc-byte-array _ new swap >>underlying ] ] + [ type-sans-pointer "#" append ] \ class-wrapper + [ '[ _ new swap >>underlying ] ] [ ] x-unmarshaller ; From 7ad0924df27d47fdf87f18e72e809e1f482d944b Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 19:20:26 +1200 Subject: [PATCH 07/38] alien.cxx: methods and virtual methods --- extra/alien/cxx/cxx.factor | 16 ++-- extra/alien/cxx/parser/parser.factor | 4 +- extra/alien/cxx/syntax/syntax-tests.factor | 91 ++++++++++++++++++++-- extra/alien/cxx/syntax/syntax.factor | 5 +- 4 files changed, 102 insertions(+), 14 deletions(-) diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor index ab7ff416fa..9d0ee24f50 100644 --- a/extra/alien/cxx/cxx.factor +++ b/extra/alien/cxx/cxx.factor @@ -3,7 +3,8 @@ 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 ; +interpolate locals effects io strings make vocabs.parser words +generic fry quotations ; IN: alien.cxx [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip add-mixin-instance define-class-tuple ; -:: define-c++-method ( class-name name types effect -- ) +:: 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' - types class-name "*" append suffix :> types' - effect in>> "," join :> args - SBUF" " dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body - name types' effect' body define-c-marshalled ; + 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 ; diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor index 84425649da..5afaab29e0 100644 --- a/extra/alien/cxx/parser/parser.factor +++ b/extra/alien/cxx/parser/parser.factor @@ -6,5 +6,5 @@ IN: alien.cxx.parser : parse-c++-class-definition ( -- class superclass-mixin ) scan scan-word ; -: parse-c++-method-definition ( -- class-name name types effect ) - scan function-types-effect ; +: parse-c++-method-definition ( -- class-name generic name types effect ) + scan scan-word function-types-effect ; diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor index 4b853770c2..24f685a197 100644 --- a/extra/alien/cxx/syntax/syntax-tests.factor +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -1,7 +1,7 @@ ! 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 ; +alien.marshall.syntax alien.marshall accessors kernel ; IN: alien.cxx.syntax.tests DELETE-C-LIBRARY: test @@ -15,7 +15,9 @@ C-TYPEDEF: std::string string C++-CLASS: std::string c++-root -C++-METHOD: std::string const-char* c_str ( ) +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); @@ -25,8 +27,87 @@ CM-FUNCTION: std::string* new_string ( const-char* s ) ALIAS: new_string -ALIAS: to-string c_str - { 1 1 } [ new_string ] must-infer-as -{ 1 1 } [ c_str ] must-infer-as +{ 1 1 } [ c_str_std__string ] must-infer-as +[ t ] [ "abc" std::string? ] unit-test [ "abc" ] [ "abc" to-string ] unit-test + + +DELETE-C-LIBRARY: inheritance +C-LIBRARY: inheritance + +COMPILE-AS-C++ + +C-INCLUDE: + +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; + }; +}; +; + +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: new_alpha +ALIAS: 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#? ] unit-test +[ t ] [ "x" alpha? ] unit-test +[ t ] [ "x" alpha? ] unit-test +[ f ] [ "x" alpha#? ] unit-test +[ 5 ] [ "hello" length ] unit-test +[ 4 ] [ "hello" length ] unit-test +[ "hello" ] [ "hello" render ] unit-test +[ "llo" ] [ "hello" render ] unit-test +[ "ello" ] [ "hello" underlying>> \ alpha# new swap >>underlying render ] unit-test +[ "hello" ] [ "hello" chop ] unit-test +[ "lo" ] [ "hello" chop ] unit-test +[ "lo" ] [ "hello" underlying>> \ alpha# new swap >>underlying chop ] unit-test diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor index 59cf10e7de..66c72c1c2b 100644 --- a/extra/alien/cxx/syntax/syntax.factor +++ b/extra/alien/cxx/syntax/syntax.factor @@ -7,4 +7,7 @@ SYNTAX: C++-CLASS: parse-c++-class-definition define-c++-class ; SYNTAX: C++-METHOD: - parse-c++-method-definition define-c++-method ; + parse-c++-method-definition f define-c++-method ; + +SYNTAX: C++-VIRTUAL: + parse-c++-method-definition t define-c++-method ; From f261752dd1059ed115c9cfe2f12f16348285036a Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Wed, 22 Jul 2009 19:30:55 +1200 Subject: [PATCH 08/38] alien.inline.types: a trifling matter --- extra/alien/inline/types/types.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index 34162f422e..070febc324 100644 --- a/extra/alien/inline/types/types.factor +++ b/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 strings peg.ebnf make alien.c-types ; +splitting strings peg.ebnf make ; IN: alien.inline.types : cify-type ( str -- str' ) From ac2c65e92019c3c35bc37958f2b2a0f758da096f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 12:06:30 -0500 Subject: [PATCH 09/38] OR gl extension testing --- .../capabilities/capabilities-docs.factor | 8 ++++++- .../capabilities/capabilities-tests.factor | 21 +++++++++++++++++++ basis/opengl/capabilities/capabilities.factor | 7 +++++-- 3 files changed, 33 insertions(+), 3 deletions(-) create mode 100644 basis/opengl/capabilities/capabilities-tests.factor diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/basis/opengl/capabilities/capabilities-docs.factor index f5424e19da..959b222671 100644 --- a/basis/opengl/capabilities/capabilities-docs.factor +++ b/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" } } diff --git a/basis/opengl/capabilities/capabilities-tests.factor b/basis/opengl/capabilities/capabilities-tests.factor new file mode 100644 index 0000000000..8bc8871482 --- /dev/null +++ b/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 diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index ad04ce7fa5..37bfabc19b 100755 --- a/basis/opengl/capabilities/capabilities.factor +++ b/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" % From 3bbc9835fcf509e3f2e626f46c0e831d06266649 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 12:43:44 -0500 Subject: [PATCH 10/38] add a new "make-tuple" combinator for cleaving values into tuple slots by name. make render-set read-only and update gpu demos to use make-tuple --- extra/combinators/tuple/tuple-docs.factor | 43 ++++++++++++++++++++++ extra/combinators/tuple/tuple.factor | 29 +++++++++++++++ extra/gpu/demos/bunny/bunny.factor | 45 +++++++++++------------ extra/gpu/demos/raytrace/raytrace.factor | 19 +++++----- extra/gpu/render/render.factor | 25 +++++++++---- 5 files changed, 119 insertions(+), 42 deletions(-) create mode 100644 extra/combinators/tuple/tuple-docs.factor create mode 100644 extra/combinators/tuple/tuple.factor diff --git a/extra/combinators/tuple/tuple-docs.factor b/extra/combinators/tuple/tuple-docs.factor new file mode 100644 index 0000000000..aedb013129 --- /dev/null +++ b/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" diff --git a/extra/combinators/tuple/tuple.factor b/extra/combinators/tuple/tuple.factor new file mode 100644 index 0000000000..c4e0ef40a1 --- /dev/null +++ b/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 + +> 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 :> \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 + diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index ea15dc7884..a1b42d9f12 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/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 @@ -229,16 +230,14 @@ BEFORE: bunny-world begin-world { depth-attachment 1.0 } } clear-framebuffer ] [ - render-set new - triangles-mode >>primitive-mode - { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments - swap { - [ >>uniforms ] - [ bunny>> vertex-array>> >>vertex-array ] - [ bunny>> index-elements>> >>indexes ] - [ sobel>> framebuffer>> >>framebuffer ] - } cleave - render + { + { "primitive-mode" [ drop triangles-mode ] } + { "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] } + { "uniforms" [ ] } + { "vertex-array" [ bunny>> vertex-array>> ] } + { "indexes" [ bunny>> index-elements>> ] } + { "framebuffer" [ sobel>> framebuffer>> ] } + } render ] bi ; : ( 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 - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap sobel>> - [ >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + sobel>> { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ ] } + { "vertex-array" [ vertex-array>> ] } + } 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 - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap loading>> - [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + loading>> { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] } + { "vertex-array" [ vertex-array>> ] } + } render ; M: bunny-world draw-world* dup bunny>> diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index df323d3c82..9ac943150d 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays game-loop game-worlds generalizations -gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel -literals math math.matrices math.order math.vectors +USING: accessors arrays combinators.tuple game-loop game-worlds +generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd +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 @@ -97,13 +97,12 @@ AFTER: raytrace-world tick* spheres>> [ tick-sphere ] each ; M: raytrace-world draw-world* - render-set new - triangle-strip-mode >>primitive-mode - T{ index-range f 0 4 } >>indexes - swap - [ >>uniforms ] - [ vertex-array>> >>vertex-array ] bi - render ; + { + { "primitive-mode" [ drop triangle-strip-mode ] } + { "indexes" [ drop T{ index-range f 0 4 } ] } + { "uniforms" [ ] } + { "vertex-array" [ vertex-array>> ] } + } render ; M: raytrace-world pref-dim* drop { 1024 768 } ; M: raytrace-world tick-length drop 1000 30 /i ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 65a99f94d7..feb2f3f768 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: accessors alien alien.c-types alien.structs arrays assocs 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.textures.private half-floats images kernel lexer locals @@ -474,13 +474,22 @@ M: vertex-array dispose PRIVATE> TUPLE: render-set - { primitive-mode primitive-mode } - { vertex-array vertex-array } - { uniforms uniform-tuple } - { indexes vertex-indexes initial: T{ index-range } } - { instances ?integer initial: f } - { framebuffer any-framebuffer initial: system-framebuffer } - { output-attachments sequence initial: { default-attachment } } ; + { primitive-mode primitive-mode read-only } + { vertex-array vertex-array read-only } + { uniforms uniform-tuple read-only } + { indexes vertex-indexes initial: T{ index-range } read-only } + { instances ?integer initial: f read-only } + { framebuffer any-framebuffer initial: system-framebuffer read-only } + { output-attachments sequence initial: { default-attachment } read-only } ; + +: ( x quot-assoc -- render-set ) + render-set swap make-tuple ; inline + +: 2 ( x y quot-assoc -- render-set ) + render-set swap 2make-tuple ; inline + +: 3 ( x y z quot-assoc -- render-set ) + render-set swap 3make-tuple ; inline : render ( render-set -- ) { From dd2bbc51b378a4ea88e12608b5656515dd57cc19 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 21:12:04 -0500 Subject: [PATCH 11/38] unix.types: define alias; use it in calendar.unix to avoid clobbering data --- basis/calendar/unix/unix.factor | 4 ++-- basis/unix/types/freebsd/freebsd.factor | 4 +++- basis/unix/types/linux/linux.factor | 4 +++- basis/unix/types/macosx/macosx.factor | 4 +++- basis/unix/types/netbsd/netbsd.factor | 4 +++- basis/unix/types/openbsd/openbsd.factor | 4 +++- 6 files changed, 17 insertions(+), 7 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 9848d0c164..aa4e8f7e9a 100644 --- a/basis/calendar/unix/unix.factor +++ b/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 localtime ; + f time localtime ; : timezone-name ( -- string ) get-time tm-zone ; diff --git a/basis/unix/types/freebsd/freebsd.factor b/basis/unix/types/freebsd/freebsd.factor index e012ebcbd6..215e344231 100644 --- a/basis/unix/types/freebsd/freebsd.factor +++ b/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: diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index b0340c1778..a3dddfc93e 100644 --- a/basis/unix/types/linux/linux.factor +++ b/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: \ No newline at end of file diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor index ac62776ed7..421efa60bc 100644 --- a/basis/unix/types/macosx/macosx.factor +++ b/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: \ No newline at end of file diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index b5b0ffe661..7dacc97061 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/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: + cell-bits { { 32 [ "unix.types.netbsd.32" require ] } { 64 [ "unix.types.netbsd.64" require ] } diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor index 8938afa936..7c8fbd2b9d 100644 --- a/basis/unix/types/openbsd/openbsd.factor +++ b/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: \ No newline at end of file From bba46d2b3091dc9574e017fd948ba145d2b04342 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 22:32:02 -0500 Subject: [PATCH 12/38] improve uniform-tuple interface in gpu.render. uniform-tuples can now contain other uniform-tuples to represent struct uniforms. use glUniform*v to blast uniform arrays in one shot. s/-/_/ in slot names so they look more factorish on the CPU side --- extra/gpu/demos/bunny/bunny.factor | 24 +-- extra/gpu/demos/raytrace/raytrace.factor | 42 ++--- extra/gpu/render/render.factor | 218 +++++++++++++++++------ 3 files changed, 193 insertions(+), 91 deletions(-) diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index a1b42d9f12..f975b21245 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -53,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 } - { "color" float-uniform 4 } - { "ambient" float-uniform 4 } - { "diffuse" float-uniform 4 } - { "shininess" float-uniform 1 } ; + { "light-position" vec3-uniform f } + { "color" vec4-uniform f } + { "ambient" vec4-uniform f } + { "diffuse" vec4-uniform f } + { "shininess" float-uniform f } ; UNIFORM-TUPLE: sobel-uniforms - { "texcoord_scale" float-uniform 2 } - { "color_texture" texture-uniform 1 } - { "normal_texture" texture-uniform 1 } - { "depth_texture" texture-uniform 1 } - { "line_color" float-uniform 4 } ; + { "texcoord-scale" vec2-uniform f } + { "color-texture" texture-uniform f } + { "normal-texture" texture-uniform f } + { "depth-texture" texture-uniform f } + { "line-color" vec4-uniform f } ; UNIFORM-TUPLE: loading-uniforms - { "texcoord_scale" float-uniform 2 } - { "loading_texture" texture-uniform 1 } ; + { "texcoord-scale" vec2-uniform f } + { "loading-texture" texture-uniform f } ; : numbers ( str -- seq ) " " split [ string>number ] map sift ; diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor index 9ac943150d..339f192416 100644 --- a/extra/gpu/demos/raytrace/raytrace.factor +++ b/extra/gpu/demos/raytrace/raytrace.factor @@ -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 } } - { "fov" float-uniform 2 } - - { "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 } + { "mv-inv-matrix" mat4-uniform f } + { "fov" vec2-uniform f } - { "floor_height" float-uniform 1 } - { "floor_color[0]" float-uniform 4 } - { "floor_color[1]" float-uniform 4 } - { "background_color" float-uniform 4 } - { "light_direction" float-uniform 3 } ; + { "spheres" sphere-uniforms 4 } + + { "floor-height" float-uniform f } + { "floor-color" vec4-uniform 2 } + { "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 - first4 [ first3 ] 4 napply + [ [ sphere-center ] [ radius>> ] [ color>> ] tri sphere-uniforms boa ] map ] tri -30.0 ! floor_height - { 1.0 0.0 0.0 1.0 } ! floor_color[0] - { 1.0 1.0 1.0 1.0 } ! floor_color[1] + { { 1.0 0.0 0.0 1.0 } { 1.0 1.0 1.0 1.0 } } ! floor_color { 0.15 0.15 1.0 1.0 } ! background_color { 0.0 -1.0 -0.1 } ! light_direction raytrace-uniforms boa ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index feb2f3f768..a0457e8082 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -1,6 +1,6 @@ ! (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 combinators.tuple destructors fry generic generic.parser gpu gpu.buffers gpu.framebuffers gpu.framebuffers.private gpu.shaders gpu.state gpu.textures @@ -8,12 +8,12 @@ gpu.textures.private half-floats images kernel lexer locals math math.order math.parser namespaces opengl opengl.gl parser quotations sequences slots sorting 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: uniform-dim integer sequence ; +UNION: ?integer integer POSTPONE: f ; TUPLE: vertex-attribute { name ?string read-only initial: f } @@ -23,15 +23,44 @@ TUPLE: vertex-attribute 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: "" } - { uniform-type uniform-type read-only initial: float-uniform } - { dim uniform-dim read-only initial: 4 } ; + { name string read-only initial: "" } + { uniform-type class read-only initial: float-uniform } + { dim ?integer read-only initial: f } ; VARIANT: index-type ubyte-indexes @@ -50,8 +79,6 @@ TUPLE: multi-index-range C: multi-index-range -UNION: ?integer integer POSTPONE: f ; - TUPLE: index-elements { ptr gpu-data-ptr read-only } { count integer read-only } @@ -242,19 +269,23 @@ 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 ; +: uniform-type-texture-units ( uniform-type -- units ) + dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ; + :: [bind-uniform-texture] ( uniform index -- quot ) uniform name>> reader-word :> value>>-word { index swap value>>-word (bind-texture-unit) } >quotation ; @@ -272,61 +303,144 @@ M: uniform-tuple bind-uniforms nip texture-uniforms-cleave cleave } >quotation ; -:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot ) - uniform name>> :> name +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{ - { { bool-uniform 1 } [ >c-bool glUniform1i ] } - { { int-uniform 1 } [ glUniform1i ] } - { { uint-uniform 1 } [ glUniform1ui ] } - { { float-uniform 1 } [ glUniform1f ] } + type H{ + { bool-uniform { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv } } + { int-uniform { dim swap >int-array glUniform1iv } } + { uint-uniform { dim swap >uint-array glUniform1uiv } } + { float-uniform { dim swap >float-array glUniform1fv } } - { { bool-uniform 2 } [ [ >c-bool ] map first2 glUniform2i ] } - { { int-uniform 2 } [ first2 glUniform2i ] } - { { uint-uniform 2 } [ first2 glUniform2ui ] } - { { float-uniform 2 } [ first2 glUniform2f ] } + { bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv } } + { ivec2-uniform { dim swap int-array{ } concat-as glUniform2i } } + { uvec2-uniform { dim swap uint-array{ } concat-as glUniform2ui } } + { vec2-uniform { dim swap float-array{ } concat-as glUniform2f } } - { { bool-uniform 3 } [ [ >c-bool ] map first3 glUniform3i ] } - { { int-uniform 3 } [ first3 glUniform3i ] } - { { uint-uniform 3 } [ first3 glUniform3ui ] } - { { float-uniform 3 } [ first3 glUniform3f ] } + { bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv } } + { ivec3-uniform { dim swap int-array{ } concat-as glUniform3i } } + { uvec3-uniform { dim swap uint-array{ } concat-as glUniform3ui } } + { vec3-uniform { dim swap float-array{ } concat-as glUniform3f } } - { { bool-uniform 4 } [ [ >c-bool ] map first4 glUniform4i ] } - { { int-uniform 4 } [ first4 glUniform4i ] } - { { uint-uniform 4 } [ first4 glUniform4ui ] } - { { float-uniform 4 } [ first4 glUniform4f ] } + { bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv } } + { ivec4-uniform { dim swap int-array{ } concat-as glUniform4iv } } + { uvec4-uniform { dim swap uint-array{ } concat-as glUniform4uiv } } + { vec4-uniform { dim swap float-array{ } concat-as glUniform4fv } } - { { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv ] } - { { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] } - { { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] } + { mat2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv } } + { mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } } + { 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 ] } - { { 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 } } + { texture-uniform { drop dim iota [ texture-unit + ] int-array{ } map-as glUniform1iv } } } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot - uniform uniform-type>> texture-uniform = - [ texture-unit 1 + ] [ texture-unit ] if + type uniform-type-texture-units dim * texture-unit + 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 ; + +: all-uniform-tuple-slots ( class -- slots ) + dup "uniform-tuple-slots" word-prop + [ swap superclass all-uniform-tuple-slots append ] [ drop { } ] if* ; + +:: [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 - - { - 2dup next-method - uniforms-cleave 2cleave - } >quotation ; + first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot + + { 2dup next-method } bind-quot [ ] append-as ; : define-uniform-tuple-methods ( class superclass uniforms -- ) [ @@ -386,8 +500,8 @@ padding-no [ 0 ] initialize [ [ uniform>slot ] map define-tuple-class ] [ define-uniform-tuple-methods ] [ - [ "uniform-tuple-texture-units" word-prop 0 or ] - [ [ uniform-type>> texture-uniform = ] filter length ] bi* + + [ uniform-type-texture-units ] + [ [ uniform-type>> uniform-type-texture-units ] [ + ] map-reduce ] bi* + "uniform-tuple-texture-units" set-word-prop ] [ nip "uniform-tuple-slots" set-word-prop ] From 2a194ea78000d6a3e885e87bd748dab70caaa27c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Jul 2009 13:01:21 -0500 Subject: [PATCH 13/38] bind textures out of uniform structs and arrays --- extra/gpu/render/render-tests.factor | 117 +++++++++++++++++++++++++++ extra/gpu/render/render.factor | 81 ++++++++++++------- 2 files changed, 167 insertions(+), 31 deletions(-) create mode 100644 extra/gpu/render/render-tests.factor diff --git a/extra/gpu/render/render-tests.factor b/extra/gpu/render/render-tests.factor new file mode 100644 index 0000000000..90a8dcc2cb --- /dev/null +++ b/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 + diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index a0457e8082..51bd549b7a 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -207,8 +207,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 -- ) - [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline +: (bind-texture-unit) ( texture texture-unit -- ) + swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot ) vertex-attribute name>> :> name @@ -286,22 +286,46 @@ M: uniform-tuple bind-uniforms : uniform-type-texture-units ( uniform-type -- units ) dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ; -:: [bind-uniform-texture] ( uniform index -- quot ) - uniform name>> reader-word :> value>>-word - { index swap value>>-word (bind-texture-unit) } >quotation ; +: all-uniform-tuple-slots ( class -- slots ) + dup "uniform-tuple-slots" word-prop + [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ; -:: [bind-uniform-textures] ( superclass uniforms -- quot ) - superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit - superclass \ bind-uniform-textures method :> next-method - 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 ; +: uniform-type-texture-accessors ( uniform-type -- accessors ) + 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] @@ -342,7 +366,7 @@ DEFER: [bind-uniform-tuple] { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } } { mat4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv } } - { texture-uniform { drop dim iota [ texture-unit + ] int-array{ } map-as glUniform1iv } } + { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } } } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot type uniform-type-texture-units dim * texture-unit + @@ -391,10 +415,6 @@ DEFER: [bind-uniform-tuple] type uniform-type-texture-units texture-unit + pre-quot value-quot append ; -: all-uniform-tuple-slots ( class -- slots ) - dup "uniform-tuple-slots" word-prop - [ swap superclass all-uniform-tuple-slots append ] [ drop { } ] if* ; - :: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot ) dim [ @@ -444,8 +464,9 @@ TR: hyphens>underscores "-" "_" ; : define-uniform-tuple-methods ( class superclass uniforms -- ) [ - [ \ bind-uniform-textures create-method-in ] 2dip - [bind-uniform-textures] define + 2drop + [ \ bind-uniform-textures create-method-in ] + [ [bind-uniform-textures] ] bi define ] [ [ \ bind-uniforms create-method-in ] 2dip [bind-uniforms] define @@ -498,22 +519,21 @@ padding-no [ 0 ] initialize : (define-uniform-tuple) ( class superclass uniforms -- ) { [ [ uniform>slot ] map define-tuple-class ] - [ define-uniform-tuple-methods ] [ [ uniform-type-texture-units ] - [ [ uniform-type>> uniform-type-texture-units ] [ + ] map-reduce ] 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 -- ) @@ -540,8 +560,7 @@ SYNTAX: VERTEX-STRUCT: scan scan-word define-vertex-struct ; : define-uniform-tuple ( class superclass uniforms -- ) - [ (define-uniform-tuple) ] - [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ; + (define-uniform-tuple) ; inline SYNTAX: UNIFORM-TUPLE: parse-uniform-tuple-definition define-uniform-tuple ; From 733c208f8c7c68872786f0148fc693e6970e8314 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Jul 2009 13:39:28 -0500 Subject: [PATCH 14/38] doc updates for uniform-tuple changes --- extra/gpu/render/render-docs.factor | 99 +++++++++++++++++++++++++---- 1 file changed, 88 insertions(+), 11 deletions(-) diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index 68afc68f9b..8e761be13c 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -47,7 +47,7 @@ HELP: UNIFORM-TUPLE: { "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,8 +55,26 @@ $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." } -{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } } +{ "Vector uniforms take their values from Factor " { $link sequence } "s 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 types 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." } ; @@ -73,7 +91,7 @@ HELP: VERTEX-STRUCT: { $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 { $values @@ -84,6 +102,15 @@ HELP: buffer>vertex-array { vertex-array buffer>vertex-array } related-words +HELP: bvec2-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ; + +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 { "class" class } { "superclass" class } { "uniforms" sequence } @@ -105,8 +132,6 @@ HELP: define-vertex-struct HELP: float-uniform { $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ; -{ bool-uniform int-uniform float-uniform texture-uniform } related-words - { index-elements index-range multi-index-elements multi-index-range } related-words HELP: index-elements @@ -130,7 +155,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 +163,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 +181,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 @@ -200,7 +261,7 @@ HELP: render-set { 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 +279,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,13 +290,29 @@ 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: uvec2-uniform +{ $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: uvec3-uniform +{ $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." } ; + +HELP: uvec4-uniform +{ $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: vec2-uniform +{ $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: vec3-uniform +{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component float vector uniform parameter." } ; + +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." } ; + 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 } " or " { $link buffer>vertex-array } " words." } ; From 3759cd7efcbd9594532c80d371e6f3a08e44c85e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Jul 2009 14:58:45 -0500 Subject: [PATCH 15/38] update gpu.util.wasd to match uniform tuple changes --- extra/gpu/render/render-docs.factor | 4 ++-- extra/gpu/util/wasd/wasd.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index 8e761be13c..f198558b06 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -72,7 +72,7 @@ $nl "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 types above." } +{ "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." @@ -130,7 +130,7 @@ HELP: define-vertex-struct { $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." } ; { index-elements index-range multi-index-elements multi-index-range } related-words diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index 34051730fb..b0a3d8179a 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/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 } } - { "p_matrix" float-uniform { 4 4 } } ; + { "mv_matrix" mat4-uniform f } + { "p_matrix" mat4-uniform f } ; CONSTANT: -pi/2 $[ pi -2.0 / ] CONSTANT: pi/2 $[ pi 2.0 / ] From bad8e0593765df1d35307445050e8453b397cfa0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 15:48:10 -0500 Subject: [PATCH 16/38] Disallow C functions and parameter names that contain an asterisk --- basis/alien/parser/parser.factor | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index df1dd15bfb..8e050b3950 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,11 +1,20 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! 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 ; IN: alien.parser +ERROR: invalid-c-name name ; + +M: invalid-c-name summary + drop "The C pointer asterisk must be part of the type string." ; + +: check-c-name ( string -- string ) + dup [ CHAR: * = ] any? [ invalid-c-name ] when ; + : parse-arglist ( parameters return -- types effect ) - [ 2 group unzip [ "," ?tail drop ] map ] + [ 2 group unzip [ "," ?tail drop check-c-name ] map ] [ [ { } ] [ 1array ] if-void ] bi* ; @@ -13,7 +22,7 @@ IN: alien.parser '[ _ _ _ _ alien-invoke ] ; :: make-function ( return library function parameters -- word quot effect ) - function create-in dup reset-generic + function check-c-name create-in dup reset-generic return library function parameters return parse-arglist [ function-quot ] dip ; From 78bbf96a6d23ed6799d8a72f93eb2ae30d1c93fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 15:54:57 -0500 Subject: [PATCH 17/38] move signed-le> to io.binary, clean up using list for math.bitwise --- basis/math/bitwise/bitwise.factor | 13 ++----------- core/io/binary/binary.factor | 7 +++++++ 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index cea944a6e8..bed065a800 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/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 -math.bits sequences.private words namespaces macros -hints combinators fry io.binary combinators.smart ; +USING: arrays assocs combinators combinators.smart fry kernel +macros math math.bits sequences sequences.private words ; 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 ) - signed-le> ; - : >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor index d2e50c2a6a..cf2781aac0 100644 --- a/core/io/binary/binary.factor +++ b/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 ) + signed-le> ; From 9e7bfc202bce37c339e50fa77cb59f8fa2130a75 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 15:59:55 -0500 Subject: [PATCH 18/38] remove experimental constructors features --- extra/constructors/constructors-tests.factor | 47 +------------------- extra/constructors/constructors.factor | 12 +---- 2 files changed, 4 insertions(+), 55 deletions(-) diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor index 59ecb8ff77..1e098645bf 100644 --- a/extra/constructors/constructors-tests.factor +++ b/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 a>> ] unit-test [ 2 ] [ 0 0 a>> ] unit-test -[ 2 ] [ 0 0 0 a>> ] unit-test -[ 3 ] [ 0 0 0 0 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 ] unit-test - - -TUPLE: default { a integer initial: 0 } ; - -CONSTRUCTOR: default ( -- obj ) ; - -[ 0 ] [ a>> ] unit-test - - -TUPLE: inherit1 a ; -TUPLE: inherit2 < inherit1 a ; - -CONSTRUCTOR: inherit2 ( a -- obj ) ; - -[ T{ inherit2 f f 100 } ] [ 100 ] 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 ] [ hp>> ] unit-test - -FORWARD-CONSTRUCTOR: inherit5 ( -- obj ) - 5 >>hp - 10 >>max-hp ; - -[ 5 ] [ hp>> ] unit-test +[ 3 ] [ 0 0 0 a>> ] unit-test +[ 4 ] [ 0 0 0 0 a>> ] unit-test diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor index b8fe598f84..3cee399925 100644 --- a/extra/constructors/constructors.factor +++ b/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 -- ) - 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? -- ) +:: define-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: 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 ; +SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ; "initializers" create-vocab drop From 37a9f01adced7b062f80b1d4365cf840f0561796 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 17:39:12 -0500 Subject: [PATCH 19/38] fix typo in x11 binding --- basis/x11/xlib/xlib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 65338dc88b..c8a4bfa0dc 100644 --- a/basis/x11/xlib/xlib.factor +++ b/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 * ; From 555309ba864903f1fe271c76cfe2076723532886 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 17:49:04 -0500 Subject: [PATCH 20/38] fix another typo in ffi --- basis/cairo/ffi/ffi.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index 2930843ad7..ce5f0cc233 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/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 ) ; From 9bb38b870c39cb41ca7beb6a8f955b10c8dcb2ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 18:05:09 -0500 Subject: [PATCH 21/38] allow FUNCTION: to parse pointers in the name field --- basis/alien/parser/parser.factor | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 8e050b3950..8e2fe82578 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,27 +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 -summary ; +summary math ; IN: alien.parser -ERROR: invalid-c-name name ; - -M: invalid-c-name summary - drop "The C pointer asterisk must be part of the type string." ; - -: check-c-name ( string -- string ) - dup [ CHAR: * = ] any? [ invalid-c-name ] when ; +: normalize-c-arg ( type name -- type' name' ) + [ length ] + [ + [ CHAR: * = ] trim-head + [ length - CHAR: * append ] keep + ] bi ; : parse-arglist ( parameters return -- types effect ) - [ 2 group unzip [ "," ?tail drop check-c-name ] map ] + [ + 2 group [ first2 normalize-c-arg 2array ] map + unzip [ "," ?tail drop check-c-name ] map + ] [ [ { } ] [ 1array ] if-void ] bi* ; : 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 check-c-name create-in dup reset-generic return library function parameters return parse-arglist [ function-quot ] dip ; From f7b2e4a155fd2d297bdd0740f0f2329e8fe98e42 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Jul 2009 18:14:07 -0500 Subject: [PATCH 22/38] remove call to check-c-name --- basis/alien/parser/parser.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 8e2fe82578..19ab08c03c 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -15,7 +15,7 @@ IN: alien.parser : parse-arglist ( parameters return -- types effect ) [ 2 group [ first2 normalize-c-arg 2array ] map - unzip [ "," ?tail drop check-c-name ] map + unzip [ "," ?tail drop ] map ] [ [ { } ] [ 1array ] if-void ] bi* ; @@ -25,7 +25,7 @@ IN: alien.parser :: make-function ( return! library function! parameters -- word quot effect ) return function normalize-c-arg function! return! - function check-c-name create-in dup reset-generic + function create-in dup reset-generic return library function parameters return parse-arglist [ function-quot ] dip ; From 13cf80c0c7fa6a8935ca99ed09278e57aee64ad0 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 24 Jul 2009 15:33:45 +1200 Subject: [PATCH 23/38] alien.inline.syntax: changed RAW-C: to " } +{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; diff --git a/extra/alien/inline/syntax/syntax.factor b/extra/alien/inline/syntax/syntax.factor index 6cef56f9b2..ce18616bc3 100644 --- a/extra/alien/inline/syntax/syntax.factor +++ b/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: " parse-multiline-string raw-c ; From abf1ae47025baa84dbab388a63639b6c27e9ad94 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 24 Jul 2009 18:24:27 +1200 Subject: [PATCH 24/38] alien.inline: define-c-library: set "c-library" --- extra/alien/inline/inline.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/alien/inline/inline.factor b/extra/alien/inline/inline.factor index 62c6102a86..84c3450102 100644 --- a/extra/alien/inline/inline.factor +++ b/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 ; From c458904fd7012cff548e3fa064a4e2baace154c0 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 24 Jul 2009 18:24:46 +1200 Subject: [PATCH 25/38] alien.marshall: docs lint fix --- extra/alien/marshall/marshall-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor index deac9fd186..7b321bd992 100644 --- a/extra/alien/marshall/marshall-docs.factor +++ b/extra/alien/marshall/marshall-docs.factor @@ -330,7 +330,7 @@ HELP: out-arg-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." From 5336d717500b8f2817df6a547dea8cf24cc08c41 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 18:05:23 -0500 Subject: [PATCH 26/38] sequences: update docs a bit --- core/sequences/sequences-docs.factor | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0a301b3e38..9277a04b6e 100755 --- a/core/sequences/sequences-docs.factor +++ b/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 } "." +{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link } ". 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." } ; @@ -1357,7 +1357,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 +1430,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 +1454,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:" From c762d2b422ec303c0a86915813f8e3f05c6278bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Jul 2009 18:09:14 -0500 Subject: [PATCH 27/38] scaffold tools now uses the boolean type instead of "a boolean" --- basis/tools/scaffold/scaffold.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 5fdc5ce087..089bad3158 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/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 } From 6451ed542d2bc6e6e3aa057968f5680f9b736a98 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Jul 2009 18:10:53 -0500 Subject: [PATCH 28/38] document a word in sequences --- core/sequences/sequences-docs.factor | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0a301b3e38..2122b1ca08 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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 @@ -1591,6 +1605,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" From 01a0bf7c36b210656e71ffff3b7f3ea954d5cd82 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Jul 2009 18:11:51 -0500 Subject: [PATCH 29/38] add more links to floating point words in docs --- core/math/floats/floats-docs.factor | 54 ++++++++++++++++++----------- core/math/math-docs.factor | 15 +++++--- 2 files changed, 45 insertions(+), 24 deletions(-) diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index 5549ef79e9..dfa5779c47 100644 --- a/core/math/floats/floats-docs.factor +++ b/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." } ; @@ -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 "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 } +"Constructing floating point NaNs:" +{ $subsection } +"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" diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index b920ff54ea..5cc7328580 100644 --- a/core/math/math-docs.factor +++ b/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 } "." } ; From f034be3c9ef4994c5c92baf3dcf63882c7924eda Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 24 Jul 2009 21:04:49 -0500 Subject: [PATCH 30/38] nitpick --- core/math/floats/floats-docs.factor | 10 +++++----- core/math/math-docs.factor | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index dfa5779c47..1305f2a18d 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -9,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 @@ -74,7 +74,7 @@ HELP: float>= ( x y -- ? ) 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." +"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" } diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 5cc7328580..55a50cd5d7 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -289,11 +289,11 @@ HELP: 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 From eabf32a32e02e6489a752c812d272440de37be8a Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 25 Jul 2009 16:57:12 +1200 Subject: [PATCH 31/38] alien.cxx.syntax: fix tests --- extra/alien/cxx/syntax/syntax-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor index 24f685a197..b8b08515de 100644 --- a/extra/alien/cxx/syntax/syntax-tests.factor +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -40,7 +40,7 @@ COMPILE-AS-C++ C-INCLUDE: -RAW-C: + C++-CLASS: alpha c++-root C++-CLASS: beta alpha From 33395eeabdbd98065536b2cb0a2847db1b655c7a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Jul 2009 11:30:59 -0500 Subject: [PATCH 32/38] move vertex-formats and vertex-arrays to gpu.shaders so we can use them for transform feedback formats --- extra/gpu/render/render-docs.factor | 75 +--------- extra/gpu/render/render.factor | 167 ++------------------- extra/gpu/shaders/shaders-docs.factor | 73 ++++++++- extra/gpu/shaders/shaders.factor | 203 ++++++++++++++++++++++++-- extra/gpu/util/util.factor | 2 +- 5 files changed, 280 insertions(+), 240 deletions(-) diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index f198558b06..187f08a7ea 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -34,13 +34,6 @@ HELP: } { $description "Constructs a " { $link multi-index-range } " tuple." } ; -HELP: -{ $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 } @@ -78,30 +71,9 @@ $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 } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ; -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 buffer>vertex-array } related-words - HELP: bvec2-uniform { $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ; @@ -117,18 +89,6 @@ 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 } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ; @@ -254,9 +214,10 @@ 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 "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 "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." } +} } +{ $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." } ; { render render-set } related-words @@ -313,29 +274,6 @@ HELP: vec3-uniform 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." } ; -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 } " 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" } "." } ; - 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." { $list @@ -349,11 +287,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 } -{ $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: } ; diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 51bd549b7a..3d2fef3807 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -3,24 +3,17 @@ USING: accessors alien alien.c-types alien.structs arrays assocs classes classes.mixin classes.parser classes.singleton 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.textures.private half-floats images kernel lexer locals -math math.order math.parser namespaces opengl opengl.gl parser -quotations sequences slots sorting specialized-arrays.alien -specialized-arrays.float specialized-arrays.int +gpu.framebuffers.private gpu.shaders gpu.shaders.private gpu.state +gpu.textures gpu.textures.private half-floats images kernel +lexer locals math math.order math.parser namespaces opengl +opengl.gl parser quotations sequences slots sorting +specialized-arrays.alien specialized-arrays.float specialized-arrays.int 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 ; -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 @@ -111,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 ; > 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 ] } @@ -210,56 +163,6 @@ M: multi-index-elements render-vertex-indexes : (bind-texture-unit) ( texture texture-unit -- ) 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 glVertexAttribIPointer } >quotation - ] - } - [ - { - name attribute-index [ glEnableVertexAttribArray ] keep - dim gl-type normalize? stride offset - } >quotation :> dip-block - - { dip-block dip 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 -- ) @@ -510,12 +413,6 @@ padding-no [ 0 ] initialize "(" ")" 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 ] @@ -536,55 +433,12 @@ padding-no [ 0 ] initialize 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) ; inline 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 ; - -: ( 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 ] dip 2array 1array ; inline - -: vertex-array-buffer ( vertex-array -- vertex-buffer ) - vertex-buffers>> first ; - +UNION: ?any-framebuffer any-framebuffer POSTPONE: f ; + TUPLE: render-set { primitive-mode primitive-mode read-only } { vertex-array vertex-array read-only } { uniforms uniform-tuple read-only } { indexes vertex-indexes initial: T{ index-range } read-only } { instances ?integer initial: f read-only } - { framebuffer any-framebuffer initial: system-framebuffer read-only } + { framebuffer ?any-framebuffer initial: system-framebuffer read-only } { output-attachments sequence initial: { default-attachment } read-only } ; : ( x quot-assoc -- render-set ) @@ -631,7 +487,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_RASTERIZER_DISCARD glEnable ] if* + ] [ [ vertex-array>> program-instance>> ] [ framebuffer>> ] @@ -644,5 +504,6 @@ TUPLE: render-set [ render-vertex-indexes-instanced ] [ render-vertex-indexes ] if* ] + [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ] } cleave ; inline diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index cac61114d6..456a76e5ce 100755 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/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: @@ -16,6 +17,13 @@ HELP: } { $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: +{ $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 ;" } { $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance." } ; @@ -32,6 +40,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 +61,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 buffer>vertex-array } related-words + HELP: compile-shader-error { $class-description "An error compiling the source for a " { $link shader } "." { $list @@ -48,6 +77,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." } ; @@ -103,6 +144,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 } " 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 +175,11 @@ ARTICLE: "gpu.shaders" "Shader objects" "A program must be instantiated for each graphics context it is used in:" { $subsection } "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 } +{ $subsection buffer>vertex-array } +{ $subsection POSTPONE: VERTEX-FORMAT: } ; ABOUT: "gpu.shaders" diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index e11fa639b4..e3b4482c24 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -1,17 +1,29 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays assocs combinators -combinators.short-circuit definitions destructors gpu -io.encodings.ascii io.files io.pathnames kernel lexer -locals math math.parser memoize multiline namespaces -opengl.gl opengl.shaders parser sequences +USING: accessors alien alien.c-types alien.structs arrays +assocs classes.mixin classes.parser classes.singleton +combinators combinators.short-circuit definitions destructors +generic.parser gpu gpu.buffers hashtables +images io.encodings.ascii io.files io.pathnames kernel lexer +locals math math.parser memoize multiline namespaces opengl +opengl.gl opengl.shaders parser quotations sequences specialized-arrays.int splitting strings ui.gadgets.worlds -variants hashtables vectors vocabs vocabs.loader words +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 ; + +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 + TUPLE: shader { name word read-only initial: t } { kind shader-kind read-only } @@ -25,6 +37,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 +48,136 @@ 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 ; + > vertex-type-size ] [ dim>> ] bi * ; + +: vertex-attributes-size ( vertex-attributes -- size ) + [ vertex-attribute-size ] [ + ] map-reduce ; + +:: [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 glVertexAttribIPointer } >quotation + ] + } + [ + { + name attribute-index [ glEnableVertexAttribArray ] keep + dim gl-type normalize? stride offset + } >quotation :> dip-block + + { dip-block dip 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 ; + +: 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 +210,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 ; + +: ( 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 ] dip 2array 1array ; 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 +266,6 @@ TUPLE: link-program-error program log ; DEFER: -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 ; - Date: Sat, 25 Jul 2009 15:50:38 -0500 Subject: [PATCH 33/38] add a buffer-range tuple to represent a subset of a buffer. add support for specifying a transform feedback format to GLSL-PROGRAM: syntax --- extra/gpu/buffers/buffers.factor | 26 +++++++++++------ extra/gpu/render/render.factor | 29 +------------------ .../shaders/prettyprint/prettyprint.factor | 12 +++++--- extra/gpu/shaders/shaders.factor | 15 ++++++++-- extra/gpu/textures/textures.factor | 2 +- 5 files changed, 40 insertions(+), 44 deletions(-) diff --git a/extra/gpu/buffers/buffers.factor b/extra/gpu/buffers/buffers.factor index 187f194e7d..ce53a25422 100644 --- a/extra/gpu/buffers/buffers.factor +++ b/extra/gpu/buffers/buffers.factor @@ -54,6 +54,12 @@ TUPLE: buffer < gpu-object { pixel-pack-buffer [ GL_PIXEL_PACK_BUFFER ] } } case ; inline +: get-buffer-int ( target enum -- value ) + 0 [ glGetBufferParameteriv ] keep *int ; + +: bind-buffer ( buffer -- target ) + [ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; + PRIVATE> M: buffer dispose @@ -64,11 +70,17 @@ TUPLE: buffer-ptr { offset integer read-only } ; C: buffer-ptr +TUPLE: buffer-range < buffer-ptr + { size integer read-only } ; +C: buffer-range + UNION: gpu-data-ptr buffer-ptr c-ptr ; +: buffer-size ( buffer -- size ) + bind-buffer GL_BUFFER_SIZE get-buffer-int ; + :: allocate-buffer ( buffer size initial-data -- ) - buffer kind>> gl-target :> target - target buffer handle>> glBindBuffer + buffer bind-buffer :> target target size initial-data buffer gl-buffer-usage glBufferData ; : ( upload usage kind size initial-data -- buffer ) @@ -81,15 +93,13 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ; :: update-buffer ( buffer-ptr size data -- ) buffer-ptr buffer>> :> buffer - buffer kind>> gl-target :> target - target buffer handle>> glBindBuffer + buffer bind-buffer :> target 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 :> data - target buffer handle>> glBindBuffer target buffer-ptr offset>> size data glGetBufferSubData data ; @@ -102,9 +112,7 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ; size glCopyBufferSubData ; :: with-mapped-buffer ( buffer access quot: ( alien -- ) -- ) - buffer kind>> gl-target :> target - - target buffer handle>> glBindBuffer + buffer bind-buffer :> target target access gl-access glMapBuffer quot call diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 3d2fef3807..6ea72d53a5 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -386,33 +386,6 @@ TR: hyphens>underscores "-" "_" ; ] } } 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 ; - : (define-uniform-tuple) ( class superclass uniforms -- ) { [ [ uniform>slot ] map define-tuple-class ] @@ -490,7 +463,7 @@ TUPLE: render-set [ framebuffer>> [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ] - [ GL_RASTERIZER_DISCARD glEnable ] if* + [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if* ] [ [ vertex-array>> program-instance>> ] diff --git a/extra/gpu/shaders/prettyprint/prettyprint.factor b/extra/gpu/shaders/prettyprint/prettyprint.factor index 128333ce3c..3d739a55f3 100644 --- a/extra/gpu/shaders/prettyprint/prettyprint.factor +++ b/extra/gpu/shaders/prettyprint/prettyprint.factor @@ -3,10 +3,14 @@ IN: gpu.shaders.prettyprint M: compile-shader-error error. "The GLSL shader " write - [ shader>> name>> pprint-short " failed to compile." write nl ] - [ log>> write nl ] bi ; + [ shader>> name>> pprint-short " failed to compile." print ] + [ log>> print ] bi ; M: link-program-error error. "The GLSL program " write - [ shader>> name>> pprint-short " failed to link." write nl ] - [ log>> write nl ] bi ; + [ shader>> name>> pprint-short " failed to link." print ] + [ log>> print ] bi ; + +M: too-many-feedback-formats-error error. + drop + "Only one transform feedback format can be specified for a program." print ; diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index e3b4482c24..933522b3d0 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -16,6 +16,8 @@ VARIANT: shader-kind UNION: ?string string POSTPONE: f ; +ERROR: too-many-feedback-formats-error formats ; + TUPLE: vertex-attribute { name ?string read-only initial: f } { component-type component-type read-only initial: float-components } @@ -23,6 +25,7 @@ TUPLE: vertex-attribute { normalize? boolean read-only initial: f } ; MIXIN: vertex-format +UNION: ?vertex-format vertex-format POSTPONE: f ; TUPLE: shader { name word read-only initial: t } @@ -37,7 +40,7 @@ TUPLE: program { filename read-only } { line integer read-only } { shaders array read-only } - { feedback-format vertex-format read-only } + { feedback-format ?vertex-format read-only } { instances hashtable read-only } ; TUPLE: shader-instance < gpu-object @@ -316,6 +319,14 @@ DEFER: 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 -- ) @@ -368,7 +379,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 ; diff --git a/extra/gpu/textures/textures.factor b/extra/gpu/textures/textures.factor index 5740799fbe..c84f3a2123 100644 --- a/extra/gpu/textures/textures.factor +++ b/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 [ glGetTexLevelParameterfv ] keep *float ; -: get-texture-int ( texture level enum -- value ) +: get-texture-int ( target level enum -- value ) 0 [ glGetTexLevelParameteriv ] keep *int ; : ?product ( x -- y ) From eeb02815bc735882393f0d60b2c39b5871fe9b9d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Jul 2009 21:19:56 -0500 Subject: [PATCH 34/38] set transform feedback format at program link --- basis/opengl/shaders/shaders.factor | 18 +++++------ extra/gpu/buffers/buffers.factor | 5 ++++ .../shaders/prettyprint/prettyprint.factor | 4 +++ extra/gpu/shaders/shaders.factor | 30 +++++++++++++++---- 4 files changed, 41 insertions(+), 16 deletions(-) diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index 1561138522..9d5f4810e1 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -61,22 +61,18 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; ! Programs -: ( 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* - ] - [ glLinkProgram ] - [ ] tri - gl-error ; + [ swap call ] bi-curry bi* + ] [ glLinkProgram ] [ ] tri gl-error ; inline + +: ( shaders frag-data-locations -- program ) + [ [ first2 swap glBindFragDataLocation ] with each ] curry (gl-program) ; : ( shaders -- program ) - glCreateProgram - [ swap [ glAttachShader ] with each ] - [ glLinkProgram ] - [ ] tri - gl-error ; + [ drop ] (gl-program) ; : (gl-program?) ( object -- ? ) dup integer? [ glIsProgram c-bool> ] [ drop f ] if ; diff --git a/extra/gpu/buffers/buffers.factor b/extra/gpu/buffers/buffers.factor index ce53a25422..c4f85bb5af 100644 --- a/extra/gpu/buffers/buffers.factor +++ b/extra/gpu/buffers/buffers.factor @@ -79,6 +79,11 @@ 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 ; + :: allocate-buffer ( buffer size initial-data -- ) buffer bind-buffer :> target target size initial-data buffer gl-buffer-usage glBufferData ; diff --git a/extra/gpu/shaders/prettyprint/prettyprint.factor b/extra/gpu/shaders/prettyprint/prettyprint.factor index 3d739a55f3..862922c34c 100644 --- a/extra/gpu/shaders/prettyprint/prettyprint.factor +++ b/extra/gpu/shaders/prettyprint/prettyprint.factor @@ -14,3 +14,7 @@ M: link-program-error error. 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 ; diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index 933522b3d0..fd31e8b279 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -6,9 +6,9 @@ generic.parser gpu gpu.buffers hashtables images io.encodings.ascii io.files io.pathnames kernel lexer locals math math.parser memoize multiline namespaces opengl opengl.gl opengl.shaders parser quotations sequences -specialized-arrays.int splitting strings ui.gadgets.worlds -variants vectors vocabs vocabs.loader vocabs.parser words -words.constant ; +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 @@ -17,6 +17,7 @@ VARIANT: shader-kind UNION: ?string string POSTPONE: f ; ERROR: too-many-feedback-formats-error formats ; +ERROR: invalid-link-feedback-format-error format ; TUPLE: vertex-attribute { name ?string read-only initial: f } @@ -137,16 +138,35 @@ MEMO: output-index ( program-instance output-name -- index ) { 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 ; + GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- ) +GENERIC: link-feedback-format ( program-handle format -- ) + +M: f link-feedback-format + 2drop ; + : 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 ] [ [ \ vertex-format-size create-method-in ] dip [ \ drop ] dip vertex-attributes-size [ ] 2sequence define - ] 2bi ; + ] 2tri ; : component-type>c-type ( component-type -- c-type ) { @@ -281,7 +301,7 @@ DEFER: [ compile-shader-error ] if ; : (link-program) ( program shader-instances -- program-instance ) - [ handle>> ] map + [ [ handle>> ] map ] [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program) dup gl-program-ok? [ swap world get \ program-instance boa window-resource ] [ link-program-error ] if ; From bfcb95edaf034f12df308f56f5503dc2d84171e3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Jul 2009 22:24:33 -0500 Subject: [PATCH 35/38] accept transform-feedback-output target from render --- extra/gpu/buffers/buffers.factor | 6 ++++-- extra/gpu/render/render.factor | 36 +++++++++++++++++++++++++++++++- extra/gpu/shaders/shaders.factor | 3 ++- 3 files changed, 41 insertions(+), 4 deletions(-) diff --git a/extra/gpu/buffers/buffers.factor b/extra/gpu/buffers/buffers.factor index c4f85bb5af..3de5a03d35 100644 --- a/extra/gpu/buffers/buffers.factor +++ b/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,6 +53,7 @@ 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 ) @@ -82,7 +84,7 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ; : buffer-ptr>range ( buffer-ptr -- buffer-range ) [ buffer>> ] [ offset>> ] bi 2dup [ buffer-size ] dip - - buffer-range boa ; + buffer-range boa ; inline :: allocate-buffer ( buffer size initial-data -- ) buffer bind-buffer :> target diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor index 6ea72d53a5..ce6e0e25ff 100644 --- a/extra/gpu/render/render.factor +++ b/extra/gpu/render/render.factor @@ -431,9 +431,33 @@ SYNTAX: UNIFORM-TUPLE: 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 read-only } @@ -442,7 +466,8 @@ TUPLE: render-set { indexes vertex-indexes initial: T{ index-range } read-only } { instances ?integer initial: f read-only } { framebuffer ?any-framebuffer initial: system-framebuffer read-only } - { output-attachments sequence initial: { default-attachment } read-only } ; + { output-attachments sequence initial: { default-attachment } read-only } + { transform-feedback-output transform-feedback-output initial: f read-only } ; : ( x quot-assoc -- render-set ) render-set swap make-tuple ; inline @@ -472,11 +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 diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index fd31e8b279..f38d95a118 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -301,7 +301,8 @@ DEFER: [ compile-shader-error ] if ; : (link-program) ( program shader-instances -- program-instance ) - [ [ handle>> ] map ] [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program) + [ [ handle>> ] map ] curry + [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program) dup gl-program-ok? [ swap world get \ program-instance boa window-resource ] [ link-program-error ] if ; From f504ad2e430ea8c0e84ffc09e6f11db7c9b59319 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Mon, 27 Jul 2009 15:30:30 +1200 Subject: [PATCH 36/38] alien.marshall: doc fix --- extra/alien/marshall/marshall-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor index 7b321bd992..361753a0d3 100644 --- a/extra/alien/marshall/marshall-docs.factor +++ b/extra/alien/marshall/marshall-docs.factor @@ -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 From b99b6861944723239193cd8ce3370b8711d9e9de Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Jul 2009 23:00:35 -0500 Subject: [PATCH 37/38] update gpu docs --- extra/gpu/buffers/buffers-docs.factor | 41 +++++++++++++++++++++++++-- extra/gpu/render/render-docs.factor | 3 +- extra/gpu/shaders/shaders-docs.factor | 11 +++++-- 3 files changed, 50 insertions(+), 5 deletions(-) diff --git a/extra/gpu/buffers/buffers-docs.factor b/extra/gpu/buffers/buffers-docs.factor index eee5d2b716..d05783dbf8 100644 --- a/extra/gpu/buffers/buffers-docs.factor +++ b/extra/gpu/buffers/buffers-docs.factor @@ -10,6 +10,13 @@ HELP: } { $description "Constructs a " { $link buffer-ptr } " tuple." } ; +HELP: +{ $values + { "buffer" buffer } { "offset" integer } { "size" integer } + { "buffer-range" buffer-range } +} +{ $description "Constructs a " { $link buffer-range } " tuple." } ; + HELP: { $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 } diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index 187f08a7ea..171c9bb031 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -216,8 +216,9 @@ HELP: render-set { "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. " { $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." } +{ "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." } ; +{ $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 diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index 456a76e5ce..27e0f544cd 100755 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -25,8 +25,9 @@ HELP: { $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 ;" } -{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance." } ; +{ $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 } ", 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\"" } @@ -134,6 +135,12 @@ 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: uniform-index { $values { "program-instance" program-instance } { "uniform-name" string } From 90985ea36208d786d602e8cdcee6bf55a3fcbb16 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 27 Jul 2009 13:16:41 -0500 Subject: [PATCH 38/38] verify transform feedback format matches requested format after linking program-instances --- .../shaders/prettyprint/prettyprint.factor | 4 + extra/gpu/shaders/shaders-docs.factor | 3 + extra/gpu/shaders/shaders.factor | 94 +++++++++++++++---- 3 files changed, 81 insertions(+), 20 deletions(-) diff --git a/extra/gpu/shaders/prettyprint/prettyprint.factor b/extra/gpu/shaders/prettyprint/prettyprint.factor index 862922c34c..10afe4bee1 100644 --- a/extra/gpu/shaders/prettyprint/prettyprint.factor +++ b/extra/gpu/shaders/prettyprint/prettyprint.factor @@ -18,3 +18,7 @@ M: too-many-feedback-formats-error error. 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 ; diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index 27e0f544cd..d59fa1bc39 100755 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -141,6 +141,9 @@ HELP: too-many-feedback-formats-error 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 } diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index f38d95a118..d2dd29595a 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -1,14 +1,15 @@ ! (c)2009 Joe Groff bsd license -USING: accessors alien alien.c-types alien.structs arrays -assocs classes.mixin classes.parser classes.singleton -combinators combinators.short-circuit definitions destructors -generic.parser gpu gpu.buffers hashtables -images io.encodings.ascii io.files io.pathnames kernel lexer +USING: accessors alien alien.c-types alien.strings +alien.structs arrays assocs byte-arrays classes.mixin +classes.parser classes.singleton combinators +combinators.short-circuit definitions destructors +generic.parser gpu gpu.buffers hashtables images +io.encodings.ascii io.files io.pathnames kernel lexer literals locals math math.parser memoize multiline namespaces opengl 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 ; +strings ui.gadgets.worlds variants vectors vocabs vocabs.loader +vocabs.parser words words.constant ; IN: gpu.shaders VARIANT: shader-kind @@ -18,6 +19,7 @@ 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 } @@ -99,6 +101,29 @@ MEMO: output-index ( program-instance output-name -- index ) : 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 @@ -149,6 +174,21 @@ MEMO: output-index ( program-instance output-name -- index ) >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 0 ] dip + [ 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 -- ) @@ -156,17 +196,30 @@ 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 - ] [ - [ \ vertex-format-size create-method-in ] dip - [ \ drop ] dip vertex-attributes-size [ ] 2sequence define - ] 2tri ; + { + [ + [ \ 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 ) { @@ -303,9 +356,10 @@ DEFER: : (link-program) ( program shader-instances -- program-instance ) [ [ handle>> ] map ] curry [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program) - dup gl-program-ok? - [ swap world get \ program-instance boa window-resource ] - [ link-program-error ] if ; + dup gl-program-ok? [ + [ 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>> [ ] map (link-program) ;