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

 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

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: }