fortran-invoke sketch
Joe Groff
parent
6ff37d2951
commit
118f2de466
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue