From 59091c6cf286764b4d94b1e18bd90e98f19b83d6 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Tue, 21 Jul 2009 17:09:32 +1200 Subject: [PATCH 01/21] 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/21] 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/21] 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/21] 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/21] 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/21] 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/21] 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/21] 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/21] 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/21] 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 bba46d2b3091dc9574e017fd948ba145d2b04342 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 22 Jul 2009 22:32:02 -0500 Subject: [PATCH 11/21] 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 12/21] 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 13/21] 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 14/21] 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 15/21] 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 16/21] 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 17/21] 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 18/21] 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 19/21] 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 20/21] 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 21/21] 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 ;