steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
basis/alien/fortran/fortran-tests.factor
View File

@ -1,7 +1,9 @@
! (c) 2009 Joe Groff, see BSD license ! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.fortran alien.structs USING: accessors alien alien.c-types alien.complex
alien.syntax arrays assocs kernel macros namespaces sequences alien.fortran alien.strings alien.structs alien.syntax arrays
tools.test fry ; assocs byte-arrays combinators fry generalizations
io.encodings.ascii kernel macros macros.expander namespaces
sequences shuffle tools.test ;
IN: alien.fortran.tests IN: alien.fortran.tests
RECORD: FORTRAN_TEST_RECORD RECORD: FORTRAN_TEST_RECORD
@ -169,17 +171,14 @@ unit-test
[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
! fortran-invoke ! (fortran-invoke)
: fortran-invoke-expansion ( return library function parameters -- quot )
'[ _ _ _ _ fortran-invoke ] expand-macros ; inline
[ [ [ [
! [fortran-args>c-args] ! [fortran-args>c-args]
{ {
[ { [ {
[ ascii string>alien ] [ ascii string>alien ]
[ <int> ] [ <longlong> ]
[ <float> ] [ <float> ]
[ <complex-float> ] [ <complex-float> ]
[ 1 0 ? <short> ] [ 1 0 ? <short> ]
@ -188,100 +187,109 @@ unit-test
} 5 ncleave } 5 ncleave
! [fortran-invoke] ! [fortran-invoke]
[ [
"void" "foopack" "funtimes_" "void" "funpack" "funtimes_"
{ "char*" "int*" "float*" "complex-float*" "short*" "long" } { "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
alien-invoke alien-invoke
] 6 nkeep ] 6 nkeep
! [fortran-results>] ! [fortran-results>]
shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
{ {
[ drop ]
[ drop ] [ drop ]
[ drop ] [ drop ]
[ *float ] [ *float ]
[ drop ] [ drop ]
[ drop ] [ drop ]
[ drop ]
} spread } spread
] ] [ ] ] [
f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
fortran-invoke-expansion (fortran-invoke)
] unit-test ] unit-test
[ [ [ [
! [fortran-args>c-args]
{
[ { [ ] } spread ]
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke] ! [fortran-invoke]
"double" "foopack" "fun_times__" [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ]
{ "float*" } 1 nkeep
alien-invoke ! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ ] [ drop ] } spread
] ] [ ] ] [
"REAL" "foopack" "FUN_TIMES" { "REAL(*)" } "REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
fortran-invoke-expansion (fortran-invoke)
] unit-test ] unit-test
[ [ [ [
! [<fortran-result>] ! [<fortran-result>]
[ "complex-float" <c-object> ] 1 ndip [ "complex-float" <c-object> ] 1 ndip
! [fortran-args>c-args]
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
! [fortran-invoke] ! [fortran-invoke]
[ [
"void" "foopack" "fun_times__" "void" "funpack" "fun_times__"
{ "complex-float*" "float*" } { "complex-float*" "float*" }
alien-invoke alien-invoke
] 2 nkeep ] 2 nkeep
! [fortran-results>] ! [fortran-results>]
{ shuffle( reta aa -- reta aa )
[ *complex-float ] { [ *complex-float ] [ drop ] } spread
[ drop ]
} spread
] ] [ ] ] [
"COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" } "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
fortran-invoke-expansion (fortran-invoke)
] unit-test ] unit-test
[ [ [ [
! [<fortran-result>] ! [<fortran-result>]
[ 20 <byte-array> 20 ] 1 ndip [ 20 <byte-array> 20 ] 0 ndip
! [fortran-invoke] ! [fortran-invoke]
[ [
"void" "foopack" "fun_times__" "void" "funpack" "fun_times__"
{ "char*" "long" "float*" } { "char*" "long" }
alien-invoke alien-invoke
] 3 nkeep ] 2 nkeep
! [fortran-results>] ! [fortran-results>]
{ shuffle( reta retb -- reta retb )
[ ] { [ ] [ ascii alien>nstring ] } spread
[ ascii alien>nstring ]
[ drop ]
} spread
] ] [ ] ] [
"CHARACTER*20" "foopack" "FUN_TIMES" { } "CHARACTER*20" "funpack" "FUN_TIMES" { }
fortran-invoke-expansion (fortran-invoke)
] unit-test ] unit-test
[ [ [ [
! [<fortran-result>] ! [<fortran-result>]
[ 10 <byte-array> 10 ] 2 ndip [ 10 <byte-array> 10 ] 3 ndip
! [fortran-args>c-args] ! [fortran-args>c-args]
{ {
[ { [ {
[ ascii string>alien ] [ ascii string>alien ]
[ <float> ] [ <float> ]
[ ascii string>alien ]
} spread ] } spread ]
[ { [ length ] [ drop ] } spread ] [ { [ length ] [ drop ] [ length ] } spread ]
} 2 ncleave } 3 ncleave
! [fortran-invoke] ! [fortran-invoke]
[ [
"void" "foopack" "fun_times__" "void" "funpack" "fun_times__"
{ "char*" "long" "char*" "float*" "long" } { "char*" "long" "char*" "float*" "char*" "long" "long" }
alien-invoke alien-invoke
] 5 nkeep ] 7 nkeep
! [fortran-results>] ! [fortran-results>]
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
{ {
[ ] [ ]
[ ascii alien>nstring ] [ ascii alien>nstring ]
[ ] [ ]
[ *float swap ] [ ascii alien>nstring ]
[ *float ]
[ ]
[ ascii alien>nstring ] [ ascii alien>nstring ]
} spread } spread
] ] [ ] ] [
"CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" } "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
fortran-invoke-expansion (fortran-invoke)
] unit-test ] unit-test

194
basis/alien/fortran/fortran.factor
View File

@ -1,8 +1,11 @@
! (c) 2009 Joe Groff, see BSD license ! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.structs alien.syntax USING: accessors alien alien.c-types alien.complex alien.parser
arrays ascii assocs combinators fry kernel lexer macros math.parser alien.strings alien.structs alien.syntax arrays ascii assocs
namespaces parser sequences splitting vectors vocabs.parser locals byte-arrays combinators combinators.short-circuit fry generalizations
io.encodings.ascii io.encodings.string ; 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 IN: alien.fortran
! XXX this currently only supports the gfortran/f2c abi. ! XXX this currently only supports the gfortran/f2c abi.
@ -18,6 +21,8 @@ IN: alien.fortran
ERROR: invalid-fortran-type type ; ERROR: invalid-fortran-type type ;
DEFER: fortran-sig>c-sig DEFER: fortran-sig>c-sig
DEFER: fortran-ret-type>c-type
DEFER: fortran-arg-type>c-type
<PRIVATE <PRIVATE
@ -90,7 +95,7 @@ M: real-complex-type (fortran-type>c-type)
M: double-precision-type (fortran-type>c-type) M: double-precision-type (fortran-type>c-type)
"double" simple-type ; "double" simple-type ;
M: double-complex-type (fortran-type>c-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) M: misc-type (fortran-type>c-type)
dup name>> simple-type ; dup name>> simple-type ;
@ -118,7 +123,7 @@ M: character-type (fortran-type>c-type)
: (parse-fortran-type) ( fortran-type-string -- type ) : (parse-fortran-type) ( fortran-type-string -- type )
parse-out swap parse-dims swap parse-size swap parse-out swap parse-dims swap parse-size swap
dup >lower fortran>c-types at* 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 ) : parse-fortran-type ( fortran-type-string/f -- type/f )
dup [ (parse-fortran-type) ] when ; 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 ) 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) M: integer-type (fortran-arg>c-args)
size>> { [
{ f [ [ <int> ] [ drop ] ] } size>> {
{ 1 [ [ <char> ] [ drop ] ] } { f [ [ <int> ] [ drop ] ] }
{ 2 [ [ <short> ] [ drop ] ] } { 1 [ [ <char> ] [ drop ] ] }
{ 4 [ [ <int> ] [ drop ] ] } { 2 [ [ <short> ] [ drop ] ] }
{ 8 [ [ <longlong> ] [ drop ] ] } { 4 [ [ <int> ] [ drop ] ] }
[ invalid-fortran-type ] { 8 [ [ <longlong> ] [ drop ] ] }
} case ; [ invalid-fortran-type ]
} case
] args?dims ;
M: logical-type (fortran-arg>c-args) 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) M: real-type (fortran-arg>c-args)
size>> { [
{ f [ [ <float> ] [ drop ] ] } size>> {
{ 4 [ [ <float> ] [ drop ] ] } { f [ [ <float> ] [ drop ] ] }
{ 8 [ [ <double> ] [ drop ] ] } { 4 [ [ <float> ] [ drop ] ] }
[ invalid-fortran-type ] { 8 [ [ <double> ] [ drop ] ] }
} case ; [ invalid-fortran-type ]
} case
] args?dims ;
M: real-complex-type (fortran-arg>c-args) M: real-complex-type (fortran-arg>c-args)
size>> { [
{ f [ [ <complex-float> ] [ drop ] ] } size>> {
{ 8 [ [ <complex-float> ] [ drop ] ] } { f [ [ <complex-float> ] [ drop ] ] }
{ 16 [ [ <complex-double> ] [ drop ] ] } { 8 [ [ <complex-float> ] [ drop ] ] }
[ invalid-fortran-type ] { 16 [ [ <complex-double> ] [ drop ] ] }
} case ; [ invalid-fortran-type ]
} case
] args?dims ;
M: double-precision-type (fortran-arg>c-args) M: double-precision-type (fortran-arg>c-args)
drop [ <double> ] [ drop ] ; [ drop [ <double> ] [ drop ] ] args?dims ;
M: double-complex-type (fortran-arg>c-args) 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) M: character-type (fortran-arg>c-args)
drop [ ascii string>alien ] [ length ] ; drop [ ascii string>alien ] [ length ] ;
@ -190,72 +204,122 @@ M: character-type (fortran-arg>c-args)
M: misc-type (fortran-arg>c-args) M: misc-type (fortran-arg>c-args)
drop [ ] [ drop ] ; 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>) M: integer-type (fortran-result>)
size>> { [ size>> {
{ f [ [ *int ] ] } { f [ { [ *int ] } ] }
{ 1 [ [ *char ] ] } { 1 [ { [ *char ] } ] }
{ 2 [ [ *short ] ] } { 2 [ { [ *short ] } ] }
{ 4 [ [ *int ] ] } { 4 [ { [ *int ] } ] }
{ 8 [ [ *longlong ] ] } { 8 [ { [ *longlong ] } ] }
[ invalid-fortran-type ] [ invalid-fortran-type ]
} case ; } case ] result?dims ;
M: logical-type (fortran-result>) 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>) M: real-type (fortran-result>)
size>> { [ size>> {
{ f [ [ *float ] ] } { f [ { [ *float ] } ] }
{ 4 [ [ *float ] ] } { 4 [ { [ *float ] } ] }
{ 8 [ [ *double ] ] } { 8 [ { [ *double ] } ] }
[ invalid-fortran-type ] [ invalid-fortran-type ]
} case ; } case ] result?dims ;
M: real-complex-type (fortran-result>) M: real-complex-type (fortran-result>)
size>> { [ size>> {
{ f [ [ *complex-float ] ] } { f [ { [ *complex-float ] } ] }
{ 8 [ [ *complex-float ] ] } { 8 [ { [ *complex-float ] } ] }
{ 16 [ [ *complex-double ] ] } { 16 [ { [ *complex-double ] } ] }
[ invalid-fortran-type ] [ invalid-fortran-type ]
} case ; } case ] result?dims ;
M: double-precision-type (fortran-result>) M: double-precision-type (fortran-result>)
drop [ *double ] ; [ drop { [ *double ] } ] result?dims ;
M: double-complex-type (fortran-result>) M: double-complex-type (fortran-result>)
drop [ *complex-double ] ; [ drop { [ *complex-double ] } ] result?dims ;
M: character-type (fortran-result>) M: character-type (fortran-result>)
drop [ ascii alien>nstring ] ; drop { [ ] [ ascii alien>nstring ] } ;
M: misc-type (fortran-result>) M: misc-type (fortran-result>)
drop [ ] ; drop { [ ] } ;
GENERIC: (<fortran-result>) ( type -- quot ) GENERIC: (<fortran-result>) ( type -- quot )
M: fortran-type (<fortran-result>) 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 ) : [<fortran-result>] ( return parameters -- quot )
[ parse-fortran-type ] dip [ parse-fortran-type ] dip
over returns-by-value? over returns-by-value?
[ 2drop [ ] ] [ 2drop [ ] ]
[ [ (<fortran-result>) ] [ '[ _ _ ndip ] ] bi* ] if ; [ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
: [fortran-args>c-args] ( parameters -- quot ) : [fortran-args>c-args] ( parameters -- quot )
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 [ [ ] ] [
[ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
'[ _ _ ncleave ] ; [ [ \ 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 return parameters fortran-sig>c-sig :> c-parameters :> c-return
function fortran-name>symbol-name :> c-function 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 ) : [fortran-results>] ( return parameters -- quot )
2drop [ ] ; [ [fortran-result-shuffle] ]
[ drop [fortran-return>] ]
[ nip [ [fortran-out-param>] ] map concat ] 2tri
append
\ spread [ ] 2sequence append ;
PRIVATE> PRIVATE>
@ -289,22 +353,26 @@ PRIVATE>
: RECORD: scan in get parse-definition define-fortran-record ; parsing : 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>] ] [ 2nip [<fortran-result>] ]
[ nip nip nip [fortran-args>c-args] ] [ nip nip nip [fortran-args>c-args] ]
[ [fortran-invoke] ] [ [fortran-invoke] ]
[ 2nip [fortran-results>] ] [ 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 -- ) :: define-fortran-function ( return library function parameters -- )
function create-in dup reset-generic function create-in dup reset-generic
return library function parameters return parse-arglist return library function parameters return parse-arglist
[ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ; [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
: SUBROUTINE: : SUBROUTINE:
f "c-library" get scan ";" parse-tokens f "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing [ "()" subseq? not ] filter define-fortran-function ; parsing
: FUNCTION: : FUNCTION:
scan "c-library" get scan ";" parse-tokens scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing [ "()" subseq? not ] filter define-fortran-function ; parsing