! (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 ;
+alien.syntax arrays assocs kernel macros namespaces sequences
+tools.test fry ;
IN: alien.fortran.tests
-F-RECORD: fortran_test_record
- { "integer" "foo" }
- { "real" "bar" }
- { "character*4" "bas" } ;
+RECORD: FORTRAN_TEST_RECORD
+ { "INTEGER" "FOO" }
+ { "REAL(2)" "BAR" }
+ { "CHARACTER*4" "BAS" } ;
! fortran-name>symbol-name
[ "double" ]
[ "real*8" fortran-type>c-type ] unit-test
-[ "(fortran-complex)" ]
+[ "complex-float" ]
[ "complex" fortran-type>c-type ] unit-test
-[ "(fortran-double-complex)" ]
+[ "complex-double" ]
[ "double-complex" fortran-type>c-type ] unit-test
-[ "(fortran-complex)" ]
+[ "complex-float" ]
[ "complex*8" fortran-type>c-type ] unit-test
-[ "(fortran-double-complex)" ]
-[ "complex*16" fortran-type>c-type ] unit-test
-
-[ "(fortran-double-complex)" ]
+[ "complex-double" ]
[ "complex*16" fortran-type>c-type ] unit-test
[ "fortran_test_record" ]
[ "double" { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
-[ "void" { "(fortran-complex)*" } ]
+[ "void" { "complex-float*" } ]
[ "complex" fortran-ret-type>c-type ] unit-test
-[ "void" { "(fortran-double-complex)*" } ]
+[ "void" { "complex-double*" } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
[ "void" { "int*" } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
-[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ]
+[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
} fortran-record>c-struct
] unit-test
-! F-RECORD:
+! RECORD:
-[ 12 ] [ "fortran_test_record" heap-size ] 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
-[ 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
+[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
-little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ?
-[ 128 "integer*4" fortran-arg>c-args ] unit-test
+! fortran-invoke
-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
+: fortran-invoke-expansion ( return library function parameters -- quot )
+ '[ _ _ _ _ fortran-invoke ] expand-macros ; inline
-[ 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
+[ [
+ ! [fortran-args>c-args]
+ {
+ [ {
+ [ ascii string>alien ]
+ [ <int> ]
+ [ <float> ]
+ [ <complex-float> ]
+ [ 1 0 ? <short> ]
+ } spread ]
+ [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
+ } 5 ncleave
+ ! [fortran-invoke]
+ [
+ "void" "foopack" "funtimes_"
+ { "char*" "int*" "float*" "complex-float*" "short*" "long" }
+ alien-invoke
+ ] 6 nkeep
+ ! [fortran-results>]
+ {
+ [ drop ]
+ [ drop ]
+ [ *float ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ } spread
+] ] [
+ f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
+ fortran-invoke-expansion
+] 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
+[ [
+ ! [fortran-invoke]
+ "double" "foopack" "fun_times__"
+ { "float*" }
+ alien-invoke
+] ] [
+ "REAL" "foopack" "FUN_TIMES" { "REAL(*)" }
+ fortran-invoke-expansion
+] 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
+[ [
+ ! [<fortran-result>]
+ [ "complex-float" <c-object> ] 1 ndip
+ ! [fortran-invoke]
+ [
+ "void" "foopack" "fun_times__"
+ { "complex-float*" "float*" }
+ alien-invoke
+ ] 2 nkeep
+ ! [fortran-results>]
+ {
+ [ *complex-float ]
+ [ drop ]
+ } spread
+] ] [
+ "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" }
+ fortran-invoke-expansion
+] 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
+[ [
+ ! [<fortran-result>]
+ [ 20 <byte-array> 20 ] 1 ndip
+ ! [fortran-invoke]
+ [
+ "void" "foopack" "fun_times__"
+ { "char*" "long" "float*" }
+ alien-invoke
+ ] 3 nkeep
+ ! [fortran-results>]
+ {
+ [ ]
+ [ ascii alien>nstring ]
+ [ drop ]
+ } spread
+] ] [
+ "CHARACTER*20" "foopack" "FUN_TIMES" { }
+ fortran-invoke-expansion
+] 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
+[ [
+ ! [<fortran-result>]
+ [ 10 <byte-array> 10 ] 2 ndip
+ ! [fortran-args>c-args]
+ {
+ [ {
+ [ ascii string>alien ]
+ [ <float> ]
+ } spread ]
+ [ { [ length ] [ drop ] } spread ]
+ } 2 ncleave
+ ! [fortran-invoke]
+ [
+ "void" "foopack" "fun_times__"
+ { "char*" "long" "char*" "float*" "long" }
+ alien-invoke
+ ] 5 nkeep
+ ! [fortran-results>]
+ {
+ [ ]
+ [ ascii alien>nstring ]
+ [ ]
+ [ *float swap ]
+ [ ascii alien>nstring ]
+ } spread
+] ] [
+ "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" }
+ fortran-invoke-expansion
+] unit-test
! (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 ;
+namespaces parser sequences splitting vectors vocabs.parser locals
+io.encodings.ascii io.encodings.string ;
IN: alien.fortran
! XXX this currently only supports the gfortran/f2c abi.
! XXX we should also support ifort at some point for commercial BLASes
-C-STRUCT: (fortran-complex)
- { "float" "r" }
- { "float" "i" } ;
-C-STRUCT: (fortran-double-complex)
- { "double" "r" }
- { "double" "i" } ;
-
-: fortran-c-abi ( -- abi ) "cdecl" ;
+: alien>nstring ( alien len encoding -- string )
+ [ memory>byte-array ] dip decode ;
: fortran-name>symbol-name ( fortran-name -- c-name )
>lower CHAR: _ over member?
ERROR: invalid-fortran-type type ;
+DEFER: fortran-sig>c-sig
+
<PRIVATE
-TUPLE: fortran-type dims size ;
+TUPLE: fortran-type dims size out? ;
TUPLE: number-type < fortran-type ;
TUPLE: integer-type < number-type ;
[ dup size>> [ invalid-fortran-type ] [ drop ] if ]
[ append-dimensions ] bi ;
-: new-fortran-type ( dims size class -- type )
- new [ (>>size) ] [ (>>dims) ] [ ] tri ;
+: new-fortran-type ( out? dims size class -- type )
+ new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
GENERIC: (fortran-type>c-type) ( type -- c-type )
-M: f (fortran-type>c-type) ;
+M: f (fortran-type>c-type) drop "void" ;
M: integer-type (fortran-type>c-type)
{
} size-case-type ;
M: real-complex-type (fortran-type>c-type)
{
- { f [ "(fortran-complex)" ] }
- { 8 [ "(fortran-complex)" ] }
- { 16 [ "(fortran-double-complex)" ] }
+ { f [ "complex-float" ] }
+ { 8 [ "complex-float" ] }
+ { 16 [ "complex-double" ] }
} size-case-type ;
M: double-precision-type (fortran-type>c-type)
: dimension>number ( string -- number )
dup "*" = [ drop 0 ] [ string>number ] if ;
+: parse-out ( string -- string' out? )
+ "!" ?head ;
+
: parse-dims ( string -- string' dim )
"(" split1 dup
[ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
: parse-size ( string -- string' size )
"*" split1 dup [ string>number ] when ;
-: parse-fortran-type ( fortran-type-string -- type )
- parse-dims swap parse-size swap
+: (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 misc-type boa ] if ;
+ [ nip new-fortran-type ] [ drop f misc-type boa ] if ;
+
+: parse-fortran-type ( fortran-type-string/f -- type/f )
+ dup [ (parse-fortran-type) ] when ;
: c-type>pointer ( c-type -- c-type* )
"[" split1 drop "*" append ;
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 ;
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) ;
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 )
-GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot )
-
-M: integer-type [fortran-arg>c-args]
+M: integer-type (fortran-arg>c-args)
size>> {
{ f [ [ <int> ] [ drop ] ] }
{ 1 [ [ <char> ] [ drop ] ] }
[ invalid-fortran-type ]
} case ;
-M: real-type [fortran-arg>c-args]
+M: logical-type (fortran-arg>c-args)
+ call-next-method [ [ 1 0 ? ] prepend ] dip ;
+
+M: real-type (fortran-arg>c-args)
size>> {
{ f [ [ <float> ] [ drop ] ] }
{ 4 [ [ <float> ] [ drop ] ] }
[ invalid-fortran-type ]
} case ;
-M: real-complex-type [fortran-arg>c-args]
+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 ;
+
+M: double-precision-type (fortran-arg>c-args)
+ drop [ <double> ] [ drop ] ;
+
+M: double-complex-type (fortran-arg>c-args)
+ drop [ <complex-double> ] [ drop ] ;
+
+M: character-type (fortran-arg>c-args)
+ drop [ ascii string>alien ] [ length ] ;
+
+M: misc-type (fortran-arg>c-args)
+ drop [ ] [ drop ] ;
+
+GENERIC: (fortran-result>) ( type -- quot )
+
+M: integer-type (fortran-result>)
+ size>> {
+ { f [ [ *int ] ] }
+ { 1 [ [ *char ] ] }
+ { 2 [ [ *short ] ] }
+ { 4 [ [ *int ] ] }
+ { 8 [ [ *longlong ] ] }
+ [ invalid-fortran-type ]
+ } case ;
+
+M: logical-type (fortran-result>)
+ call-next-method [ zero? not ] append ;
+
+M: real-type (fortran-result>)
size>> {
- { f [ [ <real-complex> ] [ drop ] ] }
- { 8 [ [ <real-complex> ] [ drop ] ] }
- { 16 [ [ <double-complex> ] [ drop ] ] }
+ { f [ [ *float ] ] }
+ { 4 [ [ *float ] ] }
+ { 8 [ [ *double ] ] }
[ invalid-fortran-type ]
} case ;
-M: real-complex-type [fortran-arg>c-args]
+M: real-complex-type (fortran-result>)
size>> {
- { f [ [ <real-complex> ] [ drop ] ] }
- { 8 [ [ <real-complex> ] [ drop ] ] }
- { 16 [ [ <double-complex> ] [ drop ] ] }
+ { f [ [ *complex-float ] ] }
+ { 8 [ [ *complex-float ] ] }
+ { 16 [ [ *complex-double ] ] }
[ invalid-fortran-type ]
} case ;
-M:
+M: double-precision-type (fortran-result>)
+ drop [ *double ] ;
+
+M: double-complex-type (fortran-result>)
+ drop [ *complex-double ] ;
+
+M: character-type (fortran-result>)
+ drop [ ascii alien>nstring ] ;
+
+M: misc-type (fortran-result>)
+ drop [ ] ;
+
+GENERIC: (<fortran-result>) ( type -- quot )
+
+M: fortran-type (<fortran-result>)
+ (fortran-type>c-type) '[ _ <c-object> ] ;
+
+: [<fortran-result>] ( return parameters -- quot )
+ [ parse-fortran-type ] dip
+ over returns-by-value?
+ [ 2drop [ ] ]
+ [ [ (<fortran-result>) ] [ '[ _ _ ndip ] ] 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 ] ;
+
+:: [fortran-invoke] ( return library function parameters -- 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 ] ;
+
+: [fortran-results>] ( return parameters -- quot )
+ 2drop [ ] ;
PRIVATE>
: fortran-record>c-struct ( record -- struct )
[ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
-: define-record ( name vocab fields -- )
+: define-fortran-record ( name vocab fields -- )
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
-: F-RECORD: scan in get parse-definition define-record ; parsing
+: RECORD: scan in get parse-definition define-fortran-record ; parsing
-:: define-fortran-function ( return library function parameters -- )
- ;
-
-: F-SUBROUTINE:
-
+MACRO: fortran-invoke ( return library function parameters -- )
+ {
+ [ 2nip [<fortran-result>] ]
+ [ nip nip nip [fortran-args>c-args] ]
+ [ [fortran-invoke] ]
+ [ 2nip [fortran-results>] ]
+ } 4 ncleave 3append ;
-! : F-SUBROUTINE: ... ; parsing
-! : F-FUNCTION: ... ; parsing
+:: 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 ;
+
+: 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
projects / factor.git / commitdiff