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