74 lines
2.3 KiB
Factor
74 lines
2.3 KiB
Factor
! Copyright (C) 2004, 2007 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: alien
|
|
USING: arrays generator errors generic hashtables
|
|
inference io kernel kernel-internals math namespaces parser
|
|
prettyprint sequences strings words ;
|
|
|
|
TUPLE: alien-invoke library function return parameters ;
|
|
|
|
M: alien-invoke alien-node-parameters alien-invoke-parameters ;
|
|
M: alien-invoke alien-node-return alien-invoke-return ;
|
|
M: alien-invoke alien-node-abi alien-invoke-library library-abi ;
|
|
|
|
C: alien-invoke make-node ;
|
|
|
|
: alien-invoke-dlsym ( node -- symbol dll )
|
|
dup alien-invoke-function swap alien-invoke-library
|
|
load-library ;
|
|
|
|
TUPLE: alien-invoke-error library symbol ;
|
|
|
|
M: alien-invoke-error summary
|
|
drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
|
|
|
|
: alien-invoke ( ... return library function parameters -- ... )
|
|
pick pick <alien-invoke-error> throw ;
|
|
|
|
: ensure-dlsym ( node -- )
|
|
[ alien-invoke-dlsym dlsym drop ]
|
|
[ inference-warning ] recover ;
|
|
|
|
\ alien-invoke [
|
|
! Four literals
|
|
4 ensure-values
|
|
empty-node <alien-invoke>
|
|
! Compile-time parameters
|
|
pop-literal nip over set-alien-invoke-parameters
|
|
pop-literal nip over set-alien-invoke-function
|
|
pop-literal nip over set-alien-invoke-library
|
|
pop-literal nip over set-alien-invoke-return
|
|
! Quotation which coerces parameters to required types
|
|
dup make-prep-quot infer-quot
|
|
! If symbol doesn't resolve, no stack effect, no compile
|
|
dup ensure-dlsym
|
|
! Add node to IR
|
|
dup node,
|
|
! Magic #: consume exactly the number of inputs
|
|
0 alien-invoke-stack
|
|
] "infer" set-word-prop
|
|
|
|
M: alien-invoke generate-node
|
|
end-basic-block
|
|
dup objects>registers
|
|
dup alien-invoke-dlsym %alien-invoke
|
|
dup %cleanup
|
|
box-return*
|
|
iterate-next ;
|
|
|
|
M: alien-invoke stack-frame-size* alien-invoke-frame ;
|
|
|
|
: parse-arglist ( return seq -- types effect )
|
|
2 <groups> unpair
|
|
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
|
|
|
|
: (define-c-word) ( type lib func types stack-effect -- )
|
|
>r over create-in dup reset-generic >r
|
|
[ alien-invoke ] curry curry curry curry
|
|
r> swap define-compound word r>
|
|
"declared-effect" set-word-prop ;
|
|
|
|
: define-c-word ( return library function parameters -- )
|
|
[ "()" subseq? not ] subset >r pick r> parse-arglist
|
|
(define-c-word) ;
|