alien.parser: refactor FUNCTION: parsing to read from the source incrementally. parse errors in FUNCTION: should now correspond to their location within the definition

db4
Joe Groff 2010-02-28 16:15:58 -08:00
parent e7d2e73215
commit 078ca0fa58
2 changed files with 32 additions and 36 deletions
basis/alien

View File

@ -59,64 +59,65 @@ ERROR: *-in-c-type-name name ;
[ ]
} cleave ;
: normalize-c-arg ( type name -- type' name' )
[ length ]
[
[ CHAR: * = ] trim-head
[ length - CHAR: * <array> append ] keep
] bi
[ parse-c-type ] dip ;
<PRIVATE
GENERIC: return-type-name ( type -- name )
M: object return-type-name drop "void" ;
M: word return-type-name name>> ;
M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
: parse-pointers ( type name -- type' name' )
"*" ?head
[ [ <pointer> ] dip parse-pointers ] when ;
PRIVATE>
: parse-arglist ( parameters return -- types effect )
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ return-type-name 1array ] if-void ]
bi* <effect> ;
: scan-function-name ( -- return function )
scan-c-type scan parse-pointers ;
:: (scan-c-args) ( end-marker types names -- )
scan :> type-str
type-str end-marker = [
type-str { "(" ")" } member? [
type-str parse-c-type :> type
scan :> name
type name parse-pointers :> ( type' name' )
type' types push name' names push
] unless
end-marker types names (scan-c-args)
] unless ;
: scan-c-args ( end-marker -- types names )
V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: make-function ( return library function parameters -- word quot effect )
return function normalize-c-arg :> ( return function )
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;
: function-effect ( names return -- effect )
[ { } ] [ return-type-name 1array ] if-void <effect> ;
: parse-arg-tokens ( -- tokens )
";" parse-tokens [ "()" subseq? not ] filter ;
:: make-function ( return function library types names -- word quot effect )
function create-in dup reset-generic
return library function types function-quot
names return function-effect ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan parse-arg-tokens make-function ;
: define-function ( return library function parameters -- )
make-function define-declared ;
scan-function-name "c-library" get ";" scan-c-args make-function ;
: callback-quot ( return types abi -- quot )
'[ [ _ _ _ ] dip alien-callback ] ;
:: make-callback-type ( lib return type-name parameters -- word quot effect )
return type-name normalize-c-arg :> ( return type-name )
:: make-callback-type ( lib return type-name types names -- word quot effect )
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
parameters return parse-arglist :> ( types callback-effect )
type-word callback-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 return types lib library-abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( -- word quot effect )
"c-library" get
scan scan parse-arg-tokens make-callback-type ;
scan-function-name ";" scan-c-args make-callback-type ;
PREDICATE: alien-function-word < word
def>> {

View File

@ -112,11 +112,6 @@ HELP: c-struct?
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
HELP: define-function
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }