fortran records

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
+

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 <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
 

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>> ;
+