support different fortran ABIs

db4
Joe Groff 2009-02-10 13:11:06 -06:00
parent 1708d10c9a
commit 8a144b7b94
4 changed files with 418 additions and 255 deletions

View File

@ -1,9 +1,19 @@
! Copyright (C) 2009 Joe Groff
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations sequences strings ;
USING: help.markup help.syntax kernel quotations sequences strings words.symbol ;
QUALIFIED-WITH: alien.syntax c
IN: alien.fortran
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
{ $list
{ { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
{ { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
{ { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
{ { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
}
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
ARTICLE: "alien.fortran-types" "Fortran types"
"The Fortran FFI recognizes the following Fortran types:"
{ $list
@ -15,7 +25,7 @@ ARTICLE: "alien.fortran-types" "Fortran types"
{ { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
{ { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
{ "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
{ "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameters." }
{ "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." }
}
"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
@ -30,15 +40,20 @@ HELP: SUBROUTINE:
HELP: LIBRARY:
{ $syntax "LIBRARY: name" }
{ $values { "name" "a logical library name" } }
{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions." } ;
{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
HELP: RECORD:
{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" }
{ $description "Defines a Fortran record type with the given slots." } ;
{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ;
HELP: add-fortran-library
{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
;
HELP: fortran-invoke
{ $values
{ "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
{ "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
}
{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." }
;
@ -46,6 +61,8 @@ HELP: fortran-invoke
ARTICLE: "alien.fortran" "Fortran FFI"
"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
{ $subsection "alien.fortran-types" }
{ $subsection "alien.fortran-abis" }
{ $subsection add-fortran-library }
{ $subsection POSTPONE: LIBRARY: }
{ $subsection POSTPONE: FUNCTION: }
{ $subsection POSTPONE: SUBROUTINE: }

View File

@ -1,295 +1,381 @@
! (c) 2009 Joe Groff, see BSD license
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 ;
alien.fortran alien.fortran.private alien.strings alien.structs
arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
macros.expander namespaces sequences shuffle tools.test ;
IN: alien.fortran.tests
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
LIBRARY: (alien.fortran-tests)
RECORD: FORTRAN_TEST_RECORD
{ "INTEGER" "FOO" }
{ "REAL(2)" "BAR" }
{ "CHARACTER*4" "BAS" } ;
! fortran-name>symbol-name
intel-unix-abi fortran-abi [
[ "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-name>symbol-name
! fortran-type>c-type
[ "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
[ "short" ]
[ "integer*2" fortran-type>c-type ] unit-test
! fortran-type>c-type
[ "int" ]
[ "integer*4" fortran-type>c-type ] unit-test
[ "short" ]
[ "integer*2" fortran-type>c-type ] unit-test
[ "int" ]
[ "INTEGER" fortran-type>c-type ] unit-test
[ "int" ]
[ "integer*4" fortran-type>c-type ] unit-test
[ "longlong" ]
[ "iNteger*8" fortran-type>c-type ] unit-test
[ "int" ]
[ "INTEGER" fortran-type>c-type ] unit-test
[ "int[0]" ]
[ "integer(*)" fortran-type>c-type ] unit-test
[ "longlong" ]
[ "iNteger*8" fortran-type>c-type ] unit-test
[ "int[0]" ]
[ "integer(3,*)" fortran-type>c-type ] unit-test
[ "int[0]" ]
[ "integer(*)" fortran-type>c-type ] unit-test
[ "int[3]" ]
[ "integer(3)" fortran-type>c-type ] unit-test
[ "int[0]" ]
[ "integer(3,*)" fortran-type>c-type ] unit-test
[ "int[6]" ]
[ "integer(3,2)" fortran-type>c-type ] unit-test
[ "int[3]" ]
[ "integer(3)" fortran-type>c-type ] unit-test
[ "int[24]" ]
[ "integer(4,3,2)" fortran-type>c-type ] unit-test
[ "int[6]" ]
[ "integer(3,2)" fortran-type>c-type ] unit-test
[ "char[1]" ]
[ "character" fortran-type>c-type ] unit-test
[ "int[24]" ]
[ "integer(4,3,2)" fortran-type>c-type ] unit-test
[ "char[17]" ]
[ "character*17" fortran-type>c-type ] unit-test
[ "char" ]
[ "character" fortran-type>c-type ] unit-test
[ "char[17]" ]
[ "character(17)" fortran-type>c-type ] unit-test
[ "char" ]
[ "character*1" fortran-type>c-type ] unit-test
[ "int" ]
[ "logical" fortran-type>c-type ] unit-test
[ "char[17]" ]
[ "character*17" fortran-type>c-type ] unit-test
[ "float" ]
[ "real" fortran-type>c-type ] unit-test
[ "char[17]" ]
[ "character(17)" fortran-type>c-type ] unit-test
[ "double" ]
[ "double-precision" fortran-type>c-type ] unit-test
[ "int" ]
[ "logical" fortran-type>c-type ] unit-test
[ "float" ]
[ "real*4" fortran-type>c-type ] unit-test
[ "float" ]
[ "real" fortran-type>c-type ] unit-test
[ "double" ]
[ "real*8" fortran-type>c-type ] unit-test
[ "double" ]
[ "double-precision" fortran-type>c-type ] unit-test
[ "complex-float" ]
[ "complex" fortran-type>c-type ] unit-test
[ "float" ]
[ "real*4" fortran-type>c-type ] unit-test
[ "complex-double" ]
[ "double-complex" fortran-type>c-type ] unit-test
[ "double" ]
[ "real*8" fortran-type>c-type ] unit-test
[ "complex-float" ]
[ "complex*8" fortran-type>c-type ] unit-test
[ "complex-float" ]
[ "complex" fortran-type>c-type ] unit-test
[ "complex-double" ]
[ "complex*16" fortran-type>c-type ] unit-test
[ "complex-double" ]
[ "double-complex" fortran-type>c-type ] unit-test
[ "fortran_test_record" ]
[ "fortran_test_record" fortran-type>c-type ] unit-test
[ "complex-float" ]
[ "complex*8" fortran-type>c-type ] unit-test
! fortran-arg-type>c-type
[ "complex-double" ]
[ "complex*16" fortran-type>c-type ] unit-test
[ "int*" { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
[ "fortran_test_record" ]
[ "fortran_test_record" fortran-type>c-type ] unit-test
[ "int*" { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
! fortran-arg-type>c-type
[ "int*" { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
[ "int*" { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
[ "fortran_test_record*" { } ]
[ "fortran_test_record" fortran-arg-type>c-type ] unit-test
[ "int*" { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
[ "char*" { "long" } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ "int*" { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
[ "char*" { "long" } ]
[ "character(17)" fortran-arg-type>c-type ] unit-test
[ "fortran_test_record*" { } ]
[ "fortran_test_record" fortran-arg-type>c-type ] unit-test
! fortran-ret-type>c-type
[ "char*" { } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ "void" { "char*" "long" } ]
[ "character(17)" fortran-ret-type>c-type ] unit-test
[ "char*" { } ]
[ "character(1)" fortran-arg-type>c-type ] unit-test
[ "int" { } ]
[ "integer" fortran-ret-type>c-type ] unit-test
[ "char*" { "long" } ]
[ "character(17)" fortran-arg-type>c-type ] unit-test
[ "int" { } ]
[ "logical" fortran-ret-type>c-type ] unit-test
! fortran-ret-type>c-type
[ "float" { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ "char" { } ]
[ "character(1)" fortran-ret-type>c-type ] unit-test
[ "double" { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
[ "void" { "char*" "long" } ]
[ "character(17)" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-float*" } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ "int" { } ]
[ "integer" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-double*" } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ "int" { } ]
[ "logical" fortran-ret-type>c-type ] unit-test
[ "void" { "int*" } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test
[ "float" { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ "void" { "fortran_test_record*" } ]
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
[ "void" { "float*" } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
! fortran-sig>c-sig
[ "double" { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
[ "float" { "int*" "char*" "float*" "double*" "long" } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
unit-test
[ "void" { "complex-float*" } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ "void" { "complex-double*" } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ "void" { "int*" } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test
! fortran-record>c-struct
[ "void" { "fortran_test_record*" } ]
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
[ {
{ "double" "ex" }
{ "float" "wye" }
{ "int" "zee" }
{ "char[20]" "woo" }
} ] [
{
{ "DOUBLE-PRECISION" "EX" }
{ "REAL" "WYE" }
{ "INTEGER" "ZEE" }
{ "CHARACTER(20)" "WOO" }
} fortran-record>c-struct
] unit-test
! fortran-sig>c-sig
! RECORD:
[ "float" { "int*" "char*" "float*" "double*" "long" } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
unit-test
[ 16 ] [ "fortran_test_record" heap-size ] unit-test
[ 0 ] [ "foo" "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
[ "char" { "char*" "char*" "int*" "long" } ]
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
! (fortran-invoke)
[ "void" { "char*" "long" "char*" "char*" "int*" "long" } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ [
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <longlong> ]
[ <float> ]
[ <complex-float> ]
[ 1 0 ? <short> ]
} spread ]
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
} 5 ncleave
! [fortran-invoke]
[
"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 ]
} spread
] ] [
f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
(fortran-invoke)
] unit-test
[ "void" { "complex-float*" "char*" "char*" "int*" "long" } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
[ [
! [fortran-args>c-args]
{
[ { [ ] } spread ]
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke]
[ "float" "funpack" "fun_times__" { "float*" } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ ] [ drop ] } spread
] ] [
"REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
! fortran-record>c-struct
[ [
! [<fortran-result>]
[ "complex-float" <c-object> ] 1 ndip
! [fortran-args>c-args]
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
! [fortran-invoke]
[
"void" "funpack" "fun_times__"
{ "complex-float*" "float*" }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ *complex-float ] [ drop ] } spread
] ] [
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
[ {
{ "double" "ex" }
{ "float" "wye" }
{ "int" "zee" }
{ "char[20]" "woo" }
} ] [
{
{ "DOUBLE-PRECISION" "EX" }
{ "REAL" "WYE" }
{ "INTEGER" "ZEE" }
{ "CHARACTER(20)" "WOO" }
} fortran-record>c-struct
] unit-test
[ [
! [<fortran-result>]
[ 20 <byte-array> 20 ] 0 ndip
! [fortran-invoke]
[
"void" "funpack" "fun_times__"
{ "char*" "long" }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta retb -- reta retb )
{ [ ] [ ascii alien>nstring ] } spread
] ] [
"CHARACTER*20" "funpack" "FUN_TIMES" { }
(fortran-invoke)
] unit-test
! RECORD:
[ [
! [<fortran-result>]
[ 10 <byte-array> 10 ] 3 ndip
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <float> ]
[ ascii string>alien ]
} spread ]
[ { [ length ] [ drop ] [ length ] } spread ]
} 3 ncleave
! [fortran-invoke]
[
"void" "funpack" "fun_times__"
{ "char*" "long" "char*" "float*" "char*" "long" "long" }
alien-invoke
] 7 nkeep
! [fortran-results>]
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
{
[ ]
[ ascii alien>nstring ]
[ ]
[ ascii alien>nstring ]
[ *float ]
[ ]
[ ascii alien>nstring ]
} spread
] ] [
"CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
(fortran-invoke)
] unit-test
[ 16 ] [ "fortran_test_record" heap-size ] unit-test
[ 0 ] [ "foo" "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
! (fortran-invoke)
[ [
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <longlong> ]
[ <float> ]
[ <complex-float> ]
[ 1 0 ? <short> ]
} spread ]
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
} 5 ncleave
! [fortran-invoke]
[
"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 ]
} spread
] ] [
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]
[ "float" "funpack" "fun_times_" { "float*" } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ ] [ drop ] } spread
] ] [
"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" "funpack" "fun_times_"
{ "complex-float*" "float*" }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
{ [ *complex-float ] [ drop ] } spread
] ] [
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ 20 <byte-array> 20 ] 0 ndip
! [fortran-invoke]
[
"void" "funpack" "fun_times_"
{ "char*" "long" }
alien-invoke
] 2 nkeep
! [fortran-results>]
shuffle( reta retb -- reta retb )
{ [ ] [ ascii alien>nstring ] } spread
] ] [
"CHARACTER*20" "funpack" "FUN_TIMES" { }
(fortran-invoke)
] unit-test
[ [
! [<fortran-result>]
[ 10 <byte-array> 10 ] 3 ndip
! [fortran-args>c-args]
{
[ {
[ ascii string>alien ]
[ <float> ]
[ ascii string>alien ]
} spread ]
[ { [ length ] [ drop ] [ length ] } spread ]
} 3 ncleave
! [fortran-invoke]
[
"void" "funpack" "fun_times_"
{ "char*" "long" "char*" "float*" "char*" "long" "long" }
alien-invoke
] 7 nkeep
! [fortran-results>]
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
{
[ ]
[ ascii alien>nstring ]
[ ]
[ ascii alien>nstring ]
[ *float ]
[ ]
[ ascii alien>nstring ]
} spread
] ] [
"CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
(fortran-invoke)
] unit-test
] with-variable ! intel-unix-abi
intel-windows-abi fortran-abi [
[ "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
] with-variable
f2c-abi fortran-abi [
[ "char[1]" ]
[ "character(1)" fortran-type>c-type ] unit-test
[ "char*" { "long" } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ "void" { "char*" "long" } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ "double" { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ "void" { "float*" } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ "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
] with-variable
gfortran-abi fortran-abi [
[ "float" { } ]
[ "real" fortran-ret-type>c-type ] unit-test
[ "void" { "float*" } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ "complex-float" { } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ "complex-double" { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ "char[1]" ]
[ "character(1)" fortran-type>c-type ] unit-test
[ "char*" { "long" } ]
[ "character" fortran-arg-type>c-type ] unit-test
[ "void" { "char*" "long" } ]
[ "character" fortran-ret-type>c-type ] unit-test
[ "complex-float" { } ]
[ "complex" fortran-ret-type>c-type ] unit-test
[ "complex-double" { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ "void" { "complex-double*" } ]
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
] with-variable

View File

@ -5,11 +5,10 @@ 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 system ;
math.order sorting strings system ;
IN: alien.fortran
! XXX this currently only supports the gfortran/f2c abi.
! XXX we should also support ifort at some point for commercial BLASes
SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
@ -22,18 +21,55 @@ os netbsd? [ add-f2c-libraries ] when
: alien>nstring ( alien len encoding -- string )
[ memory>byte-array ] dip decode ;
: fortran-name>symbol-name ( fortran-name -- c-name )
>lower CHAR: _ over member?
[ "__" append ] [ "_" append ] if ;
ERROR: invalid-fortran-type type ;
DEFER: fortran-sig>c-sig
DEFER: fortran-ret-type>c-type
DEFER: fortran-arg-type>c-type
DEFER: fortran-name>symbol-name
SYMBOL: library-fortran-abis
SYMBOL: fortran-abi
library-fortran-abis [ H{ } clone ] initialize
<PRIVATE
: lowercase-name-with-underscore ( name -- name' )
>lower "_" append ;
: lowercase-name-with-extra-underscore ( name -- name' )
>lower CHAR: _ over member?
[ "__" append ] [ "_" append ] if ;
HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
M: gfortran-abi real-functions-return-double? f ;
M: intel-unix-abi real-functions-return-double? f ;
M: intel-windows-abi real-functions-return-double? f ;
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
M: f2c-abi complex-functions-return-by-value? f ;
M: gfortran-abi complex-functions-return-by-value? t ;
M: intel-unix-abi complex-functions-return-by-value? f ;
M: intel-windows-abi complex-functions-return-by-value? f ;
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
M: f2c-abi character(1)-maps-to-char? f ;
M: gfortran-abi character(1)-maps-to-char? f ;
M: intel-unix-abi character(1)-maps-to-char? t ;
M: intel-windows-abi character(1)-maps-to-char? t ;
HOOK: mangle-name fortran-abi ( name -- name' )
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
M: intel-windows-abi mangle-name >upper ;
TUPLE: fortran-type dims size out? ;
TUPLE: number-type < fortran-type ;
@ -107,10 +143,14 @@ M: double-complex-type (fortran-type>c-type)
M: misc-type (fortran-type>c-type)
dup name>> simple-type ;
: single-char? ( character-type -- ? )
{ [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
: fix-character-type ( character-type -- character-type' )
clone dup size>>
[ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
[ dup dims>> [ ] [ { 1 } >>dims ] if ] if ;
[ dup dims>> [ ] [ f >>dims ] if ] if
dup single-char? [ f >>dims ] when ;
M: character-type (fortran-type>c-type)
fix-character-type "char" simple-type ;
@ -142,22 +182,23 @@ M: character-type (fortran-type>c-type)
GENERIC: added-c-args ( type -- args )
M: fortran-type added-c-args drop { } ;
M: character-type added-c-args drop { "long" } ;
M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;
GENERIC: returns-by-value? ( type -- ? )
M: f returns-by-value? drop t ;
M: fortran-type returns-by-value? drop f ;
M: number-type returns-by-value? dims>> not ;
M: complex-type returns-by-value? drop f ;
M: character-type returns-by-value? fix-character-type single-char? ;
M: complex-type returns-by-value?
{ [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
M: f (fortran-ret-type>c-type) drop "void" ;
M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
! XXX F2C claims to return double for REAL typed functions
! XXX OSX Accelerate.framework uses float
! M: real-type (fortran-ret-type>c-type) drop "double" ;
M: real-type (fortran-ret-type>c-type)
drop real-functions-return-double? [ "double" ] [ "float" ] if ;
: suffix! ( seq elt -- seq ) over push ; inline
: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
@ -209,7 +250,9 @@ M: double-complex-type (fortran-arg>c-args)
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
M: character-type (fortran-arg>c-args)
drop [ ascii string>alien ] [ length ] ;
fix-character-type single-char?
[ [ first <char> ] [ drop ] ]
[ [ ascii string>alien ] [ length ] ] if ;
M: misc-type (fortran-arg>c-args)
drop [ ] [ drop ] ;
@ -255,7 +298,9 @@ M: double-complex-type (fortran-result>)
[ drop { [ *complex-double ] } ] result?dims ;
M: character-type (fortran-result>)
drop { [ ] [ ascii alien>nstring ] } ;
fix-character-type single-char?
[ { [ *char 1string ] } ]
[ { [ ] [ ascii alien>nstring ] } ] if ;
M: misc-type (fortran-result>)
drop { [ ] } ;
@ -331,8 +376,18 @@ M: character-type (<fortran-result>)
append
\ spread [ ] 2sequence append ;
: (add-fortran-library) ( fortran-abi name -- )
library-fortran-abis get-global set-at ;
PRIVATE>
: add-fortran-library ( name soname fortran-abi -- )
[ fortran-abi [ fortran-c-abi ] with-variable add-library ]
[ nip swap (add-fortran-library) ] 3bi ;
: fortran-name>symbol-name ( fortran-name -- c-name )
mangle-name ;
: fortran-type>c-type ( fortran-type -- c-type )
parse-fortran-type (fortran-type>c-type) ;
@ -344,7 +399,7 @@ PRIVATE>
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
"void" swap
[ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix
[ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix
] if ;
: fortran-arg-types>c-types ( fortran-types -- c-types )
@ -388,4 +443,7 @@ MACRO: fortran-invoke ( return library function parameters -- )
[ "()" subseq? not ] filter define-fortran-function ; parsing
: LIBRARY:
scan "c-library" set ; parsing
scan
[ "c-library" set ]
[ library-fortran-abis get-global at fortran-abi set ] bi ; parsing

View File

@ -3,9 +3,11 @@ IN: math.blas.ffi
<<
"blas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
[ "libblas.so" "cdecl" add-library ]
{ [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
{ [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
{ [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
{ [ os freebsd? ] [ "libblas.so" gfortran-abi add-fortran-library ] }
[ "libblas.so" f2c-abi add-fortran-library ]
} cond
>>