23 #if ! defined (octave_f77_fcn_h)
24 #define octave_f77_fcn_h 1
26 #include "octave-config.h"
30 #if defined (__cplusplus)
35 #define xSTRINGIZE(x) #x
36 #define STRINGIZE(x) xSTRINGIZE(x)
40 #define F77_XFCN_ERROR(f, F) \
41 (*current_liboctave_error_handler) \
42 ("exception encountered in Fortran subroutine %s", \
43 STRINGIZE (F77_FUNC (f, F)))
52 #define F77_XFCN(f, F, args) \
55 octave_jmp_buf saved_context; \
56 sig_atomic_t saved_octave_interrupt_immediately = octave_interrupt_immediately; \
57 f77_exception_encountered = 0; \
58 octave_save_current_context (saved_context); \
59 if (octave_set_current_context) \
61 octave_interrupt_immediately = saved_octave_interrupt_immediately; \
62 octave_restore_current_context (saved_context); \
63 if (f77_exception_encountered) \
64 F77_XFCN_ERROR (f, F); \
66 octave_rethrow_exception (); \
70 octave_interrupt_immediately++; \
71 F77_FUNC (f, F) args; \
72 octave_interrupt_immediately--; \
73 octave_restore_current_context (saved_context); \
81 #if ! defined (F77_FCN)
82 #define F77_FCN(f, F) F77_FUNC (f, F)
140 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
148 #define F77_CHAR_ARG(x) octave_make_cray_ftn_ch_dsc (x, strlen (x))
149 #define F77_CONST_CHAR_ARG(x) \
150 octave_make_cray_const_ftn_ch_dsc (x, strlen (x))
151 #define F77_CHAR_ARG2(x, l) octave_make_cray_ftn_ch_dsc (x, l)
152 #define F77_CONST_CHAR_ARG2(x, l) octave_make_cray_const_ftn_ch_dsc (x, l)
153 #define F77_CXX_STRING_ARG(x) \
154 octave_make_cray_const_ftn_ch_dsc (x.c_str (), x.length ())
155 #define F77_CHAR_ARG_LEN(l)
156 #define F77_CHAR_ARG_LEN_TYPE
157 #define F77_CHAR_ARG_LEN_DECL
158 #define F77_CHAR_ARG_DECL octave_cray_ftn_ch_dsc
159 #define F77_CONST_CHAR_ARG_DECL octave_cray_ftn_ch_dsc
163 #define F77_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s
164 #define F77_CONST_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s
165 #define F77_CHAR_ARG_LEN_DEF(len)
166 #define F77_CHAR_ARG_USE(s) s.ptr
167 #define F77_CHAR_ARG_LEN_USE(s, len) (s.mask.len >> 3)
169 #define F77_RET_T int
176 #define F77_RETURN(retval) return retval;
177 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
178 # define F77_NORETURN(retval)
180 # define F77_NORETURN(retval) return retval;
188 const char *const_ptr;
196 } octave_cray_descriptor;
198 typedef void *octave_cray_ftn_ch_dsc;
200 #if defined (__cplusplus)
201 # define OCTAVE_F77_FCN_INLINE inline
203 # define OCTAVE_F77_FCN_INLINE
206 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc
207 octave_make_cray_ftn_ch_dsc (
char *ptr_arg,
unsigned long len_arg)
209 octave_cray_descriptor desc;
211 desc.mask.len = len_arg << 3;
212 return *((octave_cray_ftn_ch_dsc *) &desc);
215 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc
216 octave_make_cray_const_ftn_ch_dsc (
const char *ptr_arg,
unsigned long len_arg)
218 octave_cray_descriptor desc;
219 desc.const_ptr = ptr_arg;
220 desc.mask.len = len_arg << 3;
221 return *((octave_cray_ftn_ch_dsc *) &desc);
224 #undef OCTAVE_F77_FCN_INLINE
226 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION)
232 #define F77_CHAR_ARG(x) x, strlen (x)
233 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
234 #define F77_CHAR_ARG2(x, l) x, l
235 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l)
236 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ())
237 #define F77_CHAR_ARG_LEN(l)
238 #define F77_CHAR_ARG_LEN_TYPE int
239 #define F77_CHAR_ARG_LEN_DECL
240 #define F77_CHAR_ARG_DECL char *, F77_CHAR_ARG_LEN_TYPE
241 #define F77_CONST_CHAR_ARG_DECL const char *, F77_CHAR_ARG_LEN_TYPE
243 #define F77_CHAR_ARG_DEF(s, len) char *s, F77_CHAR_ARG_LEN_TYPE len
244 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s, F77_CHAR_ARG_LEN_TYPE len
245 #define F77_CHAR_ARG_LEN_DEF(len)
246 #define F77_CHAR_ARG_USE(s) s
247 #define F77_CHAR_ARG_LEN_USE(s, len) len
249 #define F77_RET_T void
251 #define F77_RETURN(retval) return;
252 #define F77_NORETURN(retval)
254 #elif defined (F77_USES_GFORTRAN_CALLING_CONVENTION)
266 #define F77_CHAR_ARG(x) x
267 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
268 #define F77_CHAR_ARG2(x, l) x
269 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l)
270 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ())
271 #define F77_CHAR_ARG_LEN(l) , l
272 #define F77_CHAR_ARG_LEN_TYPE int
273 #define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE
274 #define F77_CHAR_ARG_DECL char *
275 #define F77_CONST_CHAR_ARG_DECL const char *
277 #define F77_CHAR_ARG_DEF(s, len) char *s
278 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s
279 #define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len
280 #define F77_CHAR_ARG_USE(s) s
281 #define F77_CHAR_ARG_LEN_USE(s, len) len
283 #define F77_RET_T void
285 #define F77_RETURN(retval) return;
286 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
287 # define F77_NORETURN(retval)
289 # define F77_NORETURN(retval) return retval;
292 #elif defined (F77_USES_F2C_CALLING_CONVENTION)
299 #define F77_CHAR_ARG(x) x
300 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
301 #define F77_CHAR_ARG2(x, l) x
302 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l)
303 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ())
304 #define F77_CHAR_ARG_LEN(l) , l
305 #define F77_CHAR_ARG_LEN_TYPE long
306 #define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE
307 #define F77_CHAR_ARG_DECL char *
308 #define F77_CONST_CHAR_ARG_DECL const char *
310 #define F77_CHAR_ARG_DEF(s, len) char *s
311 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s
312 #define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len
313 #define F77_CHAR_ARG_USE(s) s
314 #define F77_CHAR_ARG_LEN_USE(s, len) len
316 #define F77_RET_T int
318 #define F77_RETURN(retval) return retval;
319 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
320 # define F77_NORETURN(retval)
322 # define F77_NORETURN(retval) return retval;
327 #error "unknown C++ to Fortran calling convention"
331 #define F77_DBLE double
332 #define F77_REAL float
333 #define F77_DBLE_CMPLX double _Complex
334 #define F77_CMPLX float _Complex
335 #define F77_INT octave_idx_type
336 #define F77_INT4 int32_t
337 #define F77_LOGICAL octave_idx_type
339 #define F77_CMPLX_ARG(x) \
340 reinterpret_cast<float _Complex *> (x)
342 #define F77_CONST_CMPLX_ARG(x) \
343 reinterpret_cast<const float _Complex *> (x)
345 #define F77_DBLE_CMPLX_ARG(x) \
346 reinterpret_cast<double _Complex *> (x)
348 #define F77_CONST_DBLE_CMPLX_ARG(x) \
349 reinterpret_cast<const double _Complex *> (x)
356 #define F77_CSTRING(s, len, cs) \
357 OCTAVE_LOCAL_BUFFER (char, cs, F77_CHAR_ARG_LEN_USE (s, len) + 1); \
358 memcpy (cs, F77_CHAR_ARG_USE (s), F77_CHAR_ARG_LEN_USE (s, len)); \
359 cs[F77_CHAR_ARG_LEN_USE(s, len)] = '\0'
361 OCTAVE_NORETURN OCTAVE_API
extern
366 #if defined (__cplusplus)
F77_RET_T const F77_INT F77_INT const F77_DBLE F77_DBLE const F77_INT F77_DBLE const F77_INT F77_INT F77_INT F77_DBLE F77_DBLE const F77_INT F77_INT &F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL
F77_RET_T F77_CONST_CHAR_ARG_DECL
OCTAVE_NORETURN OCTAVE_API F77_RET_T F77_FUNC(xstopx, XSTOPX)(F77_CONST_CHAR_ARG_DECL F77_CHAR_ARG_LEN_DECL)
OCTAVE_API int f77_exception_encountered