1#!/usr/bin/env python3 2# 3# Generates Fortran function stubs and module interface definitions for PETSc and SLEPc 4# 5# Note 1: 6# const char *title[] gets mapped to character(*) title and the string gets copied into the space provided by the caller 7# 8# This tool looks for the values MANSEC and [BFORT]SUBMANSEC (where BFORTSUBMANSEC has priority over SUBMANSEC) 9# defined in the makefile 10# 11# The generated interface files are stored in $PETSC_ARCH/ftn/MANSEC/petsc[BFORT]SUBMANSEC.* 12# These are then included by the src/MANSEC/ftn-mod/MANSECmod.F90 files to create the Fortran module files 13# 14# The generated C stub files are stored in $PETSC_ARCH/ftn/MANSEC/**/ where ** is the directory under MANSEC of the original source 15# 16# Stubs/interfaces generated from include can only involve sys files 17# 18# SUBMANSEC (but not BFORTSUBMANSEC) is also used (in the documentation generating part of PETSc) to determine what 19# directory in doc/manualpages/ the manual pages are deposited. 20# 21# An example of when the BFORTSUBMANSEC may be different than SUBMANSEC is src/dm/label/impls/ephemeral/plex where we would like 22# the documentation to be stored under DMLabel but the function interfaces need to go into the DMPLEX Fortran module 23# (not the DM Fortran module) since they depend on DMPlexTransform. 24# 25import os 26import pathlib 27import shutil 28import sys 29import string 30import subprocess 31from subprocess import check_output 32sys.path.insert(0,os.path.realpath(os.path.dirname(__file__))) 33import getAPI 34 35CToFortranTypes = {'int':'integer4', 'ptrdiff_t':'PetscInt64', 'float':'PetscFortranFloat', 'int32_t':'integer4', 36 'double':'PetscFortranDouble', 'short':None, 'size_t':'PetscSizeT', 'rocblas_status':None, 'PetscBT':None, 37 'PetscEnum':None, 'PetscDLHandle':None} 38 39verbose = False 40 41def verbosePrint(text): 42 '''Prints the text if run with verbose option''' 43 if verbose: print(text) 44 45def generateFortranInterface(pkgname, petscarch, classes, enums, structs, senums, funname, mpi_f08, fun): 46 '''Generates the interface definition for a function''' 47 '''This is used both by class functions and standalone functions''' 48 # check for functions for which we cannot build interfaces 49 if fun.opaque: 50 return 51 if fun.name.find('_') > -1: return 52 for k in fun.arguments: 53 ktypename = k.typename.replace('MPI_', 'MPIU_').replace('MPIU_Fint', 'MPI_Fint') 54 if ktypename in CToFortranTypes and not CToFortranTypes[ktypename]: 55 fun.opaque = True 56 return 57 if ktypename.find('_') and not ktypename.startswith('MPI') > -1: 58 fun.opaque = True 59 return 60 if ktypename.endswith('Func'): 61 # these function typedef are soon to be eliminated and so can this check 62 fun.opaque = True 63 return 64 if ktypename == 'void' and not k.isfunction: 65 return 66 67 mansec = fun.mansec 68 if not mansec: mansec = fun.submansec 69 file = fun.includefile + '90' 70 if not file.startswith(pkgname): file = pkgname + file 71 ofile = os.path.join(petscarch,'ftn', getAPI.mansecpath(mansec),file) 72 73 # Do we need to generate instead an Interface_Funname() macro? 74 PetscCtxRt = False 75 NL = '\n' 76 for k in fun.arguments: 77 if k.typename == 'PetscCtxRt': 78 PetscCtxRt = True 79 80 if PetscCtxRt: 81 with open(os.path.join(petscarch, 'include', pkgname, 'finclude', file.replace('.h90', '.h')),'a') as fd: 82 fd.write('#define ' + funname + '(') 83 cnt = 0 84 for k in fun.arguments: 85 if cnt > 0: fd.write(', ') 86 fd.write(k.name) 87 cnt = cnt + 1 88 fd.write(', ierr) ' + funname + 'Cptr(') 89 cnt = 0 90 for k in fun.arguments: 91 if cnt > 0: fd.write(', ') 92 if k.typename == 'PetscCtxRt': 93 name = k.name 94 fd.write('petscFtnCtx') 95 else: 96 fd.write(k.name) 97 cnt = cnt + 1 98 fd.write(', ierr); call c_f_pointer(petscFtnCtx, ' + name + ')\n') 99 100 with open(ofile,"a") as fd: 101 if funname in ['PetscObjectQuery', 'PetscObjectCompose']: 102 # for macro polymorphism the objects are passed directly as obj%d 103 fun.arguments[0].typename = 'PetscFortranAddr' 104 fun.arguments[2].typename = 'PetscFortranAddr' 105 funname = funname + 'Raw' 106 107 108 if funname.startswith('PetscObject') or funname == 'PetscBarrier': fd.write(' interface ' + funname + NL) 109 else: fd.write(' interface' + NL) 110 fi = fun 111 func = '' 112 if PetscCtxRt: func = 'cptr'; 113 dims = [''] 114 # if ((funname).startswith('MatDenseGetArray') or (funname).startswith('MatDenseRestoreArray')) and fi[-1].endswith('[]'): dims = ['1d','2d'] 115 for dim in dims: 116 fd.write(' subroutine ' + funname + func + dim + '(') 117 simportset = set() 118 simport = '' 119 cnt = 0 120 for k in fi.arguments: 121 if k.stringlen: continue 122 ktypename = k.typename 123 if cnt: fd.write(',') 124 fd.write(k.name) 125 if not ktypename in simportset: 126 if ktypename in classes or ktypename == 'VecScatter': 127 if simport: simport = simport + ',' 128 simport = simport + 't' + ktypename 129 if ktypename in enums: 130 if simport: simport = simport + ',' 131 simport = simport + 'e' + ktypename 132 if ktypename in structs and not structs[ktypename].opaque: 133 if simport: simport = simport + ',' 134 simport = simport + 's' + ktypename 135 if mpi_f08 and ktypename.startswith('MPI_'): 136 if simport: simport = simport + ',' 137 simport = simport + ktypename 138 simportset.add(ktypename) 139 cnt = cnt + 1 140 if cnt: fd.write(', ') 141 fd.write('ierr)' + NL) 142 fd.write(' use, intrinsic :: ISO_C_binding' + NL) 143 if simport: fd.write(' import ' + simport + NL) 144 145 cnt = 0 146 for k in fun.arguments: 147 if k.stringlen: continue 148 ktypename = k.typename.replace('MPI_', 'MPIU_').replace('MPIU_Fint', 'MPI_Fint') 149 if ktypename in CToFortranTypes: 150 ktypename =CToFortranTypes[ktypename] 151 if ktypename == 'char': 152 if getattr(k, 'char_type', None) == 'single': 153 fd.write(' character :: ' + k.name + NL) 154 else: 155 fd.write(' character(*) :: ' + k.name + NL) 156 elif ktypename in senums: 157 fd.write(' character(*) :: ' + k.name + NL) 158 elif k.array and k.stars: 159 if not dim or dim == '1d': fd.write(' ' + ktypename + ', pointer :: ' + k.name + '(:)' + NL) 160 else: fd.write(' ' + ktypename + ', pointer :: ' + k.name + '(:,:)' + NL) 161 elif k.array: 162 fd.write(' ' + ktypename + ' :: ' + k.name + '(*)' + NL) 163 elif k.isfunction: 164 fd.write(' ' + 'external ' + k.name + NL) 165 elif ktypename == 'PetscCtx': 166 fd.write(' type(*) :: ' + k.name + NL) 167 elif ktypename == 'PetscCtxRt': 168 fd.write(' type(c_ptr) :: ' + k.name + NL) 169 else: 170 fd.write(' ' + ktypename + ' :: ' + k.name + NL) 171 cnt = cnt + 1 172 fd.write(' PetscErrorCode, intent(out) :: ierr' + NL) 173 # some Fortran compilers require the end to be on its own line 174 fd.write(' end subroutine\n') 175 fd.write(' end interface\n') 176 fd.write('#if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)\n') 177 fd.write('!DEC$ ATTRIBUTES DLLEXPORT::' + funname + func + dim + NL) 178 fd.write('#endif\n') 179 180 if fun.name in ['PetscObjectQuery', 'PetscObjectCompose']: 181 # under change above 182 fun.arguments[0].typename = 'PetscObject' 183 fun.arguments[2].typename = 'PetscObject' 184 185def generateCStub(pkgname,petscarch,manualstubsfound,senums,classes,structs,funname,fun): 186 '''Generates the C stub that is callable from Fortran for a function''' 187 # 188 # 189 # PETSc returns strings in two ways either 190 # - with a pointer to an array: char *[] 191 # - or by copying the string into a given array with a given length: char [], size_t len 192 # 193 # in both cases the Fortran API passes in a character(*) with enough room to hold the result. 194 # It does not pass in the string length as a separate argument 195 # 196 # The following Argument class values used to indicate which case is being generated 197 # - stringlen - True indicates the argument is the length of the previous argument which is a character string 198 # - const - indicates the string argument is an input, not an output 199 # - stars == 1 - indicates the string is (in C) returned by a pointer to a string array 200 # 201 if fun.penss: return 202 203 skipbody = False 204 if fun.opaque or fun.opaquestub: skipbody = True 205 for k in fun.arguments: 206 if k.array and k.stars and not k.typename == 'char': skipbody = True 207 if k.stars and k.typename == 'MPI_Fint': skipbody = True 208 if k.stars == 2 and k.typename == 'void': skipbody = True 209 if k.isfunction: skipbody = True 210 if skipbody and fun.name.lower() in manualstubsfound: return 211 212 for k in fun.arguments: 213 # no automatic stub if function returns an array, except if it is a string 214 if not skipbody and k.array and k.stars and not k.typename == 'char': return 215 if k.stars and k.typename == 'MPI_Fint': return # TODO add support for returning MPI_Fint 216 if k.stars == 2 and k.typename == 'void': return 217 218 # no manual stub if dealing with multidimensional arrays, voids, etc 219 if skipbody: 220 if k.stars > 1: return 221 if k.typename == 'void': return 222 if k.typename == 'char' and not k.array: return 223 return 224 225 if not skipbody: 226 if fun.file.endswith('.h'): 227 dir = os.path.join(petscarch,'ftn',fun.mansec.lower(),'stubs') 228 filename = fun.file.replace('.h','.c') 229 else: 230 dir = os.path.join(petscarch,fun.dir.replace('src/','ftn/')) 231 filename = fun.file 232 else: 233 dir = os.path.join(fun.dir,'ftn-custom') 234 filename = 'z' + fun.file 235 if not os.path.isdir(dir): os.makedirs(dir) 236 237 with open(os.path.join(dir,filename.replace('.c','f.c')),'a') as fd: 238 fd.write('#include "petscsys.h"\n') 239 fd.write('#include "petscfix.h"\n') 240 fd.write('#include "petsc/private/ftnimpl.h"\n') 241 fd.write('#include <' + pkgname + fun.mansec + '.h>\n') 242 fd.write('#include <' + pkgname + fun.includefile.replace(pkgname,'') + '>\n') 243 244 suffix = '' 245 # not used because generating the Fortran modules takes too long 246 #for k in fun.arguments: 247 # if k.optional: 248 # suffix = 'raw' 249 if funname in ['PetscObjectQuery', 'PetscObjectCompose']: 250 suffix = 'raw' 251 252 for k in fun.arguments: 253 if k.typename == 'PetscCtxRt': 254 suffix = 'cptr' 255 break 256 257 fd.write('#if defined(PETSC_HAVE_FORTRAN_CAPS)\n') 258 fd.write(' #define ' + (funname + suffix).lower() + '_ ' + (funname + suffix).upper() + '\n') 259 fd.write('#elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)\n') 260 fd.write(' #define ' + (funname + suffix).lower() + '_ ' + (funname + suffix).lower() + '\n') 261 fd.write('#endif\n') 262 263 # output function declaration prototype 264 fd.write(pkgname.upper() + '_EXTERN void ' + (funname + suffix).lower() + '_(') 265 cnt = 0 266 for k in fun.arguments: 267 if k.stringlen: continue 268 ktypename = k.typename.replace('MPI_', 'MPIU_').replace('MPIU_Fint', 'MPI_Fint') 269 if cnt: fd.write(', ') 270 if k.const and not ((k.typename == 'char' or k.typename in senums) and k.array): 271 # see note one at the top of the file why const is not added for this case 272 fd.write('const ') 273 if k.typename in senums: 274 fd.write('char *') 275 elif k.typename == 'char' and not k.array and not k.stars and getattr(k, 'char_type', None) == 'single': 276 fd.write('char *') 277 else: 278 if k.stars == 1 and k.array and not ktypename == 'char': 279 fd.write('F90Array1d *') 280 else: 281 fd.write(ktypename) 282 fd.write(' ') 283 if k.typename in structs.keys() and structs[k.typename].opaque: 284 fd.write('*') 285 if not (k.typename == 'char' or k.typename in senums or k.array or k.typename == 'PetscCtxRt' or k.typename == 'PetscCtx'): 286 fd.write('*') 287 fd.write(k.name) 288 if (k.typename == 'char' and getattr(k, 'char_type', None) != 'single') or (not k.stars and k.array): fd.write('[]') 289 cnt = cnt + 1 290 if cnt: fd.write(', ') 291 fd.write('PetscErrorCode *ierr') 292 # add the lengths of the string arguments put in by the Fortran compiler 293 cnt = 0 294 for k in fun.arguments: 295 if k.stringlen: continue 296 if k.typename in senums or k.typename == 'char': 297 fd.write(', PETSC_FORTRAN_CHARLEN_T l_' + k.name) 298 cnt = cnt + 1 299 fd.write(')\n{\n') 300 301 if skipbody: 302 fd.write(' PetscError(PETSC_COMM_SELF, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_SUP, PETSC_ERROR_INITIAL, "Add Fortran stub body here!");\n') 303 fd.write(' *ierr = PETSC_ERR_SUP;\n') 304 fd.write(' // You may need the code fragments below\n'); 305 fd.write(' // *ierr = F90Array1dCreate(C array, MPIU_XXX, 1, length, Fortran array\n'); 306 fd.write(' // *ierr = F90Array1dAccess(Fortran array , MPIU_XXX, (void **)&C array\n'); 307 fd.write(' // *ierr = F90Array1dDestroy(Fortran array, MPIU_XXX\n'); 308 else: 309 # functions that destroy objects should return immediately if null, -2, -3 310 if fun.arguments and fun.arguments[0].typename in classes and fun.name.endswith('Destroy'): 311 fd.write(' PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(' + fun.arguments[0].name + ');\n') 312 313 # handle arguments that may return a null object 314 cnt = 0 315 for k in fun.arguments: 316 if k.stringlen: continue 317 if k.stars and k.typename in classes: 318 fd.write(' PetscBool null_' + k.name + ' = !*(void**) ' + k.name + ' ? PETSC_TRUE : PETSC_FALSE;\n') 319 cnt = cnt + 1 320 321 # prevent an existing object from being overwritten by a new create 322 if fun.arguments and fun.arguments[-1].typename in classes and fun.name.endswith('Create'): 323 fd.write(' PETSC_FORTRAN_OBJECT_CREATE(' + fun.arguments[-1].name + ');\n') 324 325 # handle string argument fixes 326 cnt = 0 327 for k in fun.arguments: 328 if k.stringlen: continue 329 if k.typename == 'char': 330 if getattr(k, 'char_type', None) == 'single': pass 331 elif not k.stars: 332 if k.const: 333 fd.write(' char* c_' + k.name + ';\n') 334 fd.write(' FIXCHAR(' + k.name + ', l_' + k.name + ', c_' + k.name + ');\n') 335 elif k.stars: 336 fd.write(' char* c_' + k.name + ' = PETSC_NULLPTR;\n') 337 elif k.typename in senums: 338 if not k.stars: 339 fd.write(' char* c_' + k.name + ';\n') 340 fd.write(' FIXCHAR(' + k.name + ', l_' + k.name + ', c_' + k.name + ');\n') 341 elif k.stars: 342 fd.write(' char* c_' + k.name + ' = PETSC_NULLPTR;\n') 343 cnt = cnt + 1 344 345 # handle viewer argument fixes 346 cnt = 0 347 for k in fun.arguments: 348 if k.stringlen: continue 349 if k.typename == 'PetscViewer' and not k.stars and not k.array: 350 fd.write(' PetscViewer v_' + k.name + ' = PetscPatchDefaultViewers(' + k.name + ');\n') 351 cnt = cnt + 1 352 353 # handle any arguments that may be null 354 cnt = 0 355 for k in fun.arguments: 356 if k.stringlen: continue 357 if k.stars or k.array: 358 if k.typename in classes: 359 fd.write(' CHKFORTRANNULLOBJECT(' + k.name + ');\n') 360 elif k.typename == 'PetscInt': 361 fd.write(' CHKFORTRANNULLINTEGER(' + k.name + ');\n') 362 elif k.typename == 'PetscReal': 363 fd.write(' CHKFORTRANNULLREAL(' + k.name + ');\n') 364 elif k.typename == 'PetscScalar': 365 fd.write(' CHKFORTRANNULLSCALAR(' + k.name + ');\n') 366 elif k.typename == 'PetscBool': 367 fd.write(' CHKFORTRANNULLBOOL(' + k.name + ');\n') 368 cnt = cnt + 1 369 370 # call C function 371 fd.write(' *ierr = ' + funname + '(') 372 cnt = 0 373 for k in fun.arguments: 374 if cnt: fd.write(', ') 375 if (k.typename in senums or k.typename == 'char') and k.stars: 376 fd.write('(const char **)&') 377 if k.typename == 'char': 378 if getattr(k, 'char_type', None) == 'single': 379 fd.write('*') 380 elif k.const: 381 fd.write('c_') 382 elif k.typename in senums: 383 fd.write('c_') 384 elif k.typename == 'MPI_Fint': 385 fd.write('MPI_Comm_f2c(*(') 386 elif not k.stars and not k.array and not k.stringlen and not k.typename == 'PetscViewer' and not k.typename == 'PetscCtxRt' and not k.typename == 'PetscCtx': 387 fd.write('*') 388# if k.typename == 'void' and k.stars == 2: 389# fd.write('&') 390 if k.stringlen: 391 fd.write('l_' + fun.arguments[cnt-1].name) 392 continue 393 if k.typename == 'PetscViewer' and not k.stars and not k.array: 394 fd.write('v_') 395 if k.typename in structs.keys() and structs[k.typename].opaque: 396 fd.write('*') 397 fd.write(k.name) 398 if k.typename == 'PetscBool' and not k.stars and not k.array: 399 # handle bool argument fixes (-1 needs to be corrected to 1 for Intel compilers) 400 fd.write(' ? PETSC_TRUE : PETSC_FALSE') 401 if k.typename == 'MPI_Fint': 402 fd.write('))') 403 cnt = cnt + 1 404 fd.write(');\n') 405 fd.write(' if (*ierr) return;\n'); 406 407 # cleanup any string arguments fixes 408 cnt = 0 409 for k in fun.arguments: 410 if k.stringlen: continue 411 if k.typename == 'char' or k.typename in senums: 412 if k.typename == 'char' and getattr(k, 'char_type', None) == 'single': pass 413 elif not k.stars and (k.const or k.typename in senums): 414 fd.write(' FREECHAR(' + k.name + ', c_' + k.name + ');\n') 415 else: 416 if k.stars: 417 fd.write(' *ierr = PetscStrncpy((char *)' + k.name + ', c_' + k.name + ', l_' + k.name + ');\n') 418 fd.write(' if (*ierr) return;\n'); 419 fd.write(' FIXRETURNCHAR(PETSC_TRUE, ' + k.name + ', l_' + k.name + ');\n') 420 cnt = cnt + 1 421 422 # handle arguments that may return a null PETSc object 423 cnt = 0 424 for k in fun.arguments: 425 if k.stringlen: continue 426 if k.stars and k.typename in classes: 427 fd.write(' if (! null_' + k.name + ' && !*(void**) ' + k.name + ') *(void **) ' + k.name + ' = (void *)-2;\n') 428 cnt = cnt + 1 429 430 fd.write('}\n') 431 if not skipbody: 432 shutil.copy(os.path.join(fun.dir,'makefile'), os.path.join(dir,'makefile')) 433 else: 434 with open(os.path.join(fun.dir,'makefile')) as fin: 435 with open(os.path.join(dir,'makefile'),'w') as fout: 436 fout.write(fin.read().replace('petscdir.mk','../petscdir.mk')) 437 output = check_output('git add ' + os.path.join(dir,'makefile'), shell=True).decode('utf-8') 438 print('Fix the manual stub for ' + fun.name + ' in ' + os.path.join(dir,filename.replace('.c','f.c'))) 439 output = check_output('git add ' + os.path.join(dir,filename.replace('.c','f.c')), shell=True).decode('utf-8') 440 441def generateFortranStub(senums, funname, fun, fd, opts): 442 '''For functions with optional arguments generate the Fortran stub that calls the C stub''' 443 for k in fun.arguments: 444 # no C stub if function returns an array, except if it is a string 445 # TODO: generate fillible stub for functions that return arrays 446 if k.array and k.stars and not k.typename == 'char': return 447 if k.stars and k.typename == 'MPI_Fint': return # TODO add support for returning MPI_Fint 448 if k.stars == 2 and k.typename == 'void': return 449 for fi in opts: 450 fd.write(' subroutine ' + funname + ''.join(fi) + '(') 451 cnt = 0 452 for k in fun.arguments: 453 if k.stringlen: continue 454 if cnt: fd.write(',') 455 fd.write(k.name) 456 cnt = cnt + 1 457 fd.write(',ierr)\n') 458 cnt = 0 459 for k in fun.arguments: 460 if k.stringlen: continue 461 ktypename = k.typename.replace('MPI_', 'MPIU_').replace('MPIU_Fint', 'MPI_Fint') 462 if fi[cnt] == 'O': 463 fd.write(' PetscNull :: ' + k.name + '\n') 464 elif ktypename in senums or ktypename == 'char': 465 fd.write(' character(*) :: ' + k.name + '\n') 466 elif k.array and k.stars: 467 fd.write(' ' + ktypename + ', pointer :: ' + k.name + '(:)\n') 468 elif k.array: 469 fd.write(' ' + ktypename + ' :: '+ k.name + '(*)\n') 470 elif ktypename == 'PetscCtx': 471 fd.write(' type(*) :: ' + k.name + '\n') 472 else: 473 fd.write(' '+ ktypename + ' :: ' + k.name + '\n') 474 cnt = cnt + 1 475 fd.write(' PetscErrorCode ierr\n') 476 fd.write(' call ' + funname + 'Raw(') 477 cnt = 0 478 for k in fun.arguments: 479 if k.stringlen: continue 480 ktypename = k.typename.replace('MPI_', 'MPIU_').replace('MPIU_Fint', 'MPI_Fint') 481 if cnt: fd.write(',') 482 if fi[cnt] == 'a': 483 fd.write(k.name) 484 else: 485 typename = ktypename.upper().replace('PETSC','') 486 if typename == 'INT': typename = 'INTEGER' 487 fd.write('PETSC_NULL_' + typename) 488 if k.array and k.stars: fd.write('_POINTER') 489 elif k.array: fd.write('_ARRAY') 490 cnt = cnt + 1 491 fd.write(',ierr)\n') 492 fd.write(' end subroutine\n') 493 494########## main 495 496def main(petscdir,slepcdir,petscarch,mpi_f08 = 'Unknown'): 497 '''Generates all the Fortran include and C stub files needed for the Fortran API''' 498 import pickle 499 del sys.path[0] 500 501 if mpi_f08 == 'Unknown': 502 with open(os.path.join(petscdir,'' if slepcdir and petscarch.startswith('installed-') else petscarch,'include','petscconf.h')) as fd: 503 mpi_f08 = fd.read().find('mpi_f08') > -1 504 505 pkgname = 'slepc' if slepcdir else 'petsc' 506 507 if not slepcdir: 508 classes, enums, senums, typedefs, structs, funcs, files, mansecs, submansecs = getAPI.getAPI(petscdir,'petsc') 509 510 with open(os.path.join(petscdir,petscarch,'lib','petsc','conf','classes.data'),'wb') as file: 511 pickle.dump(classes,file) 512 pickle.dump(enums,file) 513 pickle.dump(senums,file) 514 pickle.dump(structs,file) 515 pickle.dump(typedefs,file) 516 517 petscobjectfunctions = classes['PetscObject'].functions 518 classesext = classes.copy() 519 structsext = structs.copy() 520 enumsext = enums.copy() 521 senumsext = senums.copy() 522 else: 523 with open(os.path.join(petscdir,'' if petscarch.startswith('installed-') else petscarch,'lib','petsc','conf','classes.data'),'rb') as file: 524 petscclasses = pickle.load(file) 525 petscenums = pickle.load(file) 526 petscsenums = pickle.load(file) 527 petscstructs = pickle.load(file) 528 petsctypedefs = pickle.load(file) 529 530 petscobjectfunctions = petscclasses['PetscObject'].functions 531 classes, enums, senums, typedefs, structs, funcs, files, mansecs, submansecs = getAPI.getAPI(slepcdir,'slepc') 532 classesext = classes.copy(); classesext.update(petscclasses) 533 structsext = structs.copy(); structsext.update(petscstructs) 534 enumsext = enums.copy(); enumsext.update(petscenums) 535 senumsext = senums.copy(); senumsext.update(petscsenums) 536 537########## $PETSC_ARCH/include/petsc/finclude/*.h 538 539 dir = os.path.join(petscarch,'include', pkgname, 'finclude') 540 skipinc = [pkgname + 'version.h'] 541 if os.path.isdir(dir): shutil.rmtree(dir) 542 os.makedirs(dir) 543 544 for i in files.keys(): 545 if i.endswith('types.h') or i in skipinc: continue 546 with open(os.path.join(dir, i),'w') as fd: 547 dname = pkgname.upper() + i.upper()[0:-2] + 'DEF_H' 548 fd.write('#if !defined(' + dname + ')\n#define ' + dname + '\n\n') 549 fb = os.path.join('include', pkgname, 'finclude',i.replace('.h','base.h')) 550 if os.path.isfile(fb): 551 fd.write('#include "' + os.path.join(pkgname,'finclude',i.replace('.h','base.h')) + '"\n') 552 for j in files[i].included: 553 if j in skipinc: continue 554 j = j.replace('types.h','.h') 555 if i == j: continue 556 fd.write('#include "' + os.path.join(('petsc' if j.startswith('petsc') else 'slepc'),'finclude',j) + '"\n') 557 fd.write('\n') 558 559 for i in enums.keys(): 560 if i in ['PetscBool', 'PetscEnum']: continue 561 with open(os.path.join(dir, enums[i].includefile),"a") as fd: 562 fd.write('#define ' + i + ' type(e' + i + ')\n') 563 564 for i in typedefs.keys(): 565 if not typedefs[i].name: continue 566 if i in ['PetscBool', 'PetscSizeT']: continue 567 value = typedefs[i].value 568 if value in CToFortranTypes: 569 if not CToFortranTypes[value]: continue 570 value = CToFortranTypes[value] 571 with open(os.path.join(dir, typedefs[i].includefile),"a") as fd: 572 fd.write('#define ' + i + ' ' + value + '\n') 573 574 for i in structs.keys(): 575 with open(os.path.join(dir, structs[i].includefile),"a") as fd: 576 if not structs[i].opaque: 577 fd.write('#define ' + i + ' type(s' + i + ')\n') 578 else: 579 fd.write('#define ' + i + ' PetscFortranAddr\n') 580 581 for i in files.keys(): 582 if i.endswith('types.h') or i in skipinc: continue 583 with open(os.path.join(dir, i),'a') as fd: 584 fd.write('\n') 585 586 for i in senums.keys(): 587 with open(os.path.join(dir, senums[i].includefile),"a") as fd: 588 fd.write('#define ' + i + ' CHARACTER(80)\n') 589 590 for i in files.keys(): 591 if i.endswith('types.h') or i in skipinc: continue 592 with open(os.path.join(dir, i),'a') as fd: 593 fd.write('\n') 594 595 for i in classes.keys(): 596 if i in ['PetscIntStack']: continue 597 with open(os.path.join(dir, classes[i].includefile),"a") as fd: 598 fd.write('#define ' + i + ' type(t' + i + ')\n') 599 600 if not slepcdir: 601 # special polymorphic routines handled with macros 602 with open(os.path.join(petscarch,'include', 'petsc', 'finclude', 'petscsys.h'),"a") as fd: 603 fd.write('#define PetscObjectCompose(obj,name,otherobject,ierr) PetscObjectComposeRaw(obj%v,name,otherobject%v,ierr)\n') 604 fd.write('#define PetscObjectQuery(obj,name,otherobject,ierr) PetscObjectQueryRaw(obj%v,name,otherobject%v,ierr)\n') 605 606 for i in files.keys(): 607 if i.endswith('types.h') or i in skipinc: continue 608 with open(os.path.join(dir, i),'a') as fd: 609 fd.write('\n#endif\n') 610 611########### $PETSC_ARCH/ftn/MANSEC/*.h 612 613 dir = os.path.join(petscarch,'ftn') 614 if os.path.isdir(dir): shutil.rmtree(dir) 615 os.makedirs(dir) 616 617 for i in mansecs.keys(): 618 if not slepcdir: 619 dir = os.path.join(petscarch,'ftn', i) 620 if os.path.isdir(dir): shutil.rmtree(dir) 621 os.makedirs(dir) 622 elif i!='sys': 623 dir = os.path.join(petscarch,'ftn', getAPI.mansecpath(i)) 624 if os.path.isdir(dir): shutil.rmtree(dir) 625 os.makedirs(dir) 626 627 for i in classes.keys(): 628 if i in ['PetscIntStack', 'PetscTabulation']: continue 629 with open(os.path.join(petscarch,'ftn', getAPI.mansecpath(classes[i].mansec),classes[i].includefile),"a") as fd: 630 if not classes[i].petscobject: 631 fd.write(' type t' + i + '\n') 632 fd.write(' PetscFortranAddr:: v = PETSC_FORTRAN_TYPE_INITIALIZE\n') 633 fd.write(' end type t' + i + '\n') 634 else: 635 fd.write(' type, extends(tPetscObject) :: t' + i + '\n') 636 fd.write(' end type t' + i + '\n') 637 v = (pkgname.upper() + '_NULL_' + i.upper().replace(pkgname.upper(),'').strip('_')).replace('_NULL_NULL','_NULL') 638 fd.write(' ' + i + ', parameter :: ' + v + ' = t' + i + '(0)\n') 639 fd.write(' ' + i + ', target :: ' + v + '_ARRAY(1) = [t' + i + '(0)]\n') 640 fd.write(' ' + i + ', pointer :: ' + v + '_POINTER(:) => ' + v + '_ARRAY\n') 641 fd.write('#if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)\n') 642 fd.write('!DEC$ ATTRIBUTES DLLEXPORT::' + v + '\n') 643 fd.write('!DEC$ ATTRIBUTES DLLEXPORT::' + v + '_ARRAY\n') 644 fd.write('!DEC$ ATTRIBUTES DLLEXPORT::' + v + '_POINTER\n') 645 fd.write('#endif\n') 646 fd.write('\n') 647 648 for i in enums.keys(): 649 if i in ['PetscBool', 'PetscEnum']: continue 650 with open(os.path.join(petscarch,'ftn', getAPI.mansecpath(enums[i].mansec),enums[i].includefile),"a") as fd: 651 fd.write(' type e' + i + '\n') 652 fd.write(' PetscEnum:: v = PETSC_FORTRAN_TYPE_INITIALIZE\n') 653 fd.write(' end type e' + i + '\n\n') 654 v = (pkgname.upper() + '_NULL_' + i.upper().replace(pkgname.upper(),'').replace('NULL','')).strip('_').replace('_NULL_NULL','_NULL') 655 fd.write(' ' + i + ', parameter :: ' + v + ' = e' + i + '(-50)\n') 656 fd.write('#if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)\n') 657 fd.write('!DEC$ ATTRIBUTES DLLEXPORT::' + v + '\n') 658 fd.write('#endif\n') 659 cnt = 0 660 givenvalue = 0 661 for j in enums[i].values: 662 if j.find('=') > -1: 663 if givenvalue == -1: 664 print('Some enum values for ' + i + ' are set but others are not set') 665 v = j.replace(' = ',' = e' + i + '(') + ')' 666 givenvalue = 1 667 else: 668 if givenvalue == 1: 669 print('Some enum values for ' + i + ' are set but others are not set') 670 v = j + ' = e' + i + '(' + str(cnt) + ')' 671 givenvalue = -1 672 fd.write(' ' + i + ', parameter :: ' + v + '\n') 673 cnt = cnt + 1 674 fd.write('\n') 675 676 fd.write('#if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)\n') 677 for j in enums[i].values: 678 if j.count('='): v = j[0:j.find('=')] 679 else: v = j 680 fd.write('!DEC$ ATTRIBUTES DLLEXPORT::' + v + '\n') 681 fd.write('#endif\n') 682 fd.write('\n') 683 684 for i in senums.keys(): 685 with open(os.path.join(petscarch,'ftn', getAPI.mansecpath(senums[i].mansec),senums[i].includefile),"a") as fd: 686 for j in senums[i].values: 687 fd.write(' CHARACTER(LEN=*), PARAMETER :: ' + j + ' = \'' + senums[i].values[j].replace('"','') + '\'\n') 688 fd.write('\n') 689 690 fd.write('#if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)\n') 691 for j in senums[i].values: 692 fd.write('!DEC$ ATTRIBUTES DLLEXPORT::' + j + '\n') 693 fd.write('#endif\n') 694 fd.write('\n') 695 696 for i in structs.keys(): 697 if structs[i].opaque: continue 698 with open(os.path.join(petscarch,'ftn', getAPI.mansecpath(structs[i].mansec),structs[i].includefile),"a") as fd: 699 fd.write(' type s' + i + '\n') 700 for j in structs[i].records: 701 fd.write(' ' + j.type.replace('[','(').replace(']',')') + '\n') 702 fd.write(' end type s' + i + '\n') 703 fd.write('\n') 704 705########### $PETSC_ARCH/ftn/MANSEC/*.h90 706 707 for i in classes.keys(): 708 # generate interface definitions for all objects' methods 709 if i in ['PetscIntStack']: continue 710 for j in classes[i].functions: # loop over functions in class 711 generateFortranInterface(pkgname,petscarch,classesext,enumsext,structs,senumsext,j,mpi_f08,classes[i].functions[j]) 712 713 if i in ['PetscObject', 'PetscTabulation']: continue 714 file = classes[i].includefile + '90' 715 if not file.startswith(pkgname): file = pkgname + file 716 with open(os.path.join(petscarch,'ftn', getAPI.mansecpath(classes[i].mansec),file),"a") as fd: 717 fd.write(' interface operator(.ne.)\n') 718 fd.write(' module procedure ' + i + 'notequals\n') 719 fd.write(' end interface operator (.ne.)\n') 720 fd.write(' interface operator(.eq.)\n') 721 fd.write(' module procedure ' + i + 'equals\n') 722 fd.write(' end interface operator (.eq.)\n\n') 723 724 # generate interface definitions for PetscObject methods for each PetscObject subclass (KSP etc) 725 if not classes[i].petscobject: continue 726 with open(os.path.join(petscarch,'ftn', getAPI.mansecpath(classes[i].mansec),file),"a") as fd: 727 ii = i.replace('Petsc','') 728 fd.write(' interface PetscObjectCast\n') 729 fd.write(' module procedure PetscObjectCast' + ii + '\n') 730 fd.write(' end interface\n') 731 fd.write(' interface PetscBarrier\n') 732 fd.write(' module procedure PetscBarrier' + ii + '\n') 733 fd.write(' end interface\n') 734 735 for funname in petscobjectfunctions: 736 if funname in ['PetscObjectCompose', 'PetscObjectQuery']: continue 737 fi = petscobjectfunctions[funname] 738 739 # the subclassing only works for PetscObjectXXX(PetscObject xxx,...) class methods 740 if not fi.arguments or not fi.arguments[0].typename == 'PetscObject': continue 741 742 # cannot print Fortran interface definition if any arguments are void * or void ** 743 opaque = False 744 for k in fi.arguments: 745 if k.typename == 'void' or k.typename == 'PetscCtxRt': opaque = True 746 if opaque: continue 747 748 if funname.startswith('PetscObjectSAWs') or funname == 'PetscObjectViewSAWs': 749 # if we always generate the fortran stubs simply mark these functions as opaque when SAWs is not available 750 fd.write('#if defined(PETSC_HAVE_SAWS)\n') 751 fd.write(' interface ' + funname + '\n') 752 fd.write(' module procedure ' + funname + ii + '\n') 753 fd.write(' end interface\n') 754 if funname.startswith('PetscObjectSAWs') or funname == 'PetscObjectViewSAWs': 755 fd.write('#endif\n') 756 757 # generate interface definitions for all standalone functions 758 for j in funcs.keys(): 759 generateFortranInterface(pkgname,petscarch,classesext,enumsext,structs,senumsext,funcs[j].name,mpi_f08,funcs[j]) 760 761 # generate .eq. and .neq. for enums 762 for i in enums.keys(): 763 if i in ['PetscEnum', 'PetscBool3']: continue 764 file = enums[i].includefile + '90' 765 if not file.startswith(pkgname): file = pkgname + file 766 with open(os.path.join(petscarch,'ftn',getAPI.mansecpath(enums[i].mansec),file),"a") as fd: 767 fd.write(' interface operator(.ne.)\n') 768 fd.write(' module procedure ' + i + 'notequals\n') 769 fd.write(' end interface operator (.ne.)\n') 770 fd.write(' interface operator(.eq.)\n') 771 fd.write(' module procedure ' + i + 'equals\n') 772 fd.write(' end interface operator (.eq.)\n\n') 773 774########## $PETSC_ARCH/ftn/MANSEC/*.hf90 775 776 for i in classes.keys(): 777 if i in ['PetscObject', 'PetscIntStack', 'PetscTabulation']: continue 778 with open(os.path.join(petscarch,'ftn', getAPI.mansecpath(classes[i].mansec),classes[i].includefile + 'f90'),"a") as fd: 779 780 fd.write('#if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)\n') 781 fd.write('!DEC$ ATTRIBUTES DLLEXPORT:: ' + i + 'notequals\n') 782 fd.write('!DEC$ ATTRIBUTES DLLEXPORT:: ' + i + 'equals\n') 783 fd.write('#endif\n\n') 784 fd.write(' function ' + i + 'notequals(A,B)\n') 785 fd.write(' logical ' + i + 'notequals\n') 786 fd.write(' type(t' + i + '), intent(in) :: A,B\n') 787 fd.write(' ' + i + 'notequals = (A%v .ne. B%v)\n') 788 fd.write(' end function\n') 789 fd.write(' function ' + i + 'equals(A,B)\n') 790 fd.write(' logical ' + i + 'equals\n') 791 fd.write(' type(t' + i + '), intent(in) :: A,B\n') 792 fd.write(' ' + i + 'equals = (A%v .eq. B%v)\n') 793 fd.write(' end function\n') 794 795 # generate Fortran subroutines for PetscObject methods for each PetscObject subclass (KSP etc) 796 if classes[i].petscobject: 797 ii = i.replace('Petsc', '') 798 fd.write(' function PetscObjectCast' + ii + '(obj)\n') 799 fd.write(' ' + i + ' obj\n') 800 fd.write(' PetscObject PetscObjectCast' + ii + '\n') 801 fd.write(' PetscObjectCast' + ii + '%v = obj%v\n') 802 fd.write(' end function \n') 803 fd.write(' subroutine PetscBarrier' + ii + '(obj,ierr)\n') 804 fd.write(' ' + i + ' obj\n') 805 fd.write(' PetscErrorCode ierr\n') 806 fd.write(' call PetscBarrier(PetscObjectCast(obj),ierr)\n') 807 fd.write(' end subroutine \n') 808 809 for funname in petscobjectfunctions: 810 if funname in ['PetscObjectCompose', 'PetscObjectQuery']: continue 811 fi = petscobjectfunctions[funname] 812 if not fi.arguments or not fi.arguments[0].typename == 'PetscObject': continue 813 814 # cannot generate Fortran functions if any argument is void or PetscCtxRt 815 opaque = False 816 for k in fi.arguments: 817 if k.typename == 'void' or k.typename == 'PetscCtxRt': opaque = True 818 if opaque: continue 819 820 # write the PetscObject class function for the specific object that calls the base function 821 if funname.startswith('PetscObjectSAWs') or funname == 'PetscObjectViewSAWs': 822 fd.write('#if defined(PETSC_HAVE_SAWS)\n') 823 fd.write(' subroutine ' + funname + ii + '(') 824 cnt = 0 825 for k in fi.arguments: 826 if k.stringlen: continue 827 if cnt: fd.write(', ') 828 fd.write(k.name) 829 cnt = cnt + 1 830 fd.write(', ierr)\n') 831 fd.write(' ' + i + ' ' + fi.arguments[0].name + '\n') 832 cnt = 1 833 for k in fi.arguments[1:]: 834 if k.stringlen: continue 835 ktypename = k.typename.replace('MPI_', 'MPIU_').replace('MPIU_Fint', 'MPI_Fint') 836 if ktypename in CToFortranTypes: 837 ktypename = CToFortranTypes[ktypename] 838 if ktypename in senumsext: 839 fd.write(' character(*) :: ' + k.name + '\n') 840 elif ktypename == 'char': 841 if k.char_type != 'single': 842 fd.write(' character(*) :: ' + k.name + '\n') 843 elif k.char_type == 'single': 844 fd.write(' character(len=1) :: ' + k.name + '\n') 845 elif k.array and k.stars: 846 fd.write(' ' + ktypename + ', pointer :: ' + k.name + '(:)\n') 847 elif k.array: 848 fd.write(' ' + ktypename + ' :: ' + k.name + '(*)\n') 849 elif ktypename == 'PetscCtx': 850 fd.write(' type(*) :: ' + k.name + '\n') 851 else: 852 fd.write(' ' + ktypename + ' :: ' + k.name + '\n') 853 cnt = cnt + 1 854 fd.write(' PetscErrorCode ierr\n') 855 fd.write(' call ' + funname + '(PetscObjectCast(') 856 cnt = 0 857 for k in fi.arguments: 858 if k.stringlen: continue 859 if cnt: fd.write(', ') 860 fd.write(k.name) 861 if cnt == 0: fd.write(')') 862 cnt = cnt + 1 863 fd.write(', ierr)\n') 864 fd.write(' end subroutine \n') 865 if funname.startswith('PetscObjectSAWs') or funname == 'PetscObjectViewSAWs': 866 fd.write('#endif\n') 867 868 # generate .eq. and .neq. for enums 869 for i in enums.keys(): 870 if i in ['PetscEnum', 'PetscBool3']: continue 871 with open(os.path.join(petscarch,'ftn',getAPI.mansecpath(enums[i].mansec),enums[i].includefile + 'f90'),"a") as fd: 872 873 fd.write('#if defined(_WIN32) && defined(PETSC_USE_SHARED_LIBRARIES)\n') 874 fd.write('!DEC$ ATTRIBUTES DLLEXPORT:: ' + i + 'notequals\n') 875 fd.write('!DEC$ ATTRIBUTES DLLEXPORT:: ' + i + 'equals\n') 876 fd.write('#endif\n\n') 877 fd.write(' function ' + i + 'notequals(A,B)\n') 878 fd.write(' logical ' + i + 'notequals\n') 879 fd.write(' type(e' + i + '), intent(in) :: A,B\n') 880 fd.write(' ' + i + 'notequals = (A%v .ne. B%v)\n') 881 fd.write(' end function\n') 882 fd.write(' function ' + i + 'equals(A,B)\n') 883 fd.write(' logical ' + i + 'equals\n') 884 fd.write(' type(e' + i + '), intent(in) :: A,B\n') 885 fd.write(' ' + i + 'equals = (A%v .eq. B%v)\n') 886 fd.write(' end function\n') 887 888########## $PETSC_ARCH/ftn/MANSEC/**/*f.c 889 890 import re 891 reg = re.compile(r'[-a-zA-Z0-9/._]*: [ ]*#define [ ]*([a-z0-9]*)_ [ ]*[a-z0-9]*') 892 output = check_output('find src -type f -path "*/ftn-custom/*.c" | xargs grep "[ ]*#define [a-z0-9]*_ [ ]*[a-z0-9]*$"', shell=True).decode('utf-8') 893 manualstubsfound = set() 894 for f in output.split('\n'): 895 manualstubsfound.add(reg.sub(r'\1',f)) 896 897 # convert function arguments from MPI_Comm to MPI_Fint 898 for i in funcs: 899 for j in funcs[i].arguments: 900 j.typename = j.typename.replace('MPI_Comm','MPI_Fint') 901 902 for i in classes: 903 for j in classes[i].functions: 904 for k in classes[i].functions[j].arguments: 905 k.typename = k.typename.replace('MPI_Comm','MPI_Fint') 906 907 for i in classes.keys(): 908 if i in ['PetscIntStack']: continue 909 for j in classes[i].functions: # loop over functions in class 910 generateCStub(pkgname,petscarch,manualstubsfound,senumsext,classes,structsext,j,classes[i].functions[j]) 911 912 for j in funcs.keys(): 913 if funcs[j].name in ['SlepcDebugViewMatrix']: continue 914 generateCStub(pkgname,petscarch,manualstubsfound,senumsext,classes,structsext,funcs[j].name,funcs[j]) 915 916########## $PETSC_ARCH/ftn/MANSEC/petscall.* 917 918 # petscall.* contains all the include files associated with C petscMANSEC.h 919 # these are used by src/MANSEC/ftn-mod/petscMANSECmod.F to generate the module for C petscMANSEC.h 920 # src/MANSEC/ftn-mod/petscMANSECmod.F may also define additional modules that use petscMANSEC 921 for i in mansecs.keys(): 922 d = os.path.join(petscarch,'ftn', getAPI.mansecpath(i)) 923 dd = os.path.join('../','ftn', getAPI.mansecpath(i)) 924 args = [os.path.join(d,i) for i in os.listdir(d) if i.endswith('.h')] 925 for j in args: 926 if not os.path.getsize(j): os.path.remove(j) 927 with open(os.path.join(d,pkgname + 'all.h'),'w') as fd, open(os.path.join(d,pkgname + 'all.h90'),'w') as fd90, open(os.path.join(d,pkgname + 'all.hf90'),'w') as fdf90: 928 if not i.startswith(pkgname): f = pkgname + i + '.h' 929 else: f = i + '.h' 930 includes = set() 931 for j in files[f].included: 932 if j in skipinc: continue 933 j = j.replace('types.h','.h') 934 includes.add(j) 935 fd.write('#include <' + os.path.join(('petsc' if j.startswith('petsc') else 'slepc'),'finclude',j) + '>\n') 936 if os.path.isfile(os.path.join(d,j)) : 937 fd.write('#include <' + os.path.join(dd,j) + '>\n') 938 if os.path.isfile(os.path.join(d,j + '90')): 939 fd90.write('#include <' + os.path.join(dd,j + '90') + '>\n') 940 if os.path.isfile(os.path.join(d,j + 'f90')): 941 fdf90.write('#include <' + os.path.join(dd,j + 'f90') + '>\n') 942 if f not in includes: 943 fd.write('#include <' + os.path.join(pkgname,'finclude',f) + '>\n') 944 fd.write('#include <' + os.path.join(dd,f) + '>\n') 945 if os.path.isfile(os.path.join(d,f + '90')): 946 fd90.write('#include <' + os.path.join(dd,f + '90') + '>\n') 947 if os.path.isfile(os.path.join(d,f + 'f90')): 948 fdf90.write('#include <' + os.path.join(dd,f + 'f90') + '>\n') 949 950# 951if __name__ == '__main__': 952 import sys 953 import argparse 954 955 parser = argparse.ArgumentParser(description='generate PETSc/SLEPc FORTRAN stubs', formatter_class=argparse.ArgumentDefaultsHelpFormatter) 956 parser.add_argument('--petsc-dir', metavar='path', required=True, help='PETSc root directory') 957 parser.add_argument('--slepc-dir', metavar='path', required=False, help='SLEPc root directory when generating SLEPc bindings') 958 parser.add_argument('--petsc-arch', metavar='string', required=True, help='PETSc arch name') 959 args = parser.parse_args() 960 961 ret = main(args.petsc_dir, args.slepc_dir, args.petsc_arch) 962 sys.exit(ret) 963