fortran-invoke works(?)

db4
Joe Groff 2009-02-09 13:29:50 -06:00
parent 3bc557467e
commit 4dd500b5b1
2 changed files with 184 additions and 108 deletions

View File

@ -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

View File

@ -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