GNU Octave  4.2.1
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Properties Friends Macros Pages
f77-fcn.h
Go to the documentation of this file.
1 /*
2 
3 Copyright (C) 1996-2017 John W. Eaton
4 
5 This file is part of Octave.
6 
7 Octave is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 3 of the License, or (at your
10 option) any later version.
11 
12 Octave is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16 
17 You should have received a copy of the GNU General Public License
18 along with Octave; see the file COPYING. If not, see
19 <http://www.gnu.org/licenses/>.
20 
21 */
22 
23 #if ! defined (octave_f77_fcn_h)
24 #define octave_f77_fcn_h 1
25 
26 #include "octave-config.h"
27 
28 #include "quit.h"
29 
30 #if defined (__cplusplus)
31 extern "C" {
32 #endif
33 
34 /* Hack to stringize macro results. */
35 #define xSTRINGIZE(x) #x
36 #define STRINGIZE(x) xSTRINGIZE(x)
37 
38 /* How to print an error for the F77_XFCN macro. */
39 
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)))
44 
45 /* This can be used to call a Fortran subroutine that might call
46  XSTOPX. XSTOPX will call lonjmp with current_context. Once back
47  here, we'll restore the previous context and return. We may also
48  end up here if an interrupt is processed when the Fortran
49  subroutine is called. In that case, we resotre the context and go
50  to the top level. */
51 
52 #define F77_XFCN(f, F, args) \
53  do \
54  { \
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) \
60  { \
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); \
65  else \
66  octave_rethrow_exception (); \
67  } \
68  else \
69  { \
70  octave_interrupt_immediately++; \
71  F77_FUNC (f, F) args; \
72  octave_interrupt_immediately--; \
73  octave_restore_current_context (saved_context); \
74  } \
75  } \
76  while (0)
77 
78 /* So we can check to see if an exception has occurred. */
79 OCTAVE_API extern int f77_exception_encountered;
80 
81 #if ! defined (F77_FCN)
82 #define F77_FCN(f, F) F77_FUNC (f, F)
83 #endif
84 
85 /*
86 
87 The following macros are used for handling Fortran <-> C calling
88 conventions. They are defined below for three different types of
89 systems, Cray (possibly now obsolete), Visual Fortran, and gfortran.
90 Note that we don't attempt to handle Fortran functions, we always use
91 subroutine wrappers for them and pass the return value as an extra
92 argument.
93 
94 Use these macros to pass character strings from C to Fortran:
95 
96  F77_CHAR_ARG(x)
97  F77_CONST_CHAR_ARG(x)
98  F77_CXX_STRING_ARG(x)
99  F77_CHAR_ARG_LEN(l)
100  F77_CHAR_ARG_DECL
101  F77_CONST_CHAR_ARG_DECL
102  F77_CHAR_ARG_LEN_DECL
103 
104 Use these macros to write C-language functions that accept
105 Fortran-style character strings:
106 
107  F77_CHAR_ARG_DEF(s, len)
108  F77_CONST_CHAR_ARG_DEF(s, len)
109  F77_CHAR_ARG_LEN_DEF(len)
110  F77_CHAR_ARG_USE(s)
111  F77_CHAR_ARG_LEN_USE(s, len)
112 
113 Use these macros for C++ code
114 
115  F77_INT Equivalent to Fortran INTEGER type
116  F77_INT4 Equivalent to Fortran INTEGER*4 type
117  F77_DBLE Equivalent to Fortran DOUBLE PRECISION type
118  F77_REAL Equivalent to Fortran REAL type
119  F77_CMPLX Equivalent to Fortran COMPLEX type
120  F77_DBLE_CMPLX Equivalent to Fortran DOUBLE COMPLEX type
121  F77_LOGICAL Equivalent to Fortran LOGICAL type
122  F77_RET_T Return type of a C++ function that acts like a
123  Fortran subroutine.
124 
125 Use these macros to return from C-language functions that are supposed
126 to act like Fortran subroutines. F77_NORETURN is intended to be used
127 as the last statement of such a function that has been tagged with a
128 "noreturn" attribute. If the compiler supports the "noreturn"
129 attribute or if F77_RET_T is void, then it should expand to nothing so
130 that we avoid warnings about functions tagged as "noreturn"
131 containing a return statement. Otherwise, it should expand to a
132 statement that returns the given value so that we avoid warnings about
133 not returning a value from a function declared to return something.
134 
135  F77_RETURN(retval)
136  F77_NORETURN(retval)
137 
138 */
139 
140 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
141 
142 #include <fortran.h>
143 
144 /* Use these macros to pass character strings from C to Fortran. Cray
145  Fortran uses a descriptor structure to pass a pointer to the string
146  and the length in a single argument. */
147 
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
160 
161 /* Use these macros to write C-language functions that accept
162  Fortran-style character strings. */
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)
168 
169 #define F77_RET_T int
170 
171 /* Use these macros to return from C-language functions that are
172  supposed to act like Fortran subroutines. F77_NORETURN is intended
173  to be used as the last statement of such a function that has been
174  tagged with a "noreturn" attribute. */
175 
176 #define F77_RETURN(retval) return retval;
177 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
178 # define F77_NORETURN(retval)
179 #else
180 # define F77_NORETURN(retval) return retval;
181 #endif
182 
183 /* FIXME: These should work for SV1 or Y-MP systems but will
184  need to be changed for others. */
185 
186 typedef union
187 {
188  const char *const_ptr;
189  char *ptr;
190  struct
191  {
192  unsigned off : 6;
193  unsigned len : 26;
194  unsigned add : 32;
195  } mask;
196 } octave_cray_descriptor;
197 
198 typedef void *octave_cray_ftn_ch_dsc;
199 
200  #if defined (__cplusplus)
201 # define OCTAVE_F77_FCN_INLINE inline
202 #else
203 # define OCTAVE_F77_FCN_INLINE
204 #endif
205 
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)
208 {
209  octave_cray_descriptor desc;
210  desc.ptr = ptr_arg;
211  desc.mask.len = len_arg << 3;
212  return *((octave_cray_ftn_ch_dsc *) &desc);
213 }
214 
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)
217 {
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);
222 }
223 
224 #undef OCTAVE_F77_FCN_INLINE
225 
226 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION)
227 
228 /* Use these macros to pass character strings from C to Fortran.
229  Visual Fortran inserts the length after each character string
230  argument. */
231 
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
242 
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
248 
249 #define F77_RET_T void
250 
251 #define F77_RETURN(retval) return;
252 #define F77_NORETURN(retval)
253 
254 #elif defined (F77_USES_GFORTRAN_CALLING_CONVENTION)
255 
256 /* Use these macros to pass character strings from C to Fortran.
257  gfortran appends length arguments for assumed size character
258  strings to the and ignores others.
259 
260  FIXME: I don't think we correctly handle the case of mixing some
261  fixed-length and some assumed-length character string arguments as
262  we don't handle each case separately, so it seems there could be
263  mismatch? However, I don't think we currently have to handle this
264  case in Octave. */
265 
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 *
276 
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
282 
283 #define F77_RET_T void
284 
285 #define F77_RETURN(retval) return;
286 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
287 # define F77_NORETURN(retval)
288 #else
289 # define F77_NORETURN(retval) return retval;
290 #endif
291 
292 #elif defined (F77_USES_F2C_CALLING_CONVENTION)
293 
294 /* Assume f2c-compatible calling convention. */
295 
296 /* Use these macros to pass character strings from C to Fortran. f2c
297  appends all length arguments at the end of the parameter list. */
298 
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 *
309 
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
315 
316 #define F77_RET_T int
317 
318 #define F77_RETURN(retval) return retval;
319 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
320 # define F77_NORETURN(retval)
321 #else
322 # define F77_NORETURN(retval) return retval;
323 #endif
324 
325 #else
326 
327 #error "unknown C++ to Fortran calling convention"
328 
329 #endif
330 
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
338 
339 #define F77_CMPLX_ARG(x) \
340  reinterpret_cast<float _Complex *> (x)
341 
342 #define F77_CONST_CMPLX_ARG(x) \
343  reinterpret_cast<const float _Complex *> (x)
344 
345 #define F77_DBLE_CMPLX_ARG(x) \
346  reinterpret_cast<double _Complex *> (x)
347 
348 #define F77_CONST_DBLE_CMPLX_ARG(x) \
349  reinterpret_cast<const double _Complex *> (x)
350 
351 /* Build a C string local variable CS from the Fortran string parameter S
352  declared as F77_CHAR_ARG_DEF(s, len) or F77_CONST_CHAR_ARG_DEF(s, len).
353  The string will be cleaned up at the end of the current block.
354  Needs to include <cstring> and <vector>. */
355 
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'
360 
361 OCTAVE_NORETURN OCTAVE_API extern
362 F77_RET_T
363 F77_FUNC (xstopx, XSTOPX) (F77_CONST_CHAR_ARG_DECL
365 
366 #if defined (__cplusplus)
367 }
368 #endif
369 
370 #endif
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
Definition: f77-extern.cc:35