From 118f2de4667d47a79563b7a3d9c07308781c14b5 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 6 Feb 2009 19:05:56 -0600
Subject: [PATCH] fortran-invoke sketch
---
basis/alien/complex/complex-tests.factor | 2 +-
basis/alien/complex/functor/functor.factor | 14 +-
basis/alien/fortran/fortran-tests.factor | 170 ++++++++++++++------
basis/alien/fortran/fortran.factor | 178 +++++++++++++++------
4 files changed, 260 insertions(+), 104 deletions(-)
diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor
index bfb2c1137c..0bff73b898 100644
--- a/basis/alien/complex/complex-tests.factor
+++ b/basis/alien/complex/complex-tests.factor
@@ -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
\ No newline at end of file
+[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
index 1d12bb0ff4..c6644eba1d 100644
--- a/basis/alien/complex/functor/functor.factor
+++ b/basis/alien/complex/functor/functor.factor
@@ -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
\ No newline at end of file
+;FUNCTOR
diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor
index a1f2443b30..0a86cba7e3 100644
--- a/basis/alien/fortran/fortran-tests.factor
+++ b/basis/alien/fortran/fortran-tests.factor
@@ -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
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index faec9b5b86..b0bbedd716 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -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