steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/alien/complex/functor/functor.factor
View File

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

170
basis/alien/fortran/fortran-tests.factor
View File

@ -1,12 +1,13 @@
! (c) 2009 Joe Groff, see BSD license ! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.fortran alien.structs 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 IN: alien.fortran.tests
F-RECORD: fortran_test_record RECORD: FORTRAN_TEST_RECORD
{ "integer" "foo" } { "INTEGER" "FOO" }
{ "real" "bar" } { "REAL(2)" "BAR" }
{ "character*4" "bas" } ; { "CHARACTER*4" "BAS" } ;
! fortran-name>symbol-name ! fortran-name>symbol-name
@ -67,19 +68,16 @@ F-RECORD: fortran_test_record
[ "double" ] [ "double" ]
[ "real*8" fortran-type>c-type ] unit-test [ "real*8" fortran-type>c-type ] unit-test
[ "(fortran-complex)" ] [ "complex-float" ]
[ "complex" fortran-type>c-type ] unit-test [ "complex" fortran-type>c-type ] unit-test
[ "(fortran-double-complex)" ] [ "complex-double" ]
[ "double-complex" fortran-type>c-type ] unit-test [ "double-complex" fortran-type>c-type ] unit-test
[ "(fortran-complex)" ] [ "complex-float" ]
[ "complex*8" fortran-type>c-type ] unit-test [ "complex*8" fortran-type>c-type ] unit-test
[ "(fortran-double-complex)" ] [ "complex-double" ]
[ "complex*16" fortran-type>c-type ] unit-test
[ "(fortran-double-complex)" ]
[ "complex*16" fortran-type>c-type ] unit-test [ "complex*16" fortran-type>c-type ] unit-test
[ "fortran_test_record" ] [ "fortran_test_record" ]
@ -122,10 +120,10 @@ F-RECORD: fortran_test_record
[ "double" { } ] [ "double" { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test [ "double-precision" fortran-ret-type>c-type ] unit-test
[ "void" { "(fortran-complex)*" } ] [ "void" { "complex-float*" } ]
[ "complex" fortran-ret-type>c-type ] unit-test [ "complex" fortran-ret-type>c-type ] unit-test
[ "void" { "(fortran-double-complex)*" } ] [ "void" { "complex-double*" } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test [ "double-complex" fortran-ret-type>c-type ] unit-test
[ "void" { "int*" } ] [ "void" { "int*" } ]
@ -144,7 +142,7 @@ unit-test
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test 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 ] [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test unit-test
@ -164,44 +162,126 @@ unit-test
} fortran-record>c-struct } fortran-record>c-struct
] unit-test ] 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 [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
[ 4 ] [ "bar" "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 } { } ] : fortran-invoke-expansion ( return library function parameters -- quot )
[ 128 "integer*1" fortran-arg>c-args ] unit-test '[ _ _ _ _ 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 ! [<fortran-result>]
[ 10 <byte-array> 10 ] 2 ndip
little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ? ! [fortran-args>c-args]
[ 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 } { } ] ? [ ascii string>alien ]
[ 1.0 "double-precision" fortran-arg>c-args ] unit-test [ <float> ]
} spread ]
little-endian? [ { [ length ] [ drop ] } spread ]
[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] } 2 ncleave
[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ? ! [fortran-invoke]
[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test [
"void" "foopack" "fun_times__"
[ B{ 1 0 0 0 2 0 0 0 } { } ] { "char*" "long" "char*" "float*" "long" }
[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test 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

178
basis/alien/fortran/fortran.factor
View File

@ -1,20 +1,15 @@
! (c) 2009 Joe Groff, see BSD license ! (c) 2009 Joe Groff, see BSD license
USING: accessors alien alien.c-types alien.structs alien.syntax USING: accessors alien alien.c-types alien.structs alien.syntax
arrays ascii assocs combinators fry kernel lexer macros math.parser 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 IN: alien.fortran
! XXX this currently only supports the gfortran/f2c abi. ! XXX this currently only supports the gfortran/f2c abi.
! XXX we should also support ifort at some point for commercial BLASes ! XXX we should also support ifort at some point for commercial BLASes
C-STRUCT: (fortran-complex) : alien>nstring ( alien len encoding -- string )
{ "float" "r" } [ memory>byte-array ] dip decode ;
{ "float" "i" } ;
C-STRUCT: (fortran-double-complex)
{ "double" "r" }
{ "double" "i" } ;
: fortran-c-abi ( -- abi ) "cdecl" ;
: fortran-name>symbol-name ( fortran-name -- c-name ) : fortran-name>symbol-name ( fortran-name -- c-name )
>lower CHAR: _ over member? >lower CHAR: _ over member?
@ -22,9 +17,11 @@ C-STRUCT: (fortran-double-complex)
ERROR: invalid-fortran-type type ; ERROR: invalid-fortran-type type ;
DEFER: fortran-sig>c-sig
<PRIVATE <PRIVATE
TUPLE: fortran-type dims size ; TUPLE: fortran-type dims size out? ;
TUPLE: number-type < fortran-type ; TUPLE: number-type < fortran-type ;
TUPLE: integer-type < number-type ; TUPLE: integer-type < number-type ;
@ -62,12 +59,12 @@ MACRO: size-case-type ( cases -- )
[ dup size>> [ invalid-fortran-type ] [ drop ] if ] [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
[ append-dimensions ] bi ; [ append-dimensions ] bi ;
: new-fortran-type ( dims size class -- type ) : new-fortran-type ( out? dims size class -- type )
new [ (>>size) ] [ (>>dims) ] [ ] tri ; new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
GENERIC: (fortran-type>c-type) ( type -- c-type ) 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) M: integer-type (fortran-type>c-type)
{ {
@ -85,9 +82,9 @@ M: real-type (fortran-type>c-type)
} size-case-type ; } size-case-type ;
M: real-complex-type (fortran-type>c-type) M: real-complex-type (fortran-type>c-type)
{ {
{ f [ "(fortran-complex)" ] } { f [ "complex-float" ] }
{ 8 [ "(fortran-complex)" ] } { 8 [ "complex-float" ] }
{ 16 [ "(fortran-double-complex)" ] } { 16 [ "complex-double" ] }
} size-case-type ; } size-case-type ;
M: double-precision-type (fortran-type>c-type) M: double-precision-type (fortran-type>c-type)
@ -108,6 +105,9 @@ M: character-type (fortran-type>c-type)
: dimension>number ( string -- number ) : dimension>number ( string -- number )
dup "*" = [ drop 0 ] [ string>number ] if ; dup "*" = [ drop 0 ] [ string>number ] if ;
: parse-out ( string -- string' out? )
"!" ?head ;
: parse-dims ( string -- string' dim ) : parse-dims ( string -- string' dim )
"(" split1 dup "(" split1 dup
[ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; [ ")" ?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 ) : parse-size ( string -- string' size )
"*" split1 dup [ string>number ] when ; "*" split1 dup [ string>number ] when ;
: parse-fortran-type ( fortran-type-string -- type ) : (parse-fortran-type) ( fortran-type-string -- type )
parse-dims swap parse-size swap parse-out swap parse-dims swap parse-size swap
dup >lower fortran>c-types at* 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* ) : c-type>pointer ( c-type -- c-type* )
"[" split1 drop "*" append ; "[" split1 drop "*" append ;
@ -130,33 +133,23 @@ M: character-type added-c-args drop { "long" } ;
GENERIC: returns-by-value? ( type -- ? ) GENERIC: returns-by-value? ( type -- ? )
M: f returns-by-value? drop t ;
M: fortran-type returns-by-value? drop f ; M: fortran-type returns-by-value? drop f ;
M: number-type returns-by-value? dims>> not ; M: number-type returns-by-value? dims>> not ;
M: complex-type returns-by-value? drop f ; M: complex-type returns-by-value? drop f ;
GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) 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: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
M: real-type (fortran-ret-type>c-type) drop "double" ; M: real-type (fortran-ret-type>c-type) drop "double" ;
: suffix! ( seq elt -- seq ) over push ; inline : suffix! ( seq elt -- seq ) over push ; inline
: append! ( seq-a seq-b -- seq-a ) over push-all ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline
: <real-complex> ( complex -- byte-array ) GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
"(fortran-complex)" c-object
[ [ real-part ] dip set-(fortran-complex)-r ]
[ [ imaginary-part ] dip set-(fortran-complex)-i ]
[ ] tri ;
: <double-complex> ( complex -- byte-array ) M: integer-type (fortran-arg>c-args)
"(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>> { size>> {
{ f [ [ <int> ] [ drop ] ] } { f [ [ <int> ] [ drop ] ] }
{ 1 [ [ <char> ] [ drop ] ] } { 1 [ [ <char> ] [ drop ] ] }
@ -166,7 +159,10 @@ M: integer-type [fortran-arg>c-args]
[ invalid-fortran-type ] [ invalid-fortran-type ]
} case ; } 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>> { size>> {
{ f [ [ <float> ] [ drop ] ] } { f [ [ <float> ] [ drop ] ] }
{ 4 [ [ <float> ] [ drop ] ] } { 4 [ [ <float> ] [ drop ] ] }
@ -174,23 +170,92 @@ M: real-type [fortran-arg>c-args]
[ invalid-fortran-type ] [ invalid-fortran-type ]
} case ; } case ;
M: real-complex-type [fortran-arg>c-args] M: real-complex-type (fortran-arg>c-args)
size>> { size>> {
{ f [ [ <real-complex> ] [ drop ] ] } { f [ [ <complex-float> ] [ drop ] ] }
{ 8 [ [ <real-complex> ] [ drop ] ] } { 8 [ [ <complex-float> ] [ drop ] ] }
{ 16 [ [ <double-complex> ] [ drop ] ] } { 16 [ [ <complex-double> ] [ drop ] ] }
[ invalid-fortran-type ] [ invalid-fortran-type ]
} case ; } 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>> { size>> {
{ f [ [ <real-complex> ] [ drop ] ] } { f [ [ *int ] ] }
{ 8 [ [ <real-complex> ] [ drop ] ] } { 1 [ [ *char ] ] }
{ 16 [ [ <double-complex> ] [ drop ] ] } { 2 [ [ *short ] ] }
{ 4 [ [ *int ] ] }
{ 8 [ [ *longlong ] ] }
[ invalid-fortran-type ] [ invalid-fortran-type ]
} case ; } 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> PRIVATE>
@ -219,17 +284,28 @@ PRIVATE>
: fortran-record>c-struct ( record -- struct ) : fortran-record>c-struct ( record -- struct )
[ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; [ 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 ; [ >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 -- ) :: 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: : SUBROUTINE:
f "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing
! : F-SUBROUTINE: ... ; parsing : FUNCTION:
! : F-FUNCTION: ... ; parsing scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing