Actual source code: fcallback.c

      1: #include <petsc/private/petscimpl.h>

      3: typedef struct _FortranCallbackLink *FortranCallbackLink;
      4: struct _FortranCallbackLink {
      5:   char                  *type_name;
      6:   PetscFortranCallbackId max;
      7:   FortranCallbackLink    next;
      8: };

     10: typedef struct {
     11:   PetscFortranCallbackId basecount;
     12:   PetscFortranCallbackId maxsubtypecount;
     13:   FortranCallbackLink    subtypes;
     14: } FortranCallbackBase;

     16: static FortranCallbackBase *_classbase;
     17: static PetscClassId         _maxclassid = PETSC_SMALLEST_CLASSID;

     19: static PetscErrorCode PetscFortranCallbackFinalize(void)
     20: {
     21:   PetscFunctionBegin;
     22:   for (PetscInt i = PETSC_SMALLEST_CLASSID; i < _maxclassid; i++) {
     23:     FortranCallbackBase *base = &_classbase[i - PETSC_SMALLEST_CLASSID];
     24:     FortranCallbackLink  next, link = base->subtypes;
     25:     for (; link; link = next) {
     26:       next = link->next;
     27:       PetscCall(PetscFree(link->type_name));
     28:       PetscCall(PetscFree(link));
     29:     }
     30:   }
     31:   PetscCall(PetscFree(_classbase));
     32:   _maxclassid = PETSC_SMALLEST_CLASSID;
     33:   PetscFunctionReturn(PETSC_SUCCESS);
     34: }

     36: /*@C
     37:   PetscFortranCallbackRegister - register a type+subtype callback. This is used by the PETSc Fortran stubs to allow the use of user Fortran functions
     38:   as arguments to PETSc functions that take function pointers

     40:   Not Collective, No Fortran Support

     42:   Input Parameters:
     43: + classid - ID of class on which to register callback
     44: - subtype - subtype string, or `NULL` for class ids

     46:   Output Parameter:
     47: . id - callback id

     49:   Level: developer

     51: .seealso: `PetscFortranCallbackGetSizes()`, `PetscObjectCopyFortranFunctionPointers()`, `PetscObjectSetFortranCallback()`, `PetscObjectGetFortranCallback()`
     52: @*/
     53: PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid, const char *subtype, PetscFortranCallbackId *id)
     54: {
     55:   FortranCallbackBase *base;
     56:   FortranCallbackLink  link;

     58:   PetscFunctionBegin;
     59:   if (subtype) PetscAssertPointer(subtype, 2);
     60:   PetscAssertPointer(id, 3);
     61:   PetscCheck(classid >= PETSC_SMALLEST_CLASSID && classid <= PETSC_LARGEST_CLASSID, PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "ClassId %d corrupt", classid);
     62:   *id = 0;
     63:   if (classid >= _maxclassid) {
     64:     PetscClassId         newmax = PETSC_SMALLEST_CLASSID + 2 * (PETSC_LARGEST_CLASSID - PETSC_SMALLEST_CLASSID);
     65:     FortranCallbackBase *newbase;
     66:     if (!_classbase) PetscCall(PetscRegisterFinalize(PetscFortranCallbackFinalize));
     67:     PetscCall(PetscCalloc1(newmax - PETSC_SMALLEST_CLASSID, &newbase));
     68:     PetscCall(PetscArraycpy(newbase, _classbase, _maxclassid - PETSC_SMALLEST_CLASSID));
     69:     PetscCall(PetscFree(_classbase));

     71:     _classbase  = newbase;
     72:     _maxclassid = newmax;
     73:   }
     74:   base = &_classbase[classid - PETSC_SMALLEST_CLASSID];
     75:   if (!subtype) *id = PETSC_SMALLEST_FORTRAN_CALLBACK + base->basecount++;
     76:   else {
     77:     for (link = base->subtypes; link; link = link->next) { /* look for either both NULL or matching values (implies both non-NULL) */
     78:       PetscBool match;
     79:       PetscCall(PetscStrcmp(subtype, link->type_name, &match));
     80:       if (match) { /* base type or matching subtype */
     81:         goto found;
     82:       }
     83:     }
     84:     /* Not found. Create node and prepend to class' subtype list */
     85:     PetscCall(PetscNew(&link));
     86:     PetscCall(PetscStrallocpy(subtype, &link->type_name));

     88:     link->max      = PETSC_SMALLEST_FORTRAN_CALLBACK;
     89:     link->next     = base->subtypes;
     90:     base->subtypes = link;

     92:   found:
     93:     *id = link->max++;

     95:     base->maxsubtypecount = PetscMax(base->maxsubtypecount, link->max - PETSC_SMALLEST_FORTRAN_CALLBACK);
     96:   }
     97:   PetscFunctionReturn(PETSC_SUCCESS);
     98: }

    100: /*@C
    101:   PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays

    103:   Collective, No Fortran Support

    105:   Input Parameter:
    106: . classid - class Id

    108:   Output Parameters:
    109: + numbase    - number of registered class callbacks
    110: - numsubtype - max number of registered subtype callbacks

    112:   Level: developer

    114: .seealso: `PetscFortranCallbackRegister()`, `PetscObjectCopyFortranFunctionPointers()`, `PetscObjectSetFortranCallback()`, `PetscObjectGetFortranCallback()`
    115: @*/
    116: PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid, PetscFortranCallbackId *numbase, PetscFortranCallbackId *numsubtype)
    117: {
    118:   PetscFunctionBegin;
    119:   PetscAssertPointer(numbase, 2);
    120:   PetscAssertPointer(numsubtype, 3);
    121:   if (classid < _maxclassid) {
    122:     FortranCallbackBase *base = &_classbase[classid - PETSC_SMALLEST_CLASSID];
    123:     *numbase                  = base->basecount;
    124:     *numsubtype               = base->maxsubtypecount;
    125:   } else { /* nothing registered */
    126:     *numbase    = 0;
    127:     *numsubtype = 0;
    128:   }
    129:   PetscFunctionReturn(PETSC_SUCCESS);
    130: }