diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 11f0a2efc7..a1f2443b30 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -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 + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 327db12909..faec9b5b86 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -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 +: ( complex -- byte-array ) + "(fortran-complex)" c-object + [ [ real-part ] dip set-(fortran-complex)-r ] + [ [ imaginary-part ] dip set-(fortran-complex)-i ] + [ ] tri ; + +: ( 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 [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ 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