alien.parser: refactor FUNCTION: parsing to read from the source incrementally. parse errors in FUNCTION: should now correspond to their location within the definition
parent
e7d2e73215
commit
078ca0fa58
basis/alien
parser
syntax
|
@ -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>> {
|
||||
|
|
|
@ -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" } }
|
||||
|
|
Loading…
Reference in New Issue