alien.parser: make make-callback-type have the same signature as make-function

locals-and-roots
Björn Lindqvist 2016-05-28 16:49:14 +02:00
parent 6f705c4944
commit 69f667edc8
3 changed files with 28 additions and 20 deletions

View File

@ -1,38 +1,47 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.parser alien.syntax USING: accessors alien.c-types alien.parser alien.parser.private
compiler.units continuations debugger eval kernel namespaces parser alien.syntax compiler.units continuations debugger eval fry kernel
sequences sets tools.test vocabs.parser words ; lexer namespaces parser sequences sets tools.test vocabs.parser words
;
IN: alien.parser.tests IN: alien.parser.tests
: with-parsing ( lines quot -- )
[ <lexer> ] [ '[ _ with-compilation-unit ] ] bi* with-lexer ; inline
! (CREATE-C-TYPE) ! (CREATE-C-TYPE)
{ "hello" } [ { "hello" } [
[ "hello" (CREATE-C-TYPE) ] with-compilation-unit { "hello" } [ CREATE-C-TYPE name>> ] with-parsing
name>>
] unit-test ] unit-test
! Check that it deletes from old-definitions ! Check that it deletes from old-definitions
{ 0 } [ { 0 } [
[ { } [
"hello" current-vocab create-word "hello" current-vocab create-word
old-definitions get first adjoin old-definitions get first adjoin
"hello" (CREATE-C-TYPE) drop "hello" (CREATE-C-TYPE) drop
old-definitions get first cardinality old-definitions get first cardinality
] with-compilation-unit ] with-parsing
] unit-test ] unit-test
! make-callback-type ! make-callback-type
{ "what-type" } [ { "what-type" } [
[ f void "what-type" { } { } make-callback-type ] with-compilation-unit { } [
2drop name>> void "what-type" f { } { } make-callback-type 2drop name>>
] with-parsing
] unit-test ] unit-test
{ 0 } [ { 0 } [
[ { } [
"hello" current-vocab create-word "hello" current-vocab create-word
old-definitions get first adjoin old-definitions get first adjoin
f void "hello" { } { } make-callback-type 3drop void "hello" f { } { } make-callback-type 3drop
old-definitions get first cardinality old-definitions get first cardinality
] with-compilation-unit ] with-parsing
] unit-test
! parse-enum-name
{ t } [
{ "ayae" } [ parse-enum-name new-definitions get first in? ] with-parsing
] unit-test ] unit-test
TYPEDEF: char char2 TYPEDEF: char char2

View File

@ -145,16 +145,15 @@ PRIVATE>
: callback-quot ( return types abi -- quot ) : callback-quot ( return types abi -- quot )
'[ [ _ _ _ ] dip alien-callback ] ; '[ [ _ _ _ ] dip alien-callback ] ;
:: make-callback-type ( lib return type-name types names -- word quot effect ) :: make-callback-type ( return function library types names -- word quot effect )
type-name (CREATE-C-TYPE) :> type-word function (CREATE-C-TYPE) :> type-word
void* type-word typedef void* type-word typedef
type-word names return function-effect "callback-effect" set-word-prop type-word names return function-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop type-word library "callback-library" set-word-prop
type-word return types lib library-abi callback-quot ( quot -- alien ) ; type-word return types library library-abi callback-quot ( quot -- alien ) ;
: (CALLBACK:) ( -- word quot effect ) : (CALLBACK:) ( -- word quot effect )
current-library get (FUNCTION:) make-callback-type ;
scan-function-name scan-c-args make-callback-type ;
PREDICATE: alien-function-alias-word < word PREDICATE: alien-function-alias-word < word
def>> { def>> {

View File

@ -180,9 +180,9 @@ M: type type>data-type
: def-callback-type ( callback -- ) : def-callback-type ( callback -- )
{ {
[ drop current-library get ]
[ return>> return-c-type ] [ return>> return-c-type ]
[ c-type>> ] [ c-type>> ]
[ drop current-library get ]
[ ?suffix-parameters-with-error parameter-names&types ] [ ?suffix-parameters-with-error parameter-names&types ]
} cleave make-callback-type define-inline ; } cleave make-callback-type define-inline ;
@ -258,9 +258,9 @@ M: array-type field-type>c-type type>c-type ;
:: def-signal ( signal type -- ) :: def-signal ( signal type -- )
signal { signal {
[ drop current-library get ]
[ return>> return-c-type ] [ return>> return-c-type ]
[ type signal-name ] [ type signal-name ]
[ drop current-library get ]
[ [
parameters>> type type>parameter prefix parameters>> type type>parameter prefix
user-data-parameter suffix parameter-names&types user-data-parameter suffix parameter-names&types