153 lines
4.1 KiB
Factor
153 lines
4.1 KiB
Factor
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: alien
|
|
USING: assembler compiler errors generic inference interpreter
|
|
kernel lists math namespaces parser words hashtables strings
|
|
unparser ;
|
|
|
|
! Command line parameters specify libraries to load.
|
|
!
|
|
! -library:<foo>:name=<soname> -- define a library <foo>, to be
|
|
! loaded from the <soname> DLL.
|
|
!
|
|
! -library:<foo>:abi=stdcall -- define a library using the
|
|
! stdcall ABI. This ABI is usually used on Win32. Any other abi
|
|
! parameter, or a missing abi parameter indicates the cdecl ABI
|
|
! should be used, which is common on Unix.
|
|
|
|
BUILTIN: dll 15
|
|
BUILTIN: alien 16
|
|
|
|
M: alien hashcode ( obj -- n )
|
|
alien-address >fixnum ;
|
|
|
|
M: alien = ( obj obj -- ? )
|
|
over alien? [
|
|
over local-alien? over local-alien? or [
|
|
eq?
|
|
] [
|
|
alien-address swap alien-address =
|
|
] ifte
|
|
] [
|
|
2drop f
|
|
] ifte ;
|
|
|
|
M: alien unparse ( obj -- str )
|
|
[
|
|
"#<" ,
|
|
dup local-alien? "local-alien" "alien" ? ,
|
|
" @ " ,
|
|
alien-address unparse ,
|
|
">" ,
|
|
] make-string ;
|
|
|
|
: library ( name -- object )
|
|
dup [ "libraries" get hash ] when ;
|
|
|
|
: load-dll ( name -- dll )
|
|
#! Higher level wrapper around dlopen primitive.
|
|
library dup [
|
|
[
|
|
"dll" get dup [
|
|
drop "name" get dlopen dup "dll" set
|
|
] unless
|
|
] bind
|
|
] when ;
|
|
|
|
: add-library ( library name abi -- )
|
|
"libraries" get [
|
|
<namespace> [
|
|
"abi" set
|
|
"name" set
|
|
] extend put
|
|
] bind ;
|
|
|
|
SYMBOL: #cleanup ( unwind stack by parameter )
|
|
|
|
SYMBOL: #c-call ( jump to raw address )
|
|
|
|
SYMBOL: #unbox ( move top of datastack to C stack )
|
|
SYMBOL: #box ( move EAX to datastack )
|
|
|
|
: library-abi ( library -- abi )
|
|
library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
|
|
|
|
SYMBOL: #alien-invoke
|
|
|
|
! These are set in the #alien-invoke dataflow IR node.
|
|
SYMBOL: alien-returns
|
|
SYMBOL: alien-parameters
|
|
|
|
: set-alien-returns ( returns node -- )
|
|
[ dup alien-returns set ] bind
|
|
"void" = [
|
|
[ object ] produce-d 1 0 node-outputs
|
|
] unless ;
|
|
|
|
: set-alien-parameters ( parameters node -- )
|
|
[ dup alien-parameters set ] bind
|
|
[ drop object ] map dup dup ensure-d
|
|
length 0 node-inputs consume-d ;
|
|
|
|
: alien-node ( returns params function library -- )
|
|
cons #alien-invoke dataflow,
|
|
[ set-alien-parameters ] keep
|
|
set-alien-returns ;
|
|
|
|
: infer-alien ( -- )
|
|
[ object object object object ] ensure-d
|
|
dataflow-drop, pop-d value-literal
|
|
dataflow-drop, pop-d value-literal >r
|
|
dataflow-drop, pop-d value-literal
|
|
dataflow-drop, pop-d value-literal -rot
|
|
r> swap alien-node ;
|
|
|
|
: box-parameter
|
|
c-type [
|
|
"width" get cell align
|
|
"unboxer" get
|
|
] bind #unbox swons , ;
|
|
|
|
: linearize-parameters ( params -- count )
|
|
#! Generate code for boxing a list of C types.
|
|
#! Return amount stack must be unwound by.
|
|
[ alien-parameters get reverse ] bind 0 swap [
|
|
box-parameter +
|
|
] each ;
|
|
|
|
: linearize-returns ( returns -- )
|
|
[ alien-returns get ] bind dup "void" = [
|
|
drop
|
|
] [
|
|
c-type [ "boxer" get ] bind #box swons ,
|
|
] ifte ;
|
|
|
|
: linearize-alien ( node -- )
|
|
dup linearize-parameters >r
|
|
dup [ node-param get ] bind #c-call swons ,
|
|
dup [ node-param get cdr library-abi "stdcall" = ] bind
|
|
r> swap [ drop ] [ #cleanup swons , ] ifte
|
|
linearize-returns ;
|
|
|
|
#alien-invoke [ linearize-alien ] "linearizer" set-word-property
|
|
|
|
: alien-invoke ( ... returns library function parameters -- ... )
|
|
#! Call a C library function.
|
|
#! 'returns' is a type spec, and 'parameters' is a list of
|
|
#! type specs. 'library' is an entry in the "libraries"
|
|
#! namespace.
|
|
[
|
|
"alien-invoke cannot be interpreted. " ,
|
|
"Either the compiler is disabled, " ,
|
|
"or the ``" , rot , "'' library is missing. " ,
|
|
] make-string throw ;
|
|
|
|
\ alien-invoke [ [ object object object object ] [ ] ]
|
|
"infer-effect" set-word-property
|
|
|
|
\ alien-invoke [ infer-alien ] "infer" set-word-property
|
|
|
|
global [
|
|
"libraries" get [ <namespace> "libraries" set ] unless
|
|
] bind
|