From 7b1f16ae5ed2ee0b788456db20a84eb7922f14d2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 18:51:50 -0600 Subject: [PATCH] fortran records --- basis/alien/fortran/fortran-tests.factor | 62 ++++++++++++++++++------ basis/alien/fortran/fortran.factor | 28 +++++++++-- basis/alien/structs/structs.factor | 7 ++- 3 files changed, 75 insertions(+), 22 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 29bd024930..11f0a2efc7 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -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 + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 0c30258895..327db12909 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -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 1 ] 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 diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 42923fb28b..cb3f90d358 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -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>> ; +