23 #if !defined (octave_f77_fcn_h)
24 #define octave_f77_fcn_h 1
33 #define xSTRINGIZE(x) #x
34 #define STRINGIZE(x) xSTRINGIZE(x)
38 #define F77_XFCN_ERROR(f, F) \
39 (*current_liboctave_error_handler) \
40 ("exception encountered in Fortran subroutine %s", \
41 STRINGIZE (F77_FUNC (f, F)))
51 #define F77_XFCN(f, F, args) \
54 octave_jmp_buf saved_context; \
55 sig_atomic_t saved_octave_interrupt_immediately = octave_interrupt_immediately; \
56 f77_exception_encountered = 0; \
57 octave_save_current_context (saved_context); \
58 if (octave_set_current_context) \
60 octave_interrupt_immediately = saved_octave_interrupt_immediately; \
61 octave_restore_current_context (saved_context); \
62 if (f77_exception_encountered) \
63 F77_XFCN_ERROR (f, F); \
65 octave_rethrow_exception (); \
69 octave_interrupt_immediately++; \
70 F77_FUNC (f, F) args; \
71 octave_interrupt_immediately--; \
72 octave_restore_current_context (saved_context); \
80 #if !defined (F77_FCN)
81 #define F77_FCN(f, F) F77_FUNC (f, F)
135 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
140 #define F77_CHAR_ARG(x) octave_make_cray_ftn_ch_dsc (x, strlen (x))
141 #define F77_CONST_CHAR_ARG(x) \
142 octave_make_cray_const_ftn_ch_dsc (x, strlen (x))
143 #define F77_CHAR_ARG2(x, l) octave_make_cray_ftn_ch_dsc (x, l)
144 #define F77_CONST_CHAR_ARG2(x, l) octave_make_cray_const_ftn_ch_dsc (x, l)
145 #define F77_CXX_STRING_ARG(x) \
146 octave_make_cray_const_ftn_ch_dsc (x.c_str (), x.length ())
147 #define F77_CHAR_ARG_LEN(l)
148 #define F77_CHAR_ARG_DECL octave_cray_ftn_ch_dsc
149 #define F77_CONST_CHAR_ARG_DECL octave_cray_ftn_ch_dsc
150 #define F77_CHAR_ARG_LEN_DECL
154 #define F77_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s
155 #define F77_CONST_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s
156 #define F77_CHAR_ARG_LEN_DEF(len)
157 #define F77_CHAR_ARG_USE(s) s.ptr
158 #define F77_CHAR_ARG_LEN_USE(s, len) (s.mask.len>>3)
162 #define F77_RET_T int
168 #define F77_RETURN(retval) return retval;
169 #if defined (HAVE_ATTR_NORETURN)
170 #define F77_NORETURN(retval)
172 #define F77_NORETURN(retval) return retval;
180 const char *const_ptr;
188 } octave_cray_descriptor;
190 typedef void *octave_cray_ftn_ch_dsc;
193 #define OCTAVE_F77_FCN_INLINE inline
195 #define OCTAVE_F77_FCN_INLINE
198 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc
199 octave_make_cray_ftn_ch_dsc (
char *ptr_arg,
unsigned long len_arg)
201 octave_cray_descriptor desc;
203 desc.mask.len = len_arg << 3;
204 return *((octave_cray_ftn_ch_dsc *) &desc);
207 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc
208 octave_make_cray_const_ftn_ch_dsc (
const char *ptr_arg,
unsigned long len_arg)
210 octave_cray_descriptor desc;
211 desc.const_ptr = ptr_arg;
212 desc.mask.len = len_arg << 3;
213 return *((octave_cray_ftn_ch_dsc *) &desc);
217 #undef OCTAVE_F77_FCN_INLINE
220 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION)
223 #define F77_CHAR_ARG(x) x, strlen (x)
224 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
225 #define F77_CHAR_ARG2(x, l) x, l
226 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l)
227 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ())
228 #define F77_CHAR_ARG_LEN(l)
229 #define F77_CHAR_ARG_DECL char *, int
230 #define F77_CONST_CHAR_ARG_DECL const char *, int
231 #define F77_CHAR_ARG_LEN_DECL
233 #define F77_CHAR_ARG_DEF(s, len) char *s, int len
234 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s, int len
235 #define F77_CHAR_ARG_LEN_DEF(len)
236 #define F77_CHAR_ARG_USE(s) s
237 #define F77_CHAR_ARG_LEN_USE(s, len) len
239 #define F77_RET_T void
241 #define F77_RETURN(retval) return;
242 #define F77_NORETURN(retval)
248 #define F77_CHAR_ARG(x) x
249 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
250 #define F77_CHAR_ARG2(x, l) x
251 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l)
252 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ())
253 #define F77_CHAR_ARG_LEN(l) , l
254 #define F77_CHAR_ARG_DECL char *
255 #define F77_CONST_CHAR_ARG_DECL const char *
256 #define F77_CHAR_ARG_LEN_DECL , long
258 #define F77_CHAR_ARG_DEF(s, len) char *s
259 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s
260 #define F77_CHAR_ARG_LEN_DEF(len) , long len
261 #define F77_CHAR_ARG_USE(s) s
262 #define F77_CHAR_ARG_LEN_USE(s, len) len
264 #define F77_RET_T int
266 #define F77_RETURN(retval) return retval;
267 #if defined (HAVE_ATTR_NORETURN)
268 #define F77_NORETURN(retval)
270 #define F77_NORETURN(retval) return retval;
281 #define F77_CSTRING(s, len, cs) \
282 OCTAVE_LOCAL_BUFFER (char, cs, F77_CHAR_ARG_LEN_USE (s, len) + 1); \
283 memcpy (cs, F77_CHAR_ARG_USE (s), F77_CHAR_ARG_LEN_USE (s, len)); \
284 cs[F77_CHAR_ARG_LEN_USE(s, len)] = '\0'
CRUFT_API int F77_FUNC(xstopx, XSTOPX)(const char *
CRUFT_API int f77_exception_encountered
CRUFT_API int long GCC_ATTR_NORETURN
#define F77_CONST_CHAR_ARG_DECL
#define F77_CHAR_ARG_LEN_DECL