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