extra/alien/fortran/fortran-tests.factor

   1 ! (c) 2009 Joe Groff, see BSD license
   2 USING: alien alien.c-types alien.complex alien.data
   3 alien.fortran alien.fortran.private alien.strings
   4 byte-arrays classes.struct combinators generalizations
   5 io.encodings.ascii kernel namespaces sequences shuffle
   6 tools.test vocabs.parser ;
   7 FROM: alien.syntax => pointer: ;
   8 QUALIFIED-WITH: alien.c-types c
   9 IN: alien.fortran.tests
  10
  11 << intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
  12 LIBRARY: (alien.fortran-tests)
  13 STRUCT: fortran_test_record
  14     { FOO int }
  15     { BAR double[2] }
  16     { BAS char[4] } ;
  17
  18 intel-unix-abi fortran-abi [
  19
  20     ! fortran-name>symbol-name
  21
  22     [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
  23     [ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
  24     [ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
  25
  26     ! fortran-type>c-type
  27
  28     [ c:short ]
  29     [ "integer*2" fortran-type>c-type ] unit-test
  30
  31     [ c:int ]
  32     [ "integer*4" fortran-type>c-type ] unit-test
  33
  34     [ c:int ]
  35     [ "INTEGER" fortran-type>c-type ] unit-test
  36
  37     [ c:longlong ]
  38     [ "iNteger*8" fortran-type>c-type ] unit-test
  39
  40     [ { c:int 0 } ]
  41     [ "integer(*)" fortran-type>c-type ] unit-test
  42
  43     [ { c:int 0 } ]
  44     [ "integer(3,*)" fortran-type>c-type ] unit-test
  45
  46     [ { c:int 3 } ]
  47     [ "integer(3)" fortran-type>c-type ] unit-test
  48
  49     [ { c:int 6 } ]
  50     [ "integer(3,2)" fortran-type>c-type ] unit-test
  51
  52     [ { c:int 24 } ]
  53     [ "integer(4,3,2)" fortran-type>c-type ] unit-test
  54
  55     [ c:char ]
  56     [ "character" fortran-type>c-type ] unit-test
  57
  58     [ c:char ]
  59     [ "character*1" fortran-type>c-type ] unit-test
  60
  61     [ { c:char 17 } ]
  62     [ "character*17" fortran-type>c-type ] unit-test
  63
  64     [ { c:char 17 } ]
  65     [ "character(17)" fortran-type>c-type ] unit-test
  66
  67     [ c:int ]
  68     [ "logical" fortran-type>c-type ] unit-test
  69
  70     [ c:float ]
  71     [ "real" fortran-type>c-type ] unit-test
  72
  73     [ c:double ]
  74     [ "double-precision" fortran-type>c-type ] unit-test
  75
  76     [ c:float ]
  77     [ "real*4" fortran-type>c-type ] unit-test
  78
  79     [ c:double ]
  80     [ "real*8" fortran-type>c-type ] unit-test
  81
  82     [ complex-float ]
  83     [ "complex" fortran-type>c-type ] unit-test
  84
  85     [ complex-double ]
  86     [ "double-complex" fortran-type>c-type ] unit-test
  87
  88     [ complex-float ]
  89     [ "complex*8" fortran-type>c-type ] unit-test
  90
  91     [ complex-double ]
  92     [ "complex*16" fortran-type>c-type ] unit-test
  93
  94     [ fortran_test_record ]
  95     [
  96         [
  97             "alien.fortran.tests" use-vocab
  98             "fortran_test_record" fortran-type>c-type
  99         ] with-manifest
 100     ] unit-test
 101
 102     ! fortran-arg-type>c-type
 103
 104     [ pointer: c:int { } ]
 105     [ "integer" fortran-arg-type>c-type ] unit-test
 106
 107     [ pointer: { c:int 3 } { } ]
 108     [ "integer(3)" fortran-arg-type>c-type ] unit-test
 109
 110     [ pointer: { c:int 0 } { } ]
 111     [ "integer(*)" fortran-arg-type>c-type ] unit-test
 112
 113     [ pointer: fortran_test_record { } ]
 114     [
 115         [
 116             "alien.fortran.tests" use-vocab
 117             "fortran_test_record" fortran-arg-type>c-type
 118         ] with-manifest
 119     ] unit-test
 120
 121     [ pointer: c:char { } ]
 122     [ "character" fortran-arg-type>c-type ] unit-test
 123
 124     [ pointer: c:char { } ]
 125     [ "character(1)" fortran-arg-type>c-type ] unit-test
 126
 127     [ pointer: { c:char 17 } { long } ]
 128     [ "character(17)" fortran-arg-type>c-type ] unit-test
 129
 130     ! fortran-ret-type>c-type
 131
 132     [ c:char { } ]
 133     [ "character(1)" fortran-ret-type>c-type ] unit-test
 134
 135     [ c:void { pointer: { c:char 17 } long } ]
 136     [ "character(17)" fortran-ret-type>c-type ] unit-test
 137
 138     [ c:int { } ]
 139     [ "integer" fortran-ret-type>c-type ] unit-test
 140
 141     [ c:int { } ]
 142     [ "logical" fortran-ret-type>c-type ] unit-test
 143
 144     [ c:float { } ]
 145     [ "real" fortran-ret-type>c-type ] unit-test
 146
 147     [ c:void { pointer: { c:float 0 } } ]
 148     [ "real(*)" fortran-ret-type>c-type ] unit-test
 149
 150     [ c:double { } ]
 151     [ "double-precision" fortran-ret-type>c-type ] unit-test
 152
 153     [ c:void { pointer: complex-float } ]
 154     [ "complex" fortran-ret-type>c-type ] unit-test
 155
 156     [ c:void { pointer: complex-double } ]
 157     [ "double-complex" fortran-ret-type>c-type ] unit-test
 158
 159     [ c:void { pointer: { c:int 0 } } ]
 160     [ "integer(*)" fortran-ret-type>c-type ] unit-test
 161
 162     [ c:void { pointer: fortran_test_record } ]
 163     [
 164         [
 165             "alien.fortran.tests" use-vocab
 166             "fortran_test_record" fortran-ret-type>c-type
 167         ] with-manifest
 168     ] unit-test
 169
 170     ! fortran-sig>c-sig
 171
 172     [ c:float { pointer: c:int pointer: { c:char 17 } pointer: c:float pointer: c:double c:long } ]
 173     [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
 174     unit-test
 175
 176     [ c:char { pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
 177     [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
 178     unit-test
 179
 180     [ c:void { pointer: { c:char 18 } c:long pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
 181     [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
 182     unit-test
 183
 184     [ c:void { pointer: complex-float pointer: { c:char 17 } pointer: c:char pointer: c:int c:long } ]
 185     [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
 186     unit-test
 187
 188     ! (fortran-invoke)
 189
 190     [ [
 191         ! [fortran-args>c-args]
 192         {
 193             [ {
 194                 [ ascii string>alien ]
 195                 [ longlong <ref> ]
 196                 [ float <ref> ]
 197                 [ <complex-float> ]
 198                 [ 1 0 ? c:short <ref> ]
 199             } spread ]
 200             [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
 201         } 5 ncleave
 202         ! [fortran-invoke]
 203         [
 204             c:void "funpack" "funtimes_"
 205             { pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long } f
 206             alien-invoke
 207         ] 6 nkeep
 208         ! [fortran-results>]
 209         shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
 210         {
 211             [ drop ]
 212             [ drop ]
 213             [ drop ]
 214             [ float deref ]
 215             [ drop ]
 216             [ drop ]
 217         } spread
 218     ] ] [
 219         f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
 220         (fortran-invoke)
 221     ] unit-test
 222
 223     [ [
 224         ! [fortran-args>c-args]
 225         {
 226             [ { [ ] } spread ]
 227             [ { [ drop ] } spread ]
 228         } 1 ncleave
 229         ! [fortran-invoke]
 230         [ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } f alien-invoke ]
 231         1 nkeep
 232         ! [fortran-results>]
 233         shuffle( reta aa -- reta aa )
 234         { [ ] [ drop ] } spread
 235     ] ] [
 236         "REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
 237         (fortran-invoke)
 238     ] unit-test
 239
 240     [ [
 241         ! [<fortran-result>]
 242         [ complex-float heap-size <byte-array> ] 1 ndip
 243         ! [fortran-args>c-args]
 244         { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
 245         ! [fortran-invoke]
 246         [
 247             c:void "funpack" "fun_times_"
 248             { pointer: complex-float pointer: { c:float 0 } } f
 249             alien-invoke
 250         ] 2 nkeep
 251         ! [fortran-results>]
 252         shuffle( reta aa -- reta aa )
 253         { [ *complex-float ] [ drop ] } spread
 254     ] ] [
 255         "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
 256         (fortran-invoke)
 257     ] unit-test
 258
 259     [ [
 260         ! [<fortran-result>]
 261         [ 20 <byte-array> 20 ] 0 ndip
 262         ! [fortran-invoke]
 263         [
 264             c:void "funpack" "fun_times_"
 265             { pointer: { c:char 20 } long } f
 266             alien-invoke
 267         ] 2 nkeep
 268         ! [fortran-results>]
 269         shuffle( reta retb -- reta retb )
 270         { [ ] [ ascii alien>nstring ] } spread
 271     ] ] [
 272         "CHARACTER*20" "funpack" "FUN_TIMES" { }
 273         (fortran-invoke)
 274     ] unit-test
 275
 276     [ [
 277         ! [<fortran-result>]
 278         [ 10 <byte-array> 10 ] 3 ndip
 279         ! [fortran-args>c-args]
 280         {
 281             [ {
 282                 [ ascii string>alien ]
 283                 [ float <ref> ]
 284                 [ ascii string>alien ]
 285             } spread ]
 286             [ { [ length ] [ drop ] [ length ] } spread ]
 287         } 3 ncleave
 288         ! [fortran-invoke]
 289         [
 290             c:void "funpack" "fun_times_"
 291             { pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long } f
 292             alien-invoke
 293         ] 7 nkeep
 294         ! [fortran-results>]
 295         shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
 296         {
 297             [ ]
 298             [ ascii alien>nstring ]
 299             [ ]
 300             [ ascii alien>nstring ]
 301             [ float deref ]
 302             [ ]
 303             [ ascii alien>nstring ]
 304         } spread
 305     ] ] [
 306         "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
 307         (fortran-invoke)
 308     ] unit-test
 309
 310 ] with-variable ! intel-unix-abi
 311
 312 intel-windows-abi fortran-abi [
 313
 314     [ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test
 315     [ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
 316     [ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
 317
 318 ] with-variable
 319
 320 f2c-abi fortran-abi [
 321
 322     [ { c:char 1 } ]
 323     [ "character(1)" fortran-type>c-type ] unit-test
 324
 325     [ pointer: c:char { c:long } ]
 326     [ "character" fortran-arg-type>c-type ] unit-test
 327
 328     [ c:void { pointer: c:char c:long } ]
 329     [ "character" fortran-ret-type>c-type ] unit-test
 330
 331     [ c:double { } ]
 332     [ "real" fortran-ret-type>c-type ] unit-test
 333
 334     [ c:void { pointer: { c:float 0 } } ]
 335     [ "real(*)" fortran-ret-type>c-type ] unit-test
 336
 337     [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
 338     [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
 339     [ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
 340
 341 ] with-variable
 342
 343 gfortran-abi fortran-abi [
 344
 345     [ c:float { } ]
 346     [ "real" fortran-ret-type>c-type ] unit-test
 347
 348     [ c:void { pointer: { c:float 0 } } ]
 349     [ "real(*)" fortran-ret-type>c-type ] unit-test
 350
 351     [ complex-float { } ]
 352     [ "complex" fortran-ret-type>c-type ] unit-test
 353
 354     [ complex-double { } ]
 355     [ "double-complex" fortran-ret-type>c-type ] unit-test
 356
 357     [ { char 1 } ]
 358     [ "character(1)" fortran-type>c-type ] unit-test
 359
 360     [ pointer: c:char { c:long } ]
 361     [ "character" fortran-arg-type>c-type ] unit-test
 362
 363     [ c:void { pointer: c:char c:long } ]
 364     [ "character" fortran-ret-type>c-type ] unit-test
 365
 366     [ complex-float { } ]
 367     [ "complex" fortran-ret-type>c-type ] unit-test
 368
 369     [ complex-double { } ]
 370     [ "double-complex" fortran-ret-type>c-type ] unit-test
 371
 372     [ c:void { pointer: { complex-double 3 } } ]
 373     [ "double-complex(3)" fortran-ret-type>c-type ] unit-test
 374
 375 ] with-variable