some initial work on invoking fortran functions
Joe Groff
parent
7b1f16ae5e
commit
7e2ac604e7
basis/alien/fortran
|
|
@ -1,3 +1,4 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.fortran alien.structs
|
||||
alien.syntax arrays assocs kernel namespaces sequences tools.test ;
|
||||
IN: alien.fortran.tests
|
||||
|
|
@ -11,6 +12,7 @@ F-RECORD: fortran_test_record
|
|||
|
||||
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
|
||||
[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
|
||||
|
||||
! fortran-type>c-type
|
||||
|
||||
|
|
@ -57,7 +59,7 @@ F-RECORD: fortran_test_record
|
|||
[ "real" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "double" ]
|
||||
[ "double precision" fortran-type>c-type ] unit-test
|
||||
[ "double-precision" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "float" ]
|
||||
[ "real*4" fortran-type>c-type ] unit-test
|
||||
|
|
@ -69,7 +71,7 @@ F-RECORD: fortran_test_record
|
|||
[ "complex" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "(fortran-double-complex)" ]
|
||||
[ "double complex" fortran-type>c-type ] unit-test
|
||||
[ "double-complex" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "(fortran-complex)" ]
|
||||
[ "complex*8" fortran-type>c-type ] unit-test
|
||||
|
|
@ -118,13 +120,13 @@ F-RECORD: fortran_test_record
|
|||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "double" { } ]
|
||||
[ "double precision" fortran-ret-type>c-type ] unit-test
|
||||
[ "double-precision" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "(fortran-complex)*" } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "(fortran-double-complex)*" } ]
|
||||
[ "double complex" fortran-ret-type>c-type ] unit-test
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "int*" } ]
|
||||
[ "integer(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
|
@ -155,7 +157,7 @@ unit-test
|
|||
{ "char[20]" "woo" }
|
||||
} ] [
|
||||
{
|
||||
{ "DOUBLE PRECISION" "EX" }
|
||||
{ "DOUBLE-PRECISION" "EX" }
|
||||
{ "REAL" "WYE" }
|
||||
{ "INTEGER" "ZEE" }
|
||||
{ "CHARACTER(20)" "WOO" }
|
||||
|
|
@ -169,3 +171,37 @@ unit-test
|
|||
[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
|
||||
[ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test
|
||||
|
||||
! fortran-arg>c-args
|
||||
|
||||
[ B{ 128 } { } ]
|
||||
[ 128 "integer*1" fortran-arg>c-args ] unit-test
|
||||
|
||||
little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ?
|
||||
[ 128 "integer*2" fortran-arg>c-args ] unit-test
|
||||
|
||||
little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ?
|
||||
[ 128 "integer*4" fortran-arg>c-args ] unit-test
|
||||
|
||||
little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ?
|
||||
[ 128 "integer*8" fortran-arg>c-args ] unit-test
|
||||
|
||||
[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ]
|
||||
[ "hello" "character*5" fortran-arg>c-args ] unit-test
|
||||
|
||||
little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ?
|
||||
[ 1.0 "real" fortran-arg>c-args ] unit-test
|
||||
|
||||
little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ?
|
||||
[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test
|
||||
|
||||
little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ?
|
||||
[ 1.0 "double-precision" fortran-arg>c-args ] unit-test
|
||||
|
||||
little-endian?
|
||||
[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ]
|
||||
[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ?
|
||||
[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test
|
||||
|
||||
[ B{ 1 0 0 0 2 0 0 0 } { } ]
|
||||
[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! (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 ;
|
||||
namespaces parser sequences splitting vectors vocabs.parser locals ;
|
||||
IN: alien.fortran
|
||||
|
||||
! XXX this currently only supports the gfortran/f2c abi.
|
||||
|
|
@ -43,9 +44,9 @@ CONSTANT: fortran>c-types H{
|
|||
{ "integer" integer-type }
|
||||
{ "logical" logical-type }
|
||||
{ "real" real-type }
|
||||
{ "double precision" double-precision-type }
|
||||
{ "double-precision" double-precision-type }
|
||||
{ "complex" real-complex-type }
|
||||
{ "double complex" double-complex-type }
|
||||
{ "double-complex" double-complex-type }
|
||||
}
|
||||
|
||||
: append-dimensions ( base-c-type type -- c-type )
|
||||
|
|
@ -82,7 +83,7 @@ M: real-type (fortran-type>c-type)
|
|||
{ 4 [ "float" ] }
|
||||
{ 8 [ "double" ] }
|
||||
} size-case-type ;
|
||||
M: complex-type (fortran-type>c-type)
|
||||
M: real-complex-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "(fortran-complex)" ] }
|
||||
{ 8 [ "(fortran-complex)" ] }
|
||||
|
|
@ -127,12 +128,6 @@ GENERIC: added-c-args ( type -- args )
|
|||
M: fortran-type added-c-args drop { } ;
|
||||
M: character-type added-c-args drop { "long" } ;
|
||||
|
||||
GENERIC: added-c-arg-values ( type -- arg-values )
|
||||
|
||||
M: fortran-type added-c-arg-values drop { } ;
|
||||
M: character-type added-c-arg-values
|
||||
fix-character-type dims>> first 1array ;
|
||||
|
||||
GENERIC: returns-by-value? ( type -- ? )
|
||||
|
||||
M: fortran-type returns-by-value? drop f ;
|
||||
|
|
@ -147,6 +142,56 @@ M: real-type (fortran-ret-type>c-type) drop "double" ;
|
|||
: suffix! ( seq elt -- seq ) over push ; inline
|
||||
: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
|
||||
|
||||
: <real-complex> ( complex -- byte-array )
|
||||
"(fortran-complex)" c-object
|
||||
[ [ real-part ] dip set-(fortran-complex)-r ]
|
||||
[ [ imaginary-part ] dip set-(fortran-complex)-i ]
|
||||
[ ] tri ;
|
||||
|
||||
: <double-complex> ( complex -- byte-array )
|
||||
"(fortran-double-complex)" c-object
|
||||
[ [ real-part ] dip set-(fortran-complex)-r ]
|
||||
[ [ imaginary-part ] dip set-(fortran-complex)-i ]
|
||||
[ ] tri ;
|
||||
|
||||
GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot )
|
||||
|
||||
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 ;
|
||||
|
||||
M: real-type [fortran-arg>c-args]
|
||||
size>> {
|
||||
{ f [ [ <float> ] [ drop ] ] }
|
||||
{ 4 [ [ <float> ] [ drop ] ] }
|
||||
{ 8 [ [ <double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
|
||||
M: real-complex-type [fortran-arg>c-args]
|
||||
size>> {
|
||||
{ f [ [ <real-complex> ] [ drop ] ] }
|
||||
{ 8 [ [ <real-complex> ] [ drop ] ] }
|
||||
{ 16 [ [ <double-complex> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
|
||||
M: real-complex-type [fortran-arg>c-args]
|
||||
size>> {
|
||||
{ f [ [ <real-complex> ] [ drop ] ] }
|
||||
{ 8 [ [ <real-complex> ] [ drop ] ] }
|
||||
{ 16 [ [ <double-complex> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ;
|
||||
|
||||
M:
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fortran-type>c-type ( fortran-type -- c-type )
|
||||
|
|
@ -178,6 +223,13 @@ PRIVATE>
|
|||
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
|
||||
|
||||
: F-RECORD: scan in get parse-definition define-record ; parsing
|
||||
|
||||
:: define-fortran-function ( return library function parameters -- )
|
||||
;
|
||||
|
||||
: F-SUBROUTINE:
|
||||
|
||||
|
||||
! : F-SUBROUTINE: ... ; parsing
|
||||
! : F-FUNCTION: ... ; parsing
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue