basis/alien/fortran/fortran.factor

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