basis/alien/fortran/fortran.factor

   1 ! (c) 2009 Joe Groff, see BSD license
   2 USING: accessors alien alien.c-types alien.complex alien.parser
   3 alien.strings alien.structs alien.syntax arrays ascii assocs
   4 byte-arrays combinators combinators.short-circuit fry generalizations
   5 kernel lexer macros math math.parser namespaces parser sequences
   6 splitting stack-checker vectors vocabs.parser words locals
   7 io.encodings.ascii io.encodings.string shuffle effects math.ranges
   8 math.order sorting strings system alien.libraries ;
   9 IN: alien.fortran
  10
  11 SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
  12
  13 <<
  14 : add-f2c-libraries ( -- )
  15     "I77" "libI77.so" "cdecl" add-library
  16     "F77" "libF77.so" "cdecl" add-library ;
  17
  18 os netbsd? [ add-f2c-libraries ] when
  19 >>
  20
  21 : alien>nstring ( alien len encoding -- string )
  22     [ memory>byte-array ] dip decode ;
  23
  24 ERROR: invalid-fortran-type type ;
  25
  26 DEFER: fortran-sig>c-sig
  27 DEFER: fortran-ret-type>c-type
  28 DEFER: fortran-arg-type>c-type
  29 DEFER: fortran-name>symbol-name
  30
  31 SYMBOL: library-fortran-abis
  32 SYMBOL: fortran-abi
  33 library-fortran-abis [ H{ } clone ] initialize
  34
  35 <PRIVATE
  36
  37 : lowercase-name-with-underscore ( name -- name' )
  38     >lower "_" append ;
  39 : lowercase-name-with-extra-underscore ( name -- name' )
  40     >lower CHAR: _ over member?
  41     [ "__" append ] [ "_" append ] if ;
  42
  43 HOOK: fortran-c-abi fortran-abi ( -- abi )
  44 M: f2c-abi fortran-c-abi "cdecl" ;
  45 M: g95-abi fortran-c-abi "cdecl" ;
  46 M: gfortran-abi fortran-c-abi "cdecl" ;
  47 M: intel-unix-abi fortran-c-abi "cdecl" ;
  48 M: intel-windows-abi fortran-c-abi "cdecl" ;
  49
  50 HOOK: real-functions-return-double? fortran-abi ( -- ? )
  51 M: f2c-abi real-functions-return-double? t ;
  52 M: g95-abi real-functions-return-double? f ;
  53 M: gfortran-abi real-functions-return-double? f ;
  54 M: intel-unix-abi real-functions-return-double? f ;
  55 M: intel-windows-abi real-functions-return-double? f ;
  56
  57 HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
  58 M: f2c-abi complex-functions-return-by-value? f ;
  59 M: g95-abi complex-functions-return-by-value? f ;
  60 M: gfortran-abi complex-functions-return-by-value? t ;
  61 M: intel-unix-abi complex-functions-return-by-value? f ;
  62 M: intel-windows-abi complex-functions-return-by-value? f ;
  63
  64 HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
  65 M: f2c-abi character(1)-maps-to-char? f ;
  66 M: g95-abi character(1)-maps-to-char? f ;
  67 M: gfortran-abi character(1)-maps-to-char? f ;
  68 M: intel-unix-abi character(1)-maps-to-char? t ;
  69 M: intel-windows-abi character(1)-maps-to-char? t ;
  70
  71 HOOK: mangle-name fortran-abi ( name -- name' )
  72 M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
  73 M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
  74 M: gfortran-abi mangle-name lowercase-name-with-underscore ;
  75 M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
  76 M: intel-windows-abi mangle-name >upper ;
  77
  78 TUPLE: fortran-type dims size out? ;
  79
  80 TUPLE: number-type < fortran-type ;
  81 TUPLE: integer-type < number-type ;
  82 TUPLE: logical-type < integer-type ;
  83 TUPLE: real-type < number-type ;
  84 TUPLE: double-precision-type < number-type ;
  85
  86 TUPLE: character-type < fortran-type ;
  87 TUPLE: misc-type < fortran-type name ;
  88
  89 TUPLE: complex-type < number-type ;
  90 TUPLE: real-complex-type < complex-type ;
  91 TUPLE: double-complex-type < complex-type ;
  92
  93 CONSTANT: fortran>c-types H{
  94     { "character"        character-type        }
  95     { "integer"          integer-type          }
  96     { "logical"          logical-type          }
  97     { "real"             real-type             }
  98     { "double-precision" double-precision-type }
  99     { "complex"          real-complex-type     }
 100     { "double-complex"   double-complex-type   }
 101 }
 102
 103 : append-dimensions ( base-c-type type -- c-type )
 104     dims>>
 105     [ product number>string "[" "]" surround append ] when* ;
 106
 107 MACRO: size-case-type ( cases -- )
 108     [ invalid-fortran-type ] suffix
 109     '[ [ size>> _ case ] [ append-dimensions ] bi ] ;
 110
 111 : simple-type ( type base-c-type -- c-type )
 112     swap
 113     [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
 114     [ append-dimensions ] bi ;
 115
 116 : new-fortran-type ( out? dims size class -- type )
 117     new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
 118
 119 GENERIC: (fortran-type>c-type) ( type -- c-type )
 120
 121 M: f (fortran-type>c-type) drop "void" ;
 122
 123 M: integer-type (fortran-type>c-type)
 124     {
 125         { f [ "int"      ] }
 126         { 1 [ "char"     ] }
 127         { 2 [ "short"    ] }
 128         { 4 [ "int"      ] }
 129         { 8 [ "longlong" ] }
 130     } size-case-type ;
 131 M: real-type (fortran-type>c-type)
 132     {
 133         { f [ "float"  ] }
 134         { 4 [ "float"  ] }
 135         { 8 [ "double" ] }
 136     } size-case-type ;
 137 M: real-complex-type (fortran-type>c-type)
 138     {
 139         {  f [ "complex-float"  ] }
 140         {  8 [ "complex-float"  ] }
 141         { 16 [ "complex-double" ] }
 142     } size-case-type ;
 143
 144 M: double-precision-type (fortran-type>c-type)
 145     "double" simple-type ;
 146 M: double-complex-type (fortran-type>c-type)
 147     "complex-double" simple-type ;
 148 M: misc-type (fortran-type>c-type)
 149     dup name>> simple-type ;
 150
 151 : single-char? ( character-type -- ? )
 152     { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
 153
 154 : fix-character-type ( character-type -- character-type' )
 155     clone dup size>>
 156     [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
 157     [ dup dims>> [ ] [ f >>dims ] if ] if
 158     dup single-char? [ f >>dims ] when ;
 159
 160 M: character-type (fortran-type>c-type)
 161     fix-character-type "char" simple-type ;
 162
 163 : dimension>number ( string -- number )
 164     dup "*" = [ drop 0 ] [ string>number ] if ;
 165
 166 : parse-out ( string -- string' out? )
 167     "!" ?head ;
 168
 169 : parse-dims ( string -- string' dim )
 170     "(" split1 dup
 171     [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
 172
 173 : parse-size ( string -- string' size )
 174     "*" split1 dup [ string>number ] when ;
 175
 176 : (parse-fortran-type) ( fortran-type-string -- type )
 177     parse-out swap parse-dims swap parse-size swap
 178     >lower fortran>c-types ?at
 179     [ new-fortran-type ] [ misc-type boa ] if ;
 180
 181 : parse-fortran-type ( fortran-type-string/f -- type/f )
 182     dup [ (parse-fortran-type) ] when ;
 183
 184 : c-type>pointer ( c-type -- c-type* )
 185     "[" split1 drop "*" append ;
 186
 187 GENERIC: added-c-args ( type -- args )
 188
 189 M: fortran-type added-c-args drop { } ;
 190 M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;
 191
 192 GENERIC: returns-by-value? ( type -- ? )
 193
 194 M: f returns-by-value? drop t ;
 195 M: fortran-type returns-by-value? drop f ;
 196 M: number-type returns-by-value? dims>> not ;
 197 M: character-type returns-by-value? fix-character-type single-char? ;
 198 M: complex-type returns-by-value?
 199     { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
 200
 201 GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
 202
 203 M: f (fortran-ret-type>c-type) drop "void" ;
 204 M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
 205 M: real-type (fortran-ret-type>c-type)
 206     drop real-functions-return-double? [ "double" ] [ "float" ] if ;
 207
 208 : suffix! ( seq   elt   -- seq   ) over push     ; inline
 209 : append! ( seq-a seq-b -- seq-a ) over push-all ; inline
 210
 211 GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
 212
 213 : args?dims ( type quot -- main-quot added-quot )
 214     [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
 215
 216 M: integer-type (fortran-arg>c-args)
 217     [
 218         size>> {
 219             { f [ [ <int>      ] [ drop ] ] }
 220             { 1 [ [ <char>     ] [ drop ] ] }
 221             { 2 [ [ <short>    ] [ drop ] ] }
 222             { 4 [ [ <int>      ] [ drop ] ] }
 223             { 8 [ [ <longlong> ] [ drop ] ] }
 224             [ invalid-fortran-type ]
 225         } case
 226     ] args?dims ;
 227
 228 M: logical-type (fortran-arg>c-args)
 229     [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
 230
 231 M: real-type (fortran-arg>c-args)
 232     [
 233         size>> {
 234             { f [ [ <float>  ] [ drop ] ] }
 235             { 4 [ [ <float>  ] [ drop ] ] }
 236             { 8 [ [ <double> ] [ drop ] ] }
 237             [ invalid-fortran-type ]
 238         } case
 239     ] args?dims ;
 240
 241 M: real-complex-type (fortran-arg>c-args)
 242     [
 243         size>> {
 244             {  f [ [ <complex-float>  ] [ drop ] ] }
 245             {  8 [ [ <complex-float>  ] [ drop ] ] }
 246             { 16 [ [ <complex-double> ] [ drop ] ] }
 247             [ invalid-fortran-type ]
 248         } case
 249     ] args?dims ;
 250
 251 M: double-precision-type (fortran-arg>c-args)
 252     [ drop [ <double> ] [ drop ] ] args?dims ;
 253
 254 M: double-complex-type (fortran-arg>c-args)
 255     [ drop [ <complex-double> ] [ drop ] ] args?dims ;
 256
 257 M: character-type (fortran-arg>c-args)
 258     fix-character-type single-char?
 259     [ [ first <char> ] [ drop ] ]
 260     [ [ ascii string>alien ] [ length ] ] if ;
 261
 262 M: misc-type (fortran-arg>c-args)
 263     drop [ ] [ drop ] ;
 264
 265 GENERIC: (fortran-result>) ( type -- quots )
 266
 267 : result?dims ( type quot -- quot )
 268     [ dup dims>> [ drop { [ ] } ] ] dip if ; inline
 269
 270 M: integer-type (fortran-result>)
 271     [ size>> {
 272         { f [ { [ *int      ] } ] }
 273         { 1 [ { [ *char     ] } ] }
 274         { 2 [ { [ *short    ] } ] }
 275         { 4 [ { [ *int      ] } ] }
 276         { 8 [ { [ *longlong ] } ] }
 277         [ invalid-fortran-type ]
 278     } case ] result?dims ;
 279
 280 M: logical-type (fortran-result>)
 281     [ call-next-method first [ zero? not ] append 1array ] result?dims ;
 282
 283 M: real-type (fortran-result>)
 284     [ size>> {
 285         { f [ { [ *float  ] } ] }
 286         { 4 [ { [ *float  ] } ] }
 287         { 8 [ { [ *double ] } ] }
 288         [ invalid-fortran-type ]
 289     } case ] result?dims ;
 290
 291 M: real-complex-type (fortran-result>)
 292     [ size>> {
 293         {  f [ { [ *complex-float  ] } ] }
 294         {  8 [ { [ *complex-float  ] } ] }
 295         { 16 [ { [ *complex-double ] } ] }
 296         [ invalid-fortran-type ]
 297     } case ] result?dims ;
 298
 299 M: double-precision-type (fortran-result>)
 300     [ drop { [ *double ] } ] result?dims ;
 301
 302 M: double-complex-type (fortran-result>)
 303     [ drop { [ *complex-double ] } ] result?dims ;
 304
 305 M: character-type (fortran-result>)
 306     fix-character-type single-char?
 307     [ { [ *char 1string ] } ]
 308     [ { [ ] [ ascii alien>nstring ] } ] if ;
 309
 310 M: misc-type (fortran-result>)
 311     drop { [ ] } ;
 312
 313 GENERIC: (<fortran-result>) ( type -- quot )
 314
 315 M: fortran-type (<fortran-result>)
 316     (fortran-type>c-type) \ <c-object> [ ] 2sequence ;
 317
 318 M: character-type (<fortran-result>)
 319     fix-character-type dims>> product dup
 320     [ \ <byte-array> ] dip [ ] 3sequence ;
 321
 322 : [<fortran-result>] ( return parameters -- quot )
 323     [ parse-fortran-type ] dip
 324     over returns-by-value?
 325     [ 2drop [ ] ]
 326     [ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
 327
 328 : [fortran-args>c-args] ( parameters -- quot )
 329     [ [ ] ] [
 330         [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
 331         [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
 332         \ ncleave [ ] 3sequence
 333     ] if-empty ;
 334
 335 :: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
 336     return parameters fortran-sig>c-sig :> c-parameters :> c-return
 337     function fortran-name>symbol-name :> c-function
 338     [args>args]
 339     c-return library c-function c-parameters \ alien-invoke
 340     5 [ ] nsequence
 341     c-parameters length \ nkeep
 342     [ ] 3sequence ;
 343
 344 : [fortran-out-param>] ( parameter -- quot )
 345     parse-fortran-type
 346     [ (fortran-result>) ] [ out?>> ] bi
 347     [ ] [ [ drop [ drop ] ] map ] if ;
 348
 349 : [fortran-return>] ( return -- quot )
 350     parse-fortran-type {
 351         { [ dup not ] [ drop { } ] }
 352         { [ dup returns-by-value? ] [ drop { [ ] } ] }
 353         [ (fortran-result>) ]
 354     } cond ;
 355
 356 : letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
 357
 358 : (shuffle-map) ( return parameters -- ret par )
 359     [
 360         fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
 361         letters swap head [ "ret" swap suffix ] map
 362     ] [
 363         [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
 364         [ first2 letters swap head [ "" 2sequence ] with map ] map concat
 365     ] bi* ;
 366
 367 : (fortran-in-shuffle) ( ret par -- seq )
 368     [ second ] sort-with append ;
 369
 370 : (fortran-out-shuffle) ( ret par -- seq )
 371     append ;
 372
 373 : [fortran-result-shuffle] ( return parameters -- quot )
 374     (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
 375     \ shuffle-effect [ ] 2sequence ;
 376
 377 : [fortran-results>] ( return parameters -- quot )
 378     [ [fortran-result-shuffle] ]
 379     [ drop [fortran-return>] ]
 380     [ nip [ [fortran-out-param>] ] map concat ] 2tri
 381     append
 382     \ spread [ ] 2sequence append ;
 383
 384 : (add-fortran-library) ( fortran-abi name -- )
 385     library-fortran-abis get-global set-at ;
 386
 387 PRIVATE>
 388
 389 : add-fortran-library ( name soname fortran-abi -- )
 390     [ fortran-abi [ fortran-c-abi ] with-variable add-library ]
 391     [ nip swap (add-fortran-library) ] 3bi ;
 392
 393 : fortran-name>symbol-name ( fortran-name -- c-name )
 394     mangle-name ;
 395
 396 : fortran-type>c-type ( fortran-type -- c-type )
 397     parse-fortran-type (fortran-type>c-type) ;
 398
 399 : fortran-arg-type>c-type ( fortran-type -- c-type added-args )
 400     parse-fortran-type
 401     [ (fortran-type>c-type) c-type>pointer ]
 402     [ added-c-args ] bi ;
 403 : fortran-ret-type>c-type ( fortran-type -- c-type added-args )
 404     parse-fortran-type dup returns-by-value?
 405     [ (fortran-ret-type>c-type) { } ] [
 406         "void" swap
 407         [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix
 408     ] if ;
 409
 410 : fortran-arg-types>c-types ( fortran-types -- c-types )
 411     [ length <vector> 1 <vector> ] keep
 412     [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
 413     append >array ;
 414
 415 : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
 416     [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
 417
 418 : fortran-record>c-struct ( record -- struct )
 419     [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
 420
 421 : define-fortran-record ( name vocab fields -- )
 422     [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
 423
 424 SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ;
 425
 426 : set-fortran-abi ( library -- )
 427     library-fortran-abis get-global at fortran-abi set ;
 428
 429 : (fortran-invoke) ( return library function parameters -- quot )
 430     {
 431         [ 2nip [<fortran-result>] ]
 432         [ nip nip nip [fortran-args>c-args] ]
 433         [ [fortran-invoke] ]
 434         [ 2nip [fortran-results>] ]
 435     } 4 ncleave 4 nappend ;
 436
 437 MACRO: fortran-invoke ( return library function parameters -- )
 438     { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
 439
 440 :: define-fortran-function ( return library function parameters -- )
 441     function create-in dup reset-generic
 442     return library function parameters return [ "void" ] unless* parse-arglist
 443     [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
 444
 445 SYNTAX: SUBROUTINE:
 446     f "c-library" get scan ";" parse-tokens
 447     [ "()" subseq? not ] filter define-fortran-function ;
 448
 449 SYNTAX: FUNCTION:
 450     scan "c-library" get scan ";" parse-tokens
 451     [ "()" subseq? not ] filter define-fortran-function ;
 452
 453 SYNTAX: LIBRARY:
 454     scan
 455     [ "c-library" set ]
 456     [ set-fortran-abi ] bi ;
 457