Actual source code: fortranimpl.h
1: /* This file contains info for the use of PETSc Fortran interface stubs */
2: #pragma once
4: #include <petsc/private/petscimpl.h>
5: PETSC_INTERN PetscErrorCode PETScParseFortranArgs_Private(int *, char ***);
6: PETSC_EXTERN PetscErrorCode PetscMPIFortranDatatypeToC(MPI_Fint, MPI_Datatype *);
8: PETSC_EXTERN PetscErrorCode PetscScalarAddressToFortran(PetscObject, PetscInt, PetscScalar *, PetscScalar *, PetscInt, size_t *);
9: PETSC_EXTERN PetscErrorCode PetscScalarAddressFromFortran(PetscObject, PetscScalar *, size_t, PetscInt, PetscScalar **);
10: PETSC_EXTERN size_t PetscIntAddressToFortran(const PetscInt *, const PetscInt *);
11: PETSC_EXTERN PetscInt *PetscIntAddressFromFortran(const PetscInt *, size_t);
12: PETSC_EXTERN char *PETSC_NULL_CHARACTER_Fortran;
13: PETSC_EXTERN void *PETSC_NULL_INTEGER_Fortran;
14: PETSC_EXTERN void *PETSC_NULL_SCALAR_Fortran;
15: PETSC_EXTERN void *PETSC_NULL_DOUBLE_Fortran;
16: PETSC_EXTERN void *PETSC_NULL_REAL_Fortran;
17: PETSC_EXTERN void *PETSC_NULL_BOOL_Fortran;
18: PETSC_EXTERN void (*PETSC_NULL_FUNCTION_Fortran)(void);
19: PETSC_EXTERN void *PETSC_NULL_MPI_COMM_Fortran;
21: PETSC_INTERN PetscErrorCode PetscInitFortran_Private(PetscBool, const char *, PetscInt);
23: /* ----------------------------------------------------------------------*/
24: /*
25: PETSc object C pointers are stored directly as
26: Fortran integer*4 or *8 depending on the size of pointers.
27: */
29: /* --------------------------------------------------------------------*/
30: /*
31: Since Fortran does not null terminate strings we need to insure the string is null terminated before passing it
32: to C. This may require a memory allocation which is then freed with FREECHAR().
33: */
34: #define FIXCHAR(a, n, b) \
35: do { \
36: if ((a) == PETSC_NULL_CHARACTER_Fortran) { \
37: (b) = (a) = NULL; \
38: } else { \
39: while (((n) > 0) && ((a)[(n)-1] == ' ')) (n)--; \
40: *ierr = PetscMalloc1((n) + 1, &(b)); \
41: if (*ierr) return; \
42: *ierr = PetscMemcpy((b), (a), (n)); \
43: (b)[n] = '\0'; \
44: if (*ierr) return; \
45: } \
46: } while (0)
47: #define FREECHAR(a, b) \
48: do { \
49: if (a != b) *ierr = PetscFree(b); \
50: } while (0)
52: /*
53: Fortran expects any unneeded characters at the end of its strings to be filled with the blank character.
54: */
55: #define FIXRETURNCHAR(flg, a, n) \
56: do { \
57: if (flg) { \
58: PETSC_FORTRAN_CHARLEN_T __i; \
59: for (__i = 0; __i < n && a[__i] != 0; __i++) { }; \
60: for (; __i < n; __i++) a[__i] = ' '; \
61: } \
62: } while (0)
64: /*
65: The cast through PETSC_UINTPTR_T is so that compilers that warn about casting to/from void * to void(*)(void)
66: will not complain about these comparisons. It is not know if this works for all compilers
67: */
68: #define FORTRANNULLINTEGER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_INTEGER_Fortran)
69: #define FORTRANNULLSCALAR(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_SCALAR_Fortran)
70: #define FORTRANNULLDOUBLE(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_DOUBLE_Fortran)
71: #define FORTRANNULLREAL(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_REAL_Fortran)
72: #define FORTRANNULLBOOL(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_BOOL_Fortran)
73: #define FORTRANNULLCHARACTER(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_CHARACTER_Fortran)
74: #define FORTRANNULLFUNCTION(a) (((void (*)(void))(PETSC_UINTPTR_T)a) == PETSC_NULL_FUNCTION_Fortran)
75: #define FORTRANNULLOBJECT(a) (*(void **)(PETSC_UINTPTR_T)a == (void *)0)
76: #define FORTRANNULLMPICOMM(a) (((void *)(PETSC_UINTPTR_T)a) == PETSC_NULL_MPI_COMM_Fortran)
78: #define CHKFORTRANNULLINTEGER(a) \
79: do { \
80: if (FORTRANNULLINTEGER(a)) { \
81: a = NULL; \
82: } else if (FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
83: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_INTEGER"); \
84: *ierr = PETSC_ERR_ARG_BADPTR; \
85: return; \
86: } \
87: } while (0)
89: #define CHKFORTRANNULLSCALAR(a) \
90: do { \
91: if (FORTRANNULLSCALAR(a)) { \
92: a = NULL; \
93: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
94: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_SCALAR"); \
95: *ierr = PETSC_ERR_ARG_BADPTR; \
96: return; \
97: } \
98: } while (0)
100: #define CHKFORTRANNULLDOUBLE(a) \
101: do { \
102: if (FORTRANNULLDOUBLE(a)) { \
103: a = NULL; \
104: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
105: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_DOUBLE"); \
106: *ierr = PETSC_ERR_ARG_BADPTR; \
107: return; \
108: } \
109: } while (0)
111: #define CHKFORTRANNULLREAL(a) \
112: do { \
113: if (FORTRANNULLREAL(a)) { \
114: a = NULL; \
115: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
116: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_REAL"); \
117: *ierr = PETSC_ERR_ARG_BADPTR; \
118: return; \
119: } \
120: } while (0)
122: #define CHKFORTRANNULLOBJECT(a) \
123: do { \
124: if (*(void **)a == (void *)0) { \
125: a = NULL; \
126: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
127: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_XXX where XXX is the name of a particular object class"); \
128: *ierr = PETSC_ERR_ARG_BADPTR; \
129: return; \
130: } \
131: } while (0)
133: #define CHKFORTRANNULLBOOL(a) \
134: do { \
135: if (FORTRANNULLBOOL(a)) { \
136: a = NULL; \
137: } else if (FORTRANNULLSCALAR(a) || FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
138: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_BOOL"); \
139: *ierr = PETSC_ERR_ARG_BADPTR; \
140: return; \
141: } \
142: } while (0)
144: #define CHKFORTRANNULLFUNCTION(a) \
145: do { \
146: if (FORTRANNULLFUNCTION(a)) { \
147: a = NULL; \
148: } else if (FORTRANNULLOBJECT(a) || FORTRANNULLSCALAR(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLREAL(a) || FORTRANNULLINTEGER(a) || FORTRANNULLBOOL(a) || FORTRANNULLCHARACTER(a) || FORTRANNULLMPICOMM(a)) { \
149: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_FUNCTION"); \
150: *ierr = PETSC_ERR_ARG_BADPTR; \
151: return; \
152: } \
153: } while (0)
155: #define CHKFORTRANNULLMPICOMM(a) \
156: do { \
157: if (FORTRANNULLMPICOMM(a)) { \
158: a = NULL; \
159: } else if (FORTRANNULLINTEGER(a) || FORTRANNULLDOUBLE(a) || FORTRANNULLSCALAR(a) || FORTRANNULLREAL(a) || FORTRANNULLBOOL(a) || FORTRANNULLFUNCTION(a) || FORTRANNULLCHARACTER(a)) { \
160: *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "fortran_interface_unknown_file", __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MPI_COMM"); \
161: *ierr = PETSC_ERR_ARG_BADPTR; \
162: return; \
163: } \
164: } while (0)
166: /* The two macros are used at the beginning and end of PETSc object Fortran destroy routines XxxDestroy(). -2 is in consistent with
167: the one used in checkFortranTypeInitialize() at compilersFortran.py.
168: */
170: /* In the beginning of Fortran XxxDestroy(a), if the input object was destroyed, change it to a petsc C NULL object so that it won't crash C XxxDestory() */
171: #define PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(a) \
172: do { \
173: if (*((void **)(a)) == (void *)-2) *(a) = NULL; \
174: } while (0)
176: /* After C XxxDestroy(a) is called, change a's state from NULL to destroyed, so that it can be used/destroyed again by Fortran.
177: E.g., in VecScatterCreateToAll(x,vscat,seq,ierr), if seq = PETSC_NULL_VEC, petsc won't create seq. But if seq is a
178: destroyed object (e.g., as a result of a previous Fortran VecDestroy), petsc will create seq.
179: */
180: #define PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(a) \
181: do { \
182: *((void **)(a)) = (void *)-2; \
183: } while (0)
185: /*
186: Variable type where we stash PETSc object pointers in Fortran.
187: */
188: typedef PETSC_UINTPTR_T PetscFortranAddr;
190: /*
191: These are used to support the default viewers that are
192: created at run time, in C using the , trick.
194: The numbers here must match the numbers in include/petsc/finclude/petscsys.h
195: */
196: #define PETSC_VIEWER_DRAW_WORLD_FORTRAN 4
197: #define PETSC_VIEWER_DRAW_SELF_FORTRAN 5
198: #define PETSC_VIEWER_SOCKET_WORLD_FORTRAN 6
199: #define PETSC_VIEWER_SOCKET_SELF_FORTRAN 7
200: #define PETSC_VIEWER_STDOUT_WORLD_FORTRAN 8
201: #define PETSC_VIEWER_STDOUT_SELF_FORTRAN 9
202: #define PETSC_VIEWER_STDERR_WORLD_FORTRAN 10
203: #define PETSC_VIEWER_STDERR_SELF_FORTRAN 11
204: #define PETSC_VIEWER_BINARY_WORLD_FORTRAN 12
205: #define PETSC_VIEWER_BINARY_SELF_FORTRAN 13
206: #define PETSC_VIEWER_MATLAB_WORLD_FORTRAN 14
207: #define PETSC_VIEWER_MATLAB_SELF_FORTRAN 15
209: #if defined(PETSC_USE_SOCKET_VIEWER)
210: #define PetscPatchDefaultViewers_Fortran_Socket(vin, v) \
211: } \
212: else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_WORLD_FORTRAN) \
213: { \
214: v = PETSC_VIEWER_SOCKET_WORLD; \
215: } \
216: else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_SOCKET_SELF_FORTRAN) \
217: { \
218: v = PETSC_VIEWER_SOCKET_SELF
219: #else
220: #define PetscPatchDefaultViewers_Fortran_Socket(vin, v)
221: #endif
223: #define PetscPatchDefaultViewers_Fortran(vin, v) \
224: do { \
225: if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_WORLD_FORTRAN) { \
226: v = PETSC_VIEWER_DRAW_WORLD; \
227: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_DRAW_SELF_FORTRAN) { \
228: v = PETSC_VIEWER_DRAW_SELF; \
229: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_WORLD_FORTRAN) { \
230: v = PETSC_VIEWER_STDOUT_WORLD; \
231: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDOUT_SELF_FORTRAN) { \
232: v = PETSC_VIEWER_STDOUT_SELF; \
233: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_WORLD_FORTRAN) { \
234: v = PETSC_VIEWER_STDERR_WORLD; \
235: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_STDERR_SELF_FORTRAN) { \
236: v = PETSC_VIEWER_STDERR_SELF; \
237: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_WORLD_FORTRAN) { \
238: v = PETSC_VIEWER_BINARY_WORLD; \
239: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_BINARY_SELF_FORTRAN) { \
240: v = PETSC_VIEWER_BINARY_SELF; \
241: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_WORLD_FORTRAN) { \
242: v = PETSC_VIEWER_BINARY_WORLD; \
243: } else if ((*(PetscFortranAddr *)vin) == PETSC_VIEWER_MATLAB_SELF_FORTRAN) { \
244: v = PETSC_VIEWER_BINARY_SELF; \
245: PetscPatchDefaultViewers_Fortran_Socket(vin, v); \
246: } else { \
247: v = *vin; \
248: } \
249: } while (0)
251: /*
252: Allocates enough space to store Fortran function pointers in PETSc object
253: that are needed by the Fortran interface.
254: */
255: #define PetscObjectAllocateFortranPointers(obj, N) \
256: do { \
257: if (!((PetscObject)(obj))->fortran_func_pointers) { \
258: *ierr = PetscCalloc((N) * sizeof(void (*)(void)), &((PetscObject)(obj))->fortran_func_pointers); \
259: if (*ierr) return; \
260: ((PetscObject)obj)->num_fortran_func_pointers = (N); \
261: } \
262: } while (0)
264: #define PetscCallFortranVoidFunction(...) \
265: do { \
266: PetscErrorCode ierr = PETSC_SUCCESS; \
267: /* the function may or may not access ierr */ \
268: __VA_ARGS__; \
269: PetscCall(ierr); \
270: } while (0)
272: /* Entire function body, _ctx is a "special" variable that can be passed along */
273: #define PetscObjectUseFortranCallback_Private(obj, cid, types, args, cbclass) \
274: do { \
275: void(*func) types, *_ctx; \
276: PetscFunctionBegin; \
277: PetscCall(PetscObjectGetFortranCallback((PetscObject)(obj), (cbclass), (cid), (PetscVoidFunction *)&func, &_ctx)); \
278: if (func) PetscCallFortranVoidFunction((*func)args); \
279: PetscFunctionReturn(PETSC_SUCCESS); \
280: } while (0)
281: #define PetscObjectUseFortranCallback(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_CLASS)
282: #define PetscObjectUseFortranCallbackSubType(obj, cid, types, args) PetscObjectUseFortranCallback_Private(obj, cid, types, args, PETSC_FORTRAN_CALLBACK_SUBTYPE)
284: /* Disable deprecation warnings while building Fortran wrappers */
285: #undef PETSC_DEPRECATED_OBJECT
286: #define PETSC_DEPRECATED_OBJECT(...)
287: #undef PETSC_DEPRECATED_FUNCTION
288: #define PETSC_DEPRECATED_FUNCTION(...)
289: #undef PETSC_DEPRECATED_ENUM
290: #define PETSC_DEPRECATED_ENUM(...)
291: #undef PETSC_DEPRECATED_TYPEDEF
292: #define PETSC_DEPRECATED_TYPEDEF(...)
293: #undef PETSC_DEPRECATED_MACRO
294: #define PETSC_DEPRECATED_MACRO(...)