1 #include <petsc/private/petscimpl.h> /*I "petscsys.h" I*/
2
3 typedef struct _FortranCallbackLink *FortranCallbackLink;
4 struct _FortranCallbackLink {
5 char *type_name;
6 PetscFortranCallbackId max;
7 FortranCallbackLink next;
8 };
9
10 typedef struct {
11 PetscFortranCallbackId basecount;
12 PetscFortranCallbackId maxsubtypecount;
13 FortranCallbackLink subtypes;
14 } FortranCallbackBase;
15
16 static FortranCallbackBase *_classbase;
17 static PetscClassId _maxclassid = PETSC_SMALLEST_CLASSID;
18
PetscFortranCallbackFinalize(void)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 }
35
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
39
40 Not Collective, No Fortran Support
41
42 Input Parameters:
43 + classid - ID of class on which to register callback
44 - subtype - subtype string, or `NULL` for class ids
45
46 Output Parameter:
47 . id - callback id
48
49 Level: developer
50
51 .seealso: `PetscFortranCallbackGetSizes()`, `PetscObjectCopyFortranFunctionPointers()`, `PetscObjectSetFortranCallback()`, `PetscObjectGetFortranCallback()`
52 @*/
PetscFortranCallbackRegister(PetscClassId classid,const char * subtype,PetscFortranCallbackId * id)53 PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid, const char *subtype, PetscFortranCallbackId *id)
54 {
55 FortranCallbackBase *base;
56 FortranCallbackLink link;
57
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));
70
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));
87
88 link->max = PETSC_SMALLEST_FORTRAN_CALLBACK;
89 link->next = base->subtypes;
90 base->subtypes = link;
91
92 found:
93 *id = link->max++;
94
95 base->maxsubtypecount = PetscMax(base->maxsubtypecount, link->max - PETSC_SMALLEST_FORTRAN_CALLBACK);
96 }
97 PetscFunctionReturn(PETSC_SUCCESS);
98 }
99
100 /*@C
101 PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays
102
103 Collective, No Fortran Support
104
105 Input Parameter:
106 . classid - class Id
107
108 Output Parameters:
109 + numbase - number of registered class callbacks
110 - numsubtype - max number of registered subtype callbacks
111
112 Level: developer
113
114 .seealso: `PetscFortranCallbackRegister()`, `PetscObjectCopyFortranFunctionPointers()`, `PetscObjectSetFortranCallback()`, `PetscObjectGetFortranCallback()`
115 @*/
PetscFortranCallbackGetSizes(PetscClassId classid,PetscFortranCallbackId * numbase,PetscFortranCallbackId * numsubtype)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 }
131