fortran-invoke works(?)
Joe Groff
parent
3bc557467e
commit
4dd500b5b1
|
|
@ -1,7 +1,9 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.fortran alien.structs
|
||||
alien.syntax arrays assocs kernel macros namespaces sequences
|
||||
tools.test fry ;
|
||||
USING: accessors alien alien.c-types alien.complex
|
||||
alien.fortran alien.strings alien.structs alien.syntax arrays
|
||||
assocs byte-arrays combinators fry generalizations
|
||||
io.encodings.ascii kernel macros macros.expander namespaces
|
||||
sequences shuffle tools.test ;
|
||||
IN: alien.fortran.tests
|
||||
|
||||
RECORD: FORTRAN_TEST_RECORD
|
||||
|
|
@ -169,17 +171,14 @@ unit-test
|
|||
[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
|
||||
[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
|
||||
|
||||
! fortran-invoke
|
||||
|
||||
: fortran-invoke-expansion ( return library function parameters -- quot )
|
||||
'[ _ _ _ _ fortran-invoke ] expand-macros ; inline
|
||||
! (fortran-invoke)
|
||||
|
||||
[ [
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <int> ]
|
||||
[ <longlong> ]
|
||||
[ <float> ]
|
||||
[ <complex-float> ]
|
||||
[ 1 0 ? <short> ]
|
||||
|
|
@ -188,100 +187,109 @@ unit-test
|
|||
} 5 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "foopack" "funtimes_"
|
||||
{ "char*" "int*" "float*" "complex-float*" "short*" "long" }
|
||||
"void" "funpack" "funtimes_"
|
||||
{ "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
|
||||
alien-invoke
|
||||
] 6 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
|
||||
{
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ *float ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
} spread
|
||||
] ] [
|
||||
f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
|
||||
fortran-invoke-expansion
|
||||
f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ { [ ] } spread ]
|
||||
[ { [ drop ] } spread ]
|
||||
} 1 ncleave
|
||||
! [fortran-invoke]
|
||||
"double" "foopack" "fun_times__"
|
||||
{ "float*" }
|
||||
alien-invoke
|
||||
[ "double" "funpack" "fun_times__" { "float*" } alien-invoke ]
|
||||
1 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta aa -- reta aa )
|
||||
{ [ ] [ drop ] } spread
|
||||
] ] [
|
||||
"REAL" "foopack" "FUN_TIMES" { "REAL(*)" }
|
||||
fortran-invoke-expansion
|
||||
"REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ "complex-float" <c-object> ] 1 ndip
|
||||
! [fortran-args>c-args]
|
||||
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "foopack" "fun_times__"
|
||||
"void" "funpack" "fun_times__"
|
||||
{ "complex-float*" "float*" }
|
||||
alien-invoke
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
{
|
||||
[ *complex-float ]
|
||||
[ drop ]
|
||||
} spread
|
||||
shuffle( reta aa -- reta aa )
|
||||
{ [ *complex-float ] [ drop ] } spread
|
||||
] ] [
|
||||
"COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" }
|
||||
fortran-invoke-expansion
|
||||
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 20 <byte-array> 20 ] 1 ndip
|
||||
[ 20 <byte-array> 20 ] 0 ndip
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "foopack" "fun_times__"
|
||||
{ "char*" "long" "float*" }
|
||||
"void" "funpack" "fun_times__"
|
||||
{ "char*" "long" }
|
||||
alien-invoke
|
||||
] 3 nkeep
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
{
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
[ drop ]
|
||||
} spread
|
||||
shuffle( reta retb -- reta retb )
|
||||
{ [ ] [ ascii alien>nstring ] } spread
|
||||
] ] [
|
||||
"CHARACTER*20" "foopack" "FUN_TIMES" { }
|
||||
fortran-invoke-expansion
|
||||
"CHARACTER*20" "funpack" "FUN_TIMES" { }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 10 <byte-array> 10 ] 2 ndip
|
||||
[ 10 <byte-array> 10 ] 3 ndip
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <float> ]
|
||||
[ ascii string>alien ]
|
||||
} spread ]
|
||||
[ { [ length ] [ drop ] } spread ]
|
||||
} 2 ncleave
|
||||
[ { [ length ] [ drop ] [ length ] } spread ]
|
||||
} 3 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "foopack" "fun_times__"
|
||||
{ "char*" "long" "char*" "float*" "long" }
|
||||
"void" "funpack" "fun_times__"
|
||||
{ "char*" "long" "char*" "float*" "char*" "long" "long" }
|
||||
alien-invoke
|
||||
] 5 nkeep
|
||||
] 7 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
|
||||
{
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
[ ]
|
||||
[ *float swap ]
|
||||
[ ascii alien>nstring ]
|
||||
[ *float ]
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
} spread
|
||||
] ] [
|
||||
"CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" }
|
||||
fortran-invoke-expansion
|
||||
"CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,11 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.structs alien.syntax
|
||||
arrays ascii assocs combinators fry kernel lexer macros math.parser
|
||||
namespaces parser sequences splitting vectors vocabs.parser locals
|
||||
io.encodings.ascii io.encodings.string ;
|
||||
USING: accessors alien alien.c-types alien.complex alien.parser
|
||||
alien.strings alien.structs alien.syntax arrays ascii assocs
|
||||
byte-arrays combinators combinators.short-circuit fry generalizations
|
||||
kernel lexer macros math math.parser namespaces parser sequences
|
||||
splitting stack-checker vectors vocabs.parser words locals
|
||||
io.encodings.ascii io.encodings.string shuffle effects math.ranges
|
||||
math.order sorting ;
|
||||
IN: alien.fortran
|
||||
|
||||
! XXX this currently only supports the gfortran/f2c abi.
|
||||
|
|
@ -18,6 +21,8 @@ IN: alien.fortran
|
|||
ERROR: invalid-fortran-type type ;
|
||||
|
||||
DEFER: fortran-sig>c-sig
|
||||
DEFER: fortran-ret-type>c-type
|
||||
DEFER: fortran-arg-type>c-type
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -90,7 +95,7 @@ M: real-complex-type (fortran-type>c-type)
|
|||
M: double-precision-type (fortran-type>c-type)
|
||||
"double" simple-type ;
|
||||
M: double-complex-type (fortran-type>c-type)
|
||||
"(fortran-double-complex)" simple-type ;
|
||||
"complex-double" simple-type ;
|
||||
M: misc-type (fortran-type>c-type)
|
||||
dup name>> simple-type ;
|
||||
|
||||
|
|
@ -118,7 +123,7 @@ M: character-type (fortran-type>c-type)
|
|||
: (parse-fortran-type) ( fortran-type-string -- type )
|
||||
parse-out swap parse-dims swap parse-size swap
|
||||
dup >lower fortran>c-types at*
|
||||
[ nip new-fortran-type ] [ drop f misc-type boa ] if ;
|
||||
[ nip new-fortran-type ] [ drop misc-type boa ] if ;
|
||||
|
||||
: parse-fortran-type ( fortran-type-string/f -- type/f )
|
||||
dup [ (parse-fortran-type) ] when ;
|
||||
|
|
@ -149,40 +154,49 @@ M: real-type (fortran-ret-type>c-type) drop "double" ;
|
|||
|
||||
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
|
||||
|
||||
: args?dims ( type quot -- main-quot added-quot )
|
||||
[ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
|
||||
|
||||
M: integer-type (fortran-arg>c-args)
|
||||
size>> {
|
||||
{ f [ [ <int> ] [ drop ] ] }
|
||||
{ 1 [ [ <char> ] [ drop ] ] }
|
||||
{ 2 [ [ <short> ] [ drop ] ] }
|
||||
{ 4 [ [ <int> ] [ drop ] ] }
|
||||
{ 8 [ [ <longlong> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <int> ] [ drop ] ] }
|
||||
{ 1 [ [ <char> ] [ drop ] ] }
|
||||
{ 2 [ [ <short> ] [ drop ] ] }
|
||||
{ 4 [ [ <int> ] [ drop ] ] }
|
||||
{ 8 [ [ <longlong> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: logical-type (fortran-arg>c-args)
|
||||
call-next-method [ [ 1 0 ? ] prepend ] dip ;
|
||||
[ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
|
||||
|
||||
M: real-type (fortran-arg>c-args)
|
||||
size>> {
|
||||
{ f [ [ <float> ] [ drop ] ] }
|
||||
{ 4 [ [ <float> ] [ drop ] ] }
|
||||
{ 8 [ [ <double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <float> ] [ drop ] ] }
|
||||
{ 4 [ [ <float> ] [ drop ] ] }
|
||||
{ 8 [ [ <double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: real-complex-type (fortran-arg>c-args)
|
||||
size>> {
|
||||
{ f [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 8 [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 16 [ [ <complex-double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 8 [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 16 [ [ <complex-double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: double-precision-type (fortran-arg>c-args)
|
||||
drop [ <double> ] [ drop ] ;
|
||||
[ drop [ <double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: double-complex-type (fortran-arg>c-args)
|
||||
drop [ <complex-double> ] [ drop ] ;
|
||||
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: character-type (fortran-arg>c-args)
|
||||
drop [ ascii string>alien ] [ length ] ;
|
||||
|
|
@ -190,72 +204,122 @@ M: character-type (fortran-arg>c-args)
|
|||
M: misc-type (fortran-arg>c-args)
|
||||
drop [ ] [ drop ] ;
|
||||
|
||||
GENERIC: (fortran-result>) ( type -- quot )
|
||||
GENERIC: (fortran-result>) ( type -- quots )
|
||||
|
||||
: result?dims ( type quot -- quot )
|
||||
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
|
||||
|
||||
M: integer-type (fortran-result>)
|
||||
size>> {
|
||||
{ f [ [ *int ] ] }
|
||||
{ 1 [ [ *char ] ] }
|
||||
{ 2 [ [ *short ] ] }
|
||||
{ 4 [ [ *int ] ] }
|
||||
{ 8 [ [ *longlong ] ] }
|
||||
[ size>> {
|
||||
{ f [ { [ *int ] } ] }
|
||||
{ 1 [ { [ *char ] } ] }
|
||||
{ 2 [ { [ *short ] } ] }
|
||||
{ 4 [ { [ *int ] } ] }
|
||||
{ 8 [ { [ *longlong ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
} case ] result?dims ;
|
||||
|
||||
M: logical-type (fortran-result>)
|
||||
call-next-method [ zero? not ] append ;
|
||||
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
|
||||
|
||||
M: real-type (fortran-result>)
|
||||
size>> {
|
||||
{ f [ [ *float ] ] }
|
||||
{ 4 [ [ *float ] ] }
|
||||
{ 8 [ [ *double ] ] }
|
||||
[ size>> {
|
||||
{ f [ { [ *float ] } ] }
|
||||
{ 4 [ { [ *float ] } ] }
|
||||
{ 8 [ { [ *double ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
} case ] result?dims ;
|
||||
|
||||
M: real-complex-type (fortran-result>)
|
||||
size>> {
|
||||
{ f [ [ *complex-float ] ] }
|
||||
{ 8 [ [ *complex-float ] ] }
|
||||
{ 16 [ [ *complex-double ] ] }
|
||||
[ size>> {
|
||||
{ f [ { [ *complex-float ] } ] }
|
||||
{ 8 [ { [ *complex-float ] } ] }
|
||||
{ 16 [ { [ *complex-double ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
} case ] result?dims ;
|
||||
|
||||
M: double-precision-type (fortran-result>)
|
||||
drop [ *double ] ;
|
||||
[ drop { [ *double ] } ] result?dims ;
|
||||
|
||||
M: double-complex-type (fortran-result>)
|
||||
drop [ *complex-double ] ;
|
||||
[ drop { [ *complex-double ] } ] result?dims ;
|
||||
|
||||
M: character-type (fortran-result>)
|
||||
drop [ ascii alien>nstring ] ;
|
||||
drop { [ ] [ ascii alien>nstring ] } ;
|
||||
|
||||
M: misc-type (fortran-result>)
|
||||
drop [ ] ;
|
||||
drop { [ ] } ;
|
||||
|
||||
GENERIC: (<fortran-result>) ( type -- quot )
|
||||
|
||||
M: fortran-type (<fortran-result>)
|
||||
(fortran-type>c-type) '[ _ <c-object> ] ;
|
||||
(fortran-type>c-type) \ <c-object> [ ] 2sequence ;
|
||||
|
||||
M: character-type (<fortran-result>)
|
||||
fix-character-type dims>> product dup
|
||||
[ \ <byte-array> ] dip [ ] 3sequence ;
|
||||
|
||||
: [<fortran-result>] ( return parameters -- quot )
|
||||
[ parse-fortran-type ] dip
|
||||
over returns-by-value?
|
||||
[ 2drop [ ] ]
|
||||
[ [ (<fortran-result>) ] [ '[ _ _ ndip ] ] bi* ] if ;
|
||||
[ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
|
||||
|
||||
: [fortran-args>c-args] ( parameters -- quot )
|
||||
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
|
||||
[ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi
|
||||
'[ _ _ ncleave ] ;
|
||||
[ [ ] ] [
|
||||
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
|
||||
[ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
|
||||
\ ncleave [ ] 3sequence
|
||||
] if-empty ;
|
||||
|
||||
:: [fortran-invoke] ( return library function parameters -- quot )
|
||||
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
|
||||
return parameters fortran-sig>c-sig :> c-parameters :> c-return
|
||||
function fortran-name>symbol-name :> c-function
|
||||
[ c-return library c-function c-parameters alien-invoke ] ;
|
||||
[args>args]
|
||||
c-return library c-function c-parameters \ alien-invoke
|
||||
5 [ ] nsequence
|
||||
c-parameters length \ nkeep
|
||||
[ ] 3sequence ;
|
||||
|
||||
: [fortran-out-param>] ( parameter -- quot )
|
||||
parse-fortran-type
|
||||
[ (fortran-result>) ] [ out?>> ] bi
|
||||
[ ] [ [ drop [ drop ] ] map ] if ;
|
||||
|
||||
: [fortran-return>] ( return -- quot )
|
||||
parse-fortran-type {
|
||||
{ [ dup not ] [ drop { } ] }
|
||||
{ [ dup returns-by-value? ] [ drop { [ ] } ] }
|
||||
[ (fortran-result>) ]
|
||||
} cond ;
|
||||
|
||||
: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
|
||||
|
||||
: (shuffle-map) ( return parameters -- ret par )
|
||||
[
|
||||
fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
|
||||
letters swap head [ "ret" swap suffix ] map
|
||||
] [
|
||||
[ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
|
||||
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
|
||||
] bi* ;
|
||||
|
||||
: (fortran-in-shuffle) ( ret par -- seq )
|
||||
[ [ second ] bi@ <=> ] sort append ;
|
||||
|
||||
: (fortran-out-shuffle) ( ret par -- seq )
|
||||
append ;
|
||||
|
||||
: [fortran-result-shuffle] ( return parameters -- quot )
|
||||
(shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
|
||||
\ shuffle-effect [ ] 2sequence ;
|
||||
|
||||
: [fortran-results>] ( return parameters -- quot )
|
||||
2drop [ ] ;
|
||||
[ [fortran-result-shuffle] ]
|
||||
[ drop [fortran-return>] ]
|
||||
[ nip [ [fortran-out-param>] ] map concat ] 2tri
|
||||
append
|
||||
\ spread [ ] 2sequence append ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -289,22 +353,26 @@ PRIVATE>
|
|||
|
||||
: RECORD: scan in get parse-definition define-fortran-record ; parsing
|
||||
|
||||
MACRO: fortran-invoke ( return library function parameters -- )
|
||||
: (fortran-invoke) ( return library function parameters -- quot )
|
||||
{
|
||||
[ 2nip [<fortran-result>] ]
|
||||
[ nip nip nip [fortran-args>c-args] ]
|
||||
[ [fortran-invoke] ]
|
||||
[ 2nip [fortran-results>] ]
|
||||
} 4 ncleave 3append ;
|
||||
} 4 ncleave 4 nappend ;
|
||||
|
||||
MACRO: fortran-invoke ( return library function parameters -- )
|
||||
(fortran-invoke) ;
|
||||
|
||||
:: define-fortran-function ( return library function parameters -- )
|
||||
function create-in dup reset-generic
|
||||
return library function parameters return parse-arglist
|
||||
[ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ;
|
||||
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
|
||||
|
||||
: SUBROUTINE:
|
||||
f "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter define-fortran-function ; parsing
|
||||
|
||||
: FUNCTION:
|
||||
scan "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter define-fortran-function ; parsing
|
||||
|
|
|
|||
Loading…
Reference in New Issue