diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 24221160ce..4ff599e0d1 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -78,6 +78,9 @@ M: string resolve-pointer-type [ resolve-pointer-type ] [ drop void* ] if ] if ; +M: array resolve-pointer-type + first resolve-pointer-type ; + : resolve-typedef ( name -- c-type ) dup void? [ no-c-type ] when dup c-type-name? [ c-type ] when ; diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 238207f192..a4099a9cc4 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -4,11 +4,12 @@ alien.data alien.fortran alien.fortran.private alien.strings classes.struct arrays assocs byte-arrays combinators fry generalizations io.encodings.ascii kernel macros macros.expander namespaces sequences shuffle tools.test ; +QUALIFIED-WITH: alien.c-types c IN: alien.fortran.tests << intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> LIBRARY: (alien.fortran-tests) -STRUCT: FORTRAN_TEST_RECORD +STRUCT: fortran_test_record { FOO int } { BAR double[2] } { BAS char[4] } ; @@ -23,148 +24,148 @@ intel-unix-abi fortran-abi [ ! fortran-type>c-type - [ "short" ] + [ c:short ] [ "integer*2" fortran-type>c-type ] unit-test - [ "int" ] + [ c:int ] [ "integer*4" fortran-type>c-type ] unit-test - [ "int" ] + [ c:int ] [ "INTEGER" fortran-type>c-type ] unit-test - [ "longlong" ] + [ c:longlong ] [ "iNteger*8" fortran-type>c-type ] unit-test - [ "int[0]" ] + [ { c:int 0 } ] [ "integer(*)" fortran-type>c-type ] unit-test - [ "int[0]" ] + [ { c:int 0 } ] [ "integer(3,*)" fortran-type>c-type ] unit-test - [ "int[3]" ] + [ { c:int 3 } ] [ "integer(3)" fortran-type>c-type ] unit-test - [ "int[6]" ] + [ { c:int 6 } ] [ "integer(3,2)" fortran-type>c-type ] unit-test - [ "int[24]" ] + [ { c:int 24 } ] [ "integer(4,3,2)" fortran-type>c-type ] unit-test - [ "char" ] + [ c:char ] [ "character" fortran-type>c-type ] unit-test - [ "char" ] + [ c:char ] [ "character*1" fortran-type>c-type ] unit-test - [ "char[17]" ] + [ { c:char 17 } ] [ "character*17" fortran-type>c-type ] unit-test - [ "char[17]" ] + [ { c:char 17 } ] [ "character(17)" fortran-type>c-type ] unit-test - [ "int" ] + [ c:int ] [ "logical" fortran-type>c-type ] unit-test - [ "float" ] + [ c:float ] [ "real" fortran-type>c-type ] unit-test - [ "double" ] + [ c:double ] [ "double-precision" fortran-type>c-type ] unit-test - [ "float" ] + [ c:float ] [ "real*4" fortran-type>c-type ] unit-test - [ "double" ] + [ c:double ] [ "real*8" fortran-type>c-type ] unit-test - [ "complex-float" ] + [ complex-float ] [ "complex" fortran-type>c-type ] unit-test - [ "complex-double" ] + [ complex-double ] [ "double-complex" fortran-type>c-type ] unit-test - [ "complex-float" ] + [ complex-float ] [ "complex*8" fortran-type>c-type ] unit-test - [ "complex-double" ] + [ complex-double ] [ "complex*16" fortran-type>c-type ] unit-test - [ "fortran_test_record" ] + [ fortran_test_record ] [ "fortran_test_record" fortran-type>c-type ] unit-test ! fortran-arg-type>c-type - [ "int*" { } ] + [ c:void* { } ] [ "integer" fortran-arg-type>c-type ] unit-test - [ "int*" { } ] + [ c:void* { } ] [ "integer(3)" fortran-arg-type>c-type ] unit-test - [ "int*" { } ] + [ c:void* { } ] [ "integer(*)" fortran-arg-type>c-type ] unit-test - [ "fortran_test_record*" { } ] + [ c:void* { } ] [ "fortran_test_record" fortran-arg-type>c-type ] unit-test - [ "char*" { } ] + [ c:char* { } ] [ "character" fortran-arg-type>c-type ] unit-test - [ "char*" { } ] + [ c:char* { } ] [ "character(1)" fortran-arg-type>c-type ] unit-test - [ "char*" { "long" } ] + [ c:char* { long } ] [ "character(17)" fortran-arg-type>c-type ] unit-test ! fortran-ret-type>c-type - [ "char" { } ] + [ c:char { } ] [ "character(1)" fortran-ret-type>c-type ] unit-test - [ "void" { "char*" "long" } ] + [ c:void { c:char* long } ] [ "character(17)" fortran-ret-type>c-type ] unit-test - [ "int" { } ] + [ c:int { } ] [ "integer" fortran-ret-type>c-type ] unit-test - [ "int" { } ] + [ c:int { } ] [ "logical" fortran-ret-type>c-type ] unit-test - [ "float" { } ] + [ c:float { } ] [ "real" fortran-ret-type>c-type ] unit-test - [ "void" { "float*" } ] + [ c:void { c:void* } ] [ "real(*)" fortran-ret-type>c-type ] unit-test - [ "double" { } ] + [ c:double { } ] [ "double-precision" fortran-ret-type>c-type ] unit-test - [ "void" { "complex-float*" } ] + [ c:void { c:void* } ] [ "complex" fortran-ret-type>c-type ] unit-test - [ "void" { "complex-double*" } ] + [ c:void { c:void* } ] [ "double-complex" fortran-ret-type>c-type ] unit-test - [ "void" { "int*" } ] + [ c:void { c:void* } ] [ "integer(*)" fortran-ret-type>c-type ] unit-test - [ "void" { "fortran_test_record*" } ] + [ c:void { c:void* } ] [ "fortran_test_record" fortran-ret-type>c-type ] unit-test ! fortran-sig>c-sig - [ "float" { "int*" "char*" "float*" "double*" "long" } ] + [ c:float { c:void* c:char* c:void* c:void* c:long } ] [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] unit-test - [ "char" { "char*" "char*" "int*" "long" } ] + [ c:char { c:char* c:char* c:void* c:long } ] [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test - [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ] + [ c:void { c:char* c:long c:char* c:char* c:void* c:long } ] [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test - [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ] + [ c:void { c:void* c:char* c:char* c:void* c:long } ] [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test @@ -184,8 +185,8 @@ intel-unix-abi fortran-abi [ } 5 ncleave ! [fortran-invoke] [ - "void" "funpack" "funtimes_" - { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } + c:void "funpack" "funtimes_" + { c:char* c:void* c:void* c:void* c:void* c:long } alien-invoke ] 6 nkeep ! [fortran-results>] @@ -210,7 +211,7 @@ intel-unix-abi fortran-abi [ [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] - [ "float" "funpack" "fun_times_" { "float*" } alien-invoke ] + [ c:float "funpack" "fun_times_" { void* } alien-invoke ] 1 nkeep ! [fortran-results>] shuffle( reta aa -- reta aa ) @@ -222,13 +223,13 @@ intel-unix-abi fortran-abi [ [ [ ! [] - [ "complex-float" ] 1 ndip + [ complex-float ] 1 ndip ! [fortran-args>c-args] { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] [ - "void" "funpack" "fun_times_" - { "complex-float*" "float*" } + c:void "funpack" "fun_times_" + { void* void* } alien-invoke ] 2 nkeep ! [fortran-results>] @@ -244,8 +245,8 @@ intel-unix-abi fortran-abi [ [ 20 20 ] 0 ndip ! [fortran-invoke] [ - "void" "funpack" "fun_times_" - { "char*" "long" } + c:void "funpack" "fun_times_" + { c:char* long } alien-invoke ] 2 nkeep ! [fortran-results>] @@ -270,8 +271,8 @@ intel-unix-abi fortran-abi [ } 3 ncleave ! [fortran-invoke] [ - "void" "funpack" "fun_times_" - { "char*" "long" "char*" "float*" "char*" "long" "long" } + c:void "funpack" "fun_times_" + { c:char* long c:char* c:void* c:char* c:long c:long } alien-invoke ] 7 nkeep ! [fortran-results>] @@ -302,19 +303,19 @@ intel-windows-abi fortran-abi [ f2c-abi fortran-abi [ - [ "char[1]" ] + [ { c:char 1 } ] [ "character(1)" fortran-type>c-type ] unit-test - [ "char*" { "long" } ] + [ c:char* { c:long } ] [ "character" fortran-arg-type>c-type ] unit-test - [ "void" { "char*" "long" } ] + [ c:void { c:char* c:long } ] [ "character" fortran-ret-type>c-type ] unit-test - [ "double" { } ] + [ c:double { } ] [ "real" fortran-ret-type>c-type ] unit-test - [ "void" { "float*" } ] + [ c:void { void* } ] [ "real(*)" fortran-ret-type>c-type ] unit-test [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test @@ -325,34 +326,34 @@ f2c-abi fortran-abi [ gfortran-abi fortran-abi [ - [ "float" { } ] + [ c:float { } ] [ "real" fortran-ret-type>c-type ] unit-test - [ "void" { "float*" } ] + [ c:void { void* } ] [ "real(*)" fortran-ret-type>c-type ] unit-test - [ "complex-float" { } ] + [ complex-float { } ] [ "complex" fortran-ret-type>c-type ] unit-test - [ "complex-double" { } ] + [ complex-double { } ] [ "double-complex" fortran-ret-type>c-type ] unit-test - [ "char[1]" ] + [ { char 1 } ] [ "character(1)" fortran-type>c-type ] unit-test - [ "char*" { "long" } ] + [ c:char* { c:long } ] [ "character" fortran-arg-type>c-type ] unit-test - [ "void" { "char*" "long" } ] + [ c:void { c:char* c:long } ] [ "character" fortran-ret-type>c-type ] unit-test - [ "complex-float" { } ] + [ complex-float { } ] [ "complex" fortran-ret-type>c-type ] unit-test - [ "complex-double" { } ] + [ complex-double { } ] [ "double-complex" fortran-ret-type>c-type ] unit-test - [ "void" { "complex-double*" } ] + [ c:void { c:void* } ] [ "double-complex(3)" fortran-ret-type>c-type ] unit-test ] with-variable diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index d7659d8400..65e927f85a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,11 +1,12 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.complex alien.data grouping -alien.strings alien.syntax arrays ascii assocs +USING: accessors alien alien.c-types alien.complex alien.data alien.parser +grouping alien.strings alien.syntax arrays ascii assocs byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals io.encodings.ascii io.encodings.string shuffle effects math.ranges math.order sorting strings system alien.libraries ; +QUALIFIED-WITH: alien.c-types c IN: alien.fortran SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ; @@ -101,8 +102,7 @@ CONSTANT: fortran>c-types H{ } : append-dimensions ( base-c-type type -- c-type ) - dims>> - [ product number>string "[" "]" surround append ] when* ; + dims>> [ product 2array ] when* ; MACRO: size-case-type ( cases -- ) [ invalid-fortran-type ] suffix @@ -118,35 +118,35 @@ MACRO: size-case-type ( cases -- ) GENERIC: (fortran-type>c-type) ( type -- c-type ) -M: f (fortran-type>c-type) drop "void" ; +M: f (fortran-type>c-type) drop c:void ; M: integer-type (fortran-type>c-type) { - { f [ "int" ] } - { 1 [ "char" ] } - { 2 [ "short" ] } - { 4 [ "int" ] } - { 8 [ "longlong" ] } + { f [ c:int ] } + { 1 [ c:char ] } + { 2 [ c:short ] } + { 4 [ c:int ] } + { 8 [ c:longlong ] } } size-case-type ; M: real-type (fortran-type>c-type) { - { f [ "float" ] } - { 4 [ "float" ] } - { 8 [ "double" ] } + { f [ c:float ] } + { 4 [ c:float ] } + { 8 [ c:double ] } } size-case-type ; M: real-complex-type (fortran-type>c-type) { - { f [ "complex-float" ] } - { 8 [ "complex-float" ] } - { 16 [ "complex-double" ] } + { f [ complex-float ] } + { 8 [ complex-float ] } + { 16 [ complex-double ] } } size-case-type ; M: double-precision-type (fortran-type>c-type) - "double" simple-type ; + c:double simple-type ; M: double-complex-type (fortran-type>c-type) - "complex-double" simple-type ; + complex-double simple-type ; M: misc-type (fortran-type>c-type) - dup name>> simple-type ; + dup name>> parse-c-type simple-type ; : single-char? ( character-type -- ? ) { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ; @@ -158,7 +158,7 @@ M: misc-type (fortran-type>c-type) dup single-char? [ f >>dims ] when ; M: character-type (fortran-type>c-type) - fix-character-type "char" simple-type ; + fix-character-type c:char simple-type ; : dimension>number ( string -- number ) dup "*" = [ drop 0 ] [ string>number ] if ; @@ -181,13 +181,10 @@ M: character-type (fortran-type>c-type) : parse-fortran-type ( fortran-type-string/f -- type/f ) dup [ (parse-fortran-type) ] when ; -: c-type>pointer ( c-type -- c-type* ) - "[" split1 drop "*" append ; - GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; -M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ; +M: character-type added-c-args fix-character-type single-char? [ { } ] [ { c:long } ] if ; GENERIC: returns-by-value? ( type -- ? ) @@ -200,10 +197,10 @@ M: complex-type returns-by-value? GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) -M: f (fortran-ret-type>c-type) drop "void" ; +M: f (fortran-ret-type>c-type) drop c:void ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) - drop real-functions-return-double? [ "double" ] [ "float" ] if ; + drop real-functions-return-double? [ c:double ] [ c:float ] if ; GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) @@ -354,7 +351,7 @@ M: character-type () : (shuffle-map) ( return parameters -- ret par ) [ - fortran-ret-type>c-type length swap "void" = [ 1 + ] unless + fortran-ret-type>c-type length swap void? [ 1 + ] unless letters swap head [ "ret" swap suffix ] map ] [ [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip @@ -395,13 +392,13 @@ PRIVATE> : fortran-arg-type>c-type ( fortran-type -- c-type added-args ) parse-fortran-type - [ (fortran-type>c-type) c-type>pointer ] + [ (fortran-type>c-type) resolve-pointer-type ] [ added-c-args ] bi ; : fortran-ret-type>c-type ( fortran-type -- c-type added-args ) parse-fortran-type dup returns-by-value? [ (fortran-ret-type>c-type) { } ] [ - "void" swap - [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix + c:void swap + [ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix ] if ; : fortran-arg-types>c-types ( fortran-types -- c-types ) @@ -433,7 +430,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic - return library function parameters return [ "void" ] unless* parse-arglist + return library function parameters return [ c:void ] unless* parse-arglist [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; SYNTAX: SUBROUTINE: