fortran-invoke sketch

db4
Joe Groff 2009-02-06 19:05:56 -06:00
parent 6ff37d2951
commit 118f2de466
4 changed files with 260 additions and 104 deletions

View File

@ -15,4 +15,4 @@ C-STRUCT: complex-holder
C{ 1.0 2.0 } <complex-holder> "h" set
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test

View File

@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary
set-T-real DEFINES set-${T}-real
set-T-imaginary DEFINES set-${T}-imaginary
>T DEFINES >${T}
T> DEFINES ${T}>
<T> DEFINES <${T}>
*T DEFINES *${T}
WHERE
: >T ( z -- alien )
: <T> ( z -- alien )
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
: T> ( alien -- z )
: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
T in get
@ -28,8 +28,8 @@ T in get
define-struct
T c-type
T> 1quotation >>boxer-quot
>T 1quotation >>unboxer-quot
<T> 1quotation >>boxer-quot
*T 1quotation >>unboxer-quot
drop
;FUNCTOR
;FUNCTOR

View File

@ -1,12 +1,13 @@
! (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
@ -67,19 +68,16 @@ F-RECORD: fortran_test_record
[ "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" ]
@ -122,10 +120,10 @@ F-RECORD: 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*" } ]
@ -144,7 +142,7 @@ unit-test
[ "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
@ -164,44 +162,126 @@ 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
[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
! fortran-arg>c-args
! fortran-invoke
[ B{ 128 } { } ]
[ 128 "integer*1" fortran-arg>c-args ] unit-test
: fortran-invoke-expansion ( return library function parameters -- quot )
'[ _ _ _ _ fortran-invoke ] expand-macros ; inline
little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ?
[ 128 "integer*2" 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{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ?
[ 128 "integer*4" 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{ 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-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
[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ]
[ "hello" "character*5" 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
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
[ [
! [<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

View File

@ -1,20 +1,15 @@
! (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?
@ -22,9 +17,11 @@ C-STRUCT: (fortran-double-complex)
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 ;
@ -62,12 +59,12 @@ MACRO: size-case-type ( cases -- )
[ 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)
{
@ -85,9 +82,9 @@ M: real-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)
@ -108,6 +105,9 @@ M: character-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 ;
@ -115,10 +115,13 @@ M: character-type (fortran-type>c-type)
: 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 ;
@ -130,33 +133,23 @@ M: character-type added-c-args drop { "long" } ;
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 ;
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
: <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]
M: integer-type (fortran-arg>c-args)
size>> {
{ f [ [ <int> ] [ drop ] ] }
{ 1 [ [ <char> ] [ drop ] ] }
@ -166,7 +159,10 @@ M: integer-type [fortran-arg>c-args]
[ 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 ] ] }
@ -174,23 +170,92 @@ M: real-type [fortran-arg>c-args]
[ invalid-fortran-type ]
} case ;
M: real-complex-type [fortran-arg>c-args]
M: real-complex-type (fortran-arg>c-args)
size>> {
{ f [ [ <real-complex> ] [ drop ] ] }
{ 8 [ [ <real-complex> ] [ drop ] ] }
{ 16 [ [ <double-complex> ] [ drop ] ] }
{ f [ [ <complex-float> ] [ drop ] ] }
{ 8 [ [ <complex-float> ] [ drop ] ] }
{ 16 [ [ <complex-double> ] [ drop ] ] }
[ invalid-fortran-type ]
} case ;
M: real-complex-type [fortran-arg>c-args]
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 [ [ <real-complex> ] [ drop ] ] }
{ 8 [ [ <real-complex> ] [ drop ] ] }
{ 16 [ [ <double-complex> ] [ drop ] ] }
{ f [ [ *int ] ] }
{ 1 [ [ *char ] ] }
{ 2 [ [ *short ] ] }
{ 4 [ [ *int ] ] }
{ 8 [ [ *longlong ] ] }
[ invalid-fortran-type ]
} case ;
M:
M: logical-type (fortran-result>)
call-next-method [ zero? not ] append ;
M: real-type (fortran-result>)
size>> {
{ f [ [ *float ] ] }
{ 4 [ [ *float ] ] }
{ 8 [ [ *double ] ] }
[ invalid-fortran-type ]
} case ;
M: real-complex-type (fortran-result>)
size>> {
{ f [ [ *complex-float ] ] }
{ 8 [ [ *complex-float ] ] }
{ 16 [ [ *complex-double ] ] }
[ invalid-fortran-type ]
} case ;
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>
@ -219,17 +284,28 @@ 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
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 ;
:: 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 ;
: F-SUBROUTINE:
! : F-SUBROUTINE: ... ; parsing
! : F-FUNCTION: ... ; parsing
: 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