fortran records
parent
4429c17f63
commit
7b1f16ae5e
|
@ -1,15 +1,11 @@
|
|||
USING: alien.fortran alien.syntax tools.test ;
|
||||
USING: accessors alien alien.c-types alien.fortran alien.structs
|
||||
alien.syntax arrays assocs kernel namespaces sequences tools.test ;
|
||||
IN: alien.fortran.tests
|
||||
|
||||
C-STRUCT: fortran_test_struct
|
||||
{ "int" "foo" }
|
||||
{ "float" "bar" }
|
||||
{ "char[4]" "bas" } ;
|
||||
|
||||
! F-RECORD: fortran_test_record
|
||||
! { "integer" "foo" }
|
||||
! { "real" "bar" }
|
||||
! { "character*4" "bar" }
|
||||
F-RECORD: fortran_test_record
|
||||
{ "integer" "foo" }
|
||||
{ "real" "bar" }
|
||||
{ "character*4" "bas" } ;
|
||||
|
||||
! fortran-name>symbol-name
|
||||
|
||||
|
@ -25,7 +21,7 @@ C-STRUCT: fortran_test_struct
|
|||
[ "integer*4" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int" ]
|
||||
[ "integer" fortran-type>c-type ] unit-test
|
||||
[ "INTEGER" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "longlong" ]
|
||||
[ "iNteger*8" fortran-type>c-type ] unit-test
|
||||
|
@ -84,9 +80,6 @@ C-STRUCT: fortran_test_struct
|
|||
[ "(fortran-double-complex)" ]
|
||||
[ "complex*16" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "fortran_test_struct" ]
|
||||
[ "fortran_test_struct" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "fortran_test_record" ]
|
||||
[ "fortran_test_record" fortran-type>c-type ] unit-test
|
||||
|
||||
|
@ -101,8 +94,8 @@ C-STRUCT: fortran_test_struct
|
|||
[ "int*" { } ]
|
||||
[ "integer(*)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "fortran_test_struct*" { } ]
|
||||
[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test
|
||||
[ "fortran_test_record*" { } ]
|
||||
[ "fortran_test_record" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { "long" } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
@ -139,3 +132,40 @@ C-STRUCT: fortran_test_struct
|
|||
[ "void" { "fortran_test_record*" } ]
|
||||
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
! fortran-sig>c-sig
|
||||
|
||||
[ "double" { "int*" "char*" "float*" "double*" "long" } ]
|
||||
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ]
|
||||
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ]
|
||||
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
! fortran-record>c-struct
|
||||
|
||||
[ {
|
||||
{ "double" "ex" }
|
||||
{ "float" "wye" }
|
||||
{ "int" "zee" }
|
||||
{ "char[20]" "woo" }
|
||||
} ] [
|
||||
{
|
||||
{ "DOUBLE PRECISION" "EX" }
|
||||
{ "REAL" "WYE" }
|
||||
{ "INTEGER" "ZEE" }
|
||||
{ "CHARACTER(20)" "WOO" }
|
||||
} fortran-record>c-struct
|
||||
] unit-test
|
||||
|
||||
! F-RECORD:
|
||||
|
||||
[ 12 ] [ "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
|
||||
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
USING: accessors alien alien.c-types alien.syntax arrays ascii
|
||||
assocs combinators fry kernel macros math.parser sequences splitting ;
|
||||
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 ;
|
||||
IN: alien.fortran
|
||||
|
||||
! XXX this currently only supports the gfortran/f2c abi.
|
||||
|
@ -65,9 +66,12 @@ MACRO: size-case-type ( cases -- )
|
|||
|
||||
GENERIC: (fortran-type>c-type) ( type -- c-type )
|
||||
|
||||
M: f (fortran-type>c-type) ;
|
||||
|
||||
M: integer-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "int" ] }
|
||||
{ 1 [ "char" ] }
|
||||
{ 2 [ "short" ] }
|
||||
{ 4 [ "int" ] }
|
||||
{ 8 [ "longlong" ] }
|
||||
|
@ -140,6 +144,9 @@ GENERIC: (fortran-ret-type>c-type) ( 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" ;
|
||||
|
||||
: suffix! ( seq elt -- seq ) over push ; inline
|
||||
: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fortran-type>c-type ( fortran-type -- c-type )
|
||||
|
@ -156,10 +163,21 @@ PRIVATE>
|
|||
[ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix
|
||||
] if ;
|
||||
|
||||
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ;
|
||||
: fortran-arg-types>c-types ( fortran-types -- c-types )
|
||||
[ length <vector> 1 <vector> ] keep
|
||||
[ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
|
||||
append >array ;
|
||||
|
||||
! : F-RECORD: ... ; parsing
|
||||
! : F-ABI: ... ; parsing
|
||||
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
|
||||
[ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
|
||||
|
||||
: fortran-record>c-struct ( record -- struct )
|
||||
[ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
|
||||
|
||||
: define-record ( name vocab fields -- )
|
||||
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
|
||||
|
||||
: F-RECORD: scan in get parse-definition define-record ; parsing
|
||||
! : F-SUBROUTINE: ... ; parsing
|
||||
! : F-FUNCTION: ... ; parsing
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic hashtables kernel kernel.private
|
||||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc fry
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order ;
|
||||
IN: alien.structs
|
||||
|
@ -61,3 +61,8 @@ M: struct-type stack-size
|
|||
[ expand-constants ] map
|
||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||
compute-struct-align f (define-struct) ;
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
[ name>> = ] with find nip offset>> ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue