GNU Octave  6.2.0
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
f77-fcn.h
Go to the documentation of this file.
1 ////////////////////////////////////////////////////////////////////////
2 //
3 // Copyright (C) 1996-2021 The Octave Project Developers
4 //
5 // See the file COPYRIGHT.md in the top-level directory of this
6 // distribution or <https://octave.org/copyright/>.
7 //
8 // This file is part of Octave.
9 //
10 // Octave is free software: you can redistribute it and/or modify it
11 // under the terms of the GNU General Public License as published by
12 // the Free Software Foundation, either version 3 of the License, or
13 // (at your option) any later version.
14 //
15 // Octave is distributed in the hope that it will be useful, but
16 // WITHOUT ANY WARRANTY; without even the implied warranty of
17 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 // GNU General Public License for more details.
19 //
20 // You should have received a copy of the GNU General Public License
21 // along with Octave; see the file COPYING. If not, see
22 // <https://www.gnu.org/licenses/>.
23 //
24 ////////////////////////////////////////////////////////////////////////
25 
26 #if ! defined (octave_f77_fcn_h)
27 #define octave_f77_fcn_h 1
28 
29 #include "octave-config.h"
30 
31 #include "lo-error.h"
32 #include "quit.h"
33 
34 #if defined (__cplusplus)
35 # include <limits>
36 #endif
37 
38 #if defined (__cplusplus)
39 extern "C" {
40 #endif
41 
42 /* This macro is obsolete. */
43 
44 #define F77_XFCN(f, F, args) \
45  F77_FUNC (f, F) args
46 
47 #if ! defined (F77_FCN)
48 # define F77_FCN(f, F) F77_FUNC (f, F)
49 #endif
50 
51 /*
52 
53 The following macros are used for handling Fortran <-> C calling
54 conventions. They are defined below for three different types of
55 systems, Cray (possibly now obsolete), Visual Fortran, and gfortran.
56 Note that we don't attempt to handle Fortran functions, we always use
57 subroutine wrappers for them and pass the return value as an extra
58 argument.
59 
60 Use these macros to pass character strings from C to Fortran:
61 
62  F77_CHAR_ARG(x)
63  F77_CONST_CHAR_ARG(x)
64  F77_CXX_STRING_ARG(x)
65  F77_CHAR_ARG_LEN(l)
66  F77_CHAR_ARG_DECL
67  F77_CONST_CHAR_ARG_DECL
68  F77_CHAR_ARG_LEN_DECL
69 
70 Use these macros to write C-language functions that accept
71 Fortran-style character strings:
72 
73  F77_CHAR_ARG_DEF(s, len)
74  F77_CONST_CHAR_ARG_DEF(s, len)
75  F77_CHAR_ARG_LEN_DEF(len)
76  F77_CHAR_ARG_USE(s)
77  F77_CHAR_ARG_LEN_USE(s, len)
78 
79 Use these macros for C++ code
80 
81  F77_INT Equivalent to Fortran INTEGER type
82  F77_INT4 Equivalent to Fortran INTEGER*4 type
83  F77_DBLE Equivalent to Fortran DOUBLE PRECISION type
84  F77_REAL Equivalent to Fortran REAL type
85  F77_CMPLX Equivalent to Fortran COMPLEX type
86  F77_DBLE_CMPLX Equivalent to Fortran DOUBLE COMPLEX type
87  F77_LOGICAL Equivalent to Fortran LOGICAL type
88  F77_RET_T Return type of a C++ function that acts like a
89  Fortran subroutine.
90 
91 Use these macros to return from C-language functions that are supposed
92 to act like Fortran subroutines. F77_NORETURN is intended to be used
93 as the last statement of such a function that has been tagged with a
94 "noreturn" attribute. If the compiler supports the "noreturn"
95 attribute or if F77_RET_T is void, then it should expand to nothing so
96 that we avoid warnings about functions tagged as "noreturn"
97 containing a return statement. Otherwise, it should expand to a
98 statement that returns the given value so that we avoid warnings about
99 not returning a value from a function declared to return something.
100 
101  F77_RETURN(retval)
102  F77_NORETURN(retval)
103 
104 */
105 
106 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
107 
108 #include <fortran.h>
109 
110 /* Use these macros to pass character strings from C to Fortran. Cray
111  Fortran uses a descriptor structure to pass a pointer to the string
112  and the length in a single argument. */
113 
114 #define F77_CHAR_ARG(x) octave_make_cray_ftn_ch_dsc (x, strlen (x))
115 #define F77_CONST_CHAR_ARG(x) \
116  octave_make_cray_const_ftn_ch_dsc (x, strlen (x))
117 #define F77_CHAR_ARG2(x, l) octave_make_cray_ftn_ch_dsc (x, l)
118 #define F77_CONST_CHAR_ARG2(x, l) octave_make_cray_const_ftn_ch_dsc (x, l)
119 #define F77_CXX_STRING_ARG(x) \
120  octave_make_cray_const_ftn_ch_dsc (x.c_str (), x.length ())
121 #define F77_CHAR_ARG_LEN(l)
122 #define F77_CHAR_ARG_LEN_TYPE
123 #define F77_CHAR_ARG_LEN_DECL
124 #define F77_CHAR_ARG_DECL octave_cray_ftn_ch_dsc
125 #define F77_CONST_CHAR_ARG_DECL octave_cray_ftn_ch_dsc
126 
127 /* Use these macros to write C-language functions that accept
128  Fortran-style character strings. */
129 #define F77_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s
130 #define F77_CONST_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s
131 #define F77_CHAR_ARG_LEN_DEF(len)
132 #define F77_CHAR_ARG_USE(s) s.ptr
133 #define F77_CHAR_ARG_LEN_USE(s, len) (s.mask.len >> 3)
134 
135 #define F77_RET_T int
136 
137 /* Use these macros to return from C-language functions that are
138  supposed to act like Fortran subroutines. F77_NORETURN is intended
139  to be used as the last statement of such a function that has been
140  tagged with a "noreturn" attribute. */
141 
142 #define F77_RETURN(retval) return retval;
143 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
144 # define F77_NORETURN(retval)
145 #else
146 # define F77_NORETURN(retval) return retval;
147 #endif
148 
149 /* FIXME: These should work for SV1 or Y-MP systems but will
150  need to be changed for others. */
151 
152 typedef union
153 {
154  const char *const_ptr;
155  char *ptr;
156  struct
157  {
158  unsigned off : 6;
159  unsigned len : 26;
160  unsigned add : 32;
161  } mask;
162 } octave_cray_descriptor;
163 
164 typedef void *octave_cray_ftn_ch_dsc;
165 
166 #if defined (__cplusplus)
167 # define OCTAVE_F77_FCN_INLINE inline
168 #else
169 # define OCTAVE_F77_FCN_INLINE
170 #endif
171 
172 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc
173 octave_make_cray_ftn_ch_dsc (char *ptr_arg, unsigned long len_arg)
174 {
175  octave_cray_descriptor desc;
176  desc.ptr = ptr_arg;
177  desc.mask.len = len_arg << 3;
178  return *((octave_cray_ftn_ch_dsc *) &desc);
179 }
180 
181 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc
182 octave_make_cray_const_ftn_ch_dsc (const char *ptr_arg, unsigned long len_arg)
183 {
184  octave_cray_descriptor desc;
185  desc.const_ptr = ptr_arg;
186  desc.mask.len = len_arg << 3;
187  return *((octave_cray_ftn_ch_dsc *) &desc);
188 }
189 
190 #undef OCTAVE_F77_FCN_INLINE
191 
192 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION)
193 
194 /* Use these macros to pass character strings from C to Fortran.
195  Visual Fortran inserts the length after each character string
196  argument. */
197 
198 #define F77_CHAR_ARG(x) x, strlen (x)
199 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
200 #define F77_CHAR_ARG2(x, l) x, l
201 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l)
202 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ())
203 #define F77_CHAR_ARG_LEN(l)
204 #define F77_CHAR_ARG_LEN_TYPE int
205 #define F77_CHAR_ARG_LEN_DECL
206 #define F77_CHAR_ARG_DECL char *, F77_CHAR_ARG_LEN_TYPE
207 #define F77_CONST_CHAR_ARG_DECL const char *, F77_CHAR_ARG_LEN_TYPE
208 
209 #define F77_CHAR_ARG_DEF(s, len) char *s, F77_CHAR_ARG_LEN_TYPE len
210 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s, F77_CHAR_ARG_LEN_TYPE len
211 #define F77_CHAR_ARG_LEN_DEF(len)
212 #define F77_CHAR_ARG_USE(s) s
213 #define F77_CHAR_ARG_LEN_USE(s, len) len
214 
215 #define F77_RET_T void
216 
217 #define F77_RETURN(retval) return;
218 #define F77_NORETURN(retval)
219 
220 #elif defined (F77_USES_GFORTRAN_CALLING_CONVENTION)
221 
222 /* Use these macros to pass character strings from C to Fortran.
223  gfortran appends length arguments for assumed size character
224  strings to the and ignores others.
225 
226  FIXME: I don't think we correctly handle the case of mixing some
227  fixed-length and some assumed-length character string arguments as
228  we don't handle each case separately, so it seems there could be
229  mismatch? However, I don't think we currently have to handle this
230  case in Octave. */
231 
232 #define F77_CHAR_ARG(x) x
233 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
234 #define F77_CHAR_ARG2(x, l) x
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) , l
238 #if defined (__GNUC__) && __GNUC__ >= 8
239 # define F77_CHAR_ARG_LEN_TYPE size_t
240 #else
241 # define F77_CHAR_ARG_LEN_TYPE int
242 #endif
243 #define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE
244 #define F77_CHAR_ARG_DECL char *
245 #define F77_CONST_CHAR_ARG_DECL const char *
246 
247 #define F77_CHAR_ARG_DEF(s, len) char *s
248 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s
249 #define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len
250 #define F77_CHAR_ARG_USE(s) s
251 #define F77_CHAR_ARG_LEN_USE(s, len) len
252 
253 #define F77_RET_T void
254 
255 #define F77_RETURN(retval) return;
256 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
257 # define F77_NORETURN(retval)
258 #else
259 # define F77_NORETURN(retval) return retval;
260 #endif
261 
262 #elif defined (F77_USES_F2C_CALLING_CONVENTION)
263 
264 /* Assume f2c-compatible calling convention. */
265 
266 /* Use these macros to pass character strings from C to Fortran. f2c
267  appends all length arguments at the end of the parameter list. */
268 
269 #define F77_CHAR_ARG(x) x
270 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x)
271 #define F77_CHAR_ARG2(x, l) x
272 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l)
273 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ())
274 #define F77_CHAR_ARG_LEN(l) , l
275 #define F77_CHAR_ARG_LEN_TYPE long
276 #define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE
277 #define F77_CHAR_ARG_DECL char *
278 #define F77_CONST_CHAR_ARG_DECL const char *
279 
280 #define F77_CHAR_ARG_DEF(s, len) char *s
281 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s
282 #define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len
283 #define F77_CHAR_ARG_USE(s) s
284 #define F77_CHAR_ARG_LEN_USE(s, len) len
285 
286 #define F77_RET_T int
287 
288 #define F77_RETURN(retval) return retval;
289 #if defined (HAVE_OCTAVE_NORETURN_ATTR)
290 # define F77_NORETURN(retval)
291 #else
292 # define F77_NORETURN(retval) return retval;
293 #endif
294 
295 #else
296 
297 #error "unknown C++ to Fortran calling convention"
298 
299 #endif
300 
301 typedef double F77_DBLE;
302 typedef float F77_REAL;
303 typedef double _Complex F77_DBLE_CMPLX;
304 typedef float _Complex F77_CMPLX;
305 typedef octave_f77_int_type F77_INT;
306 typedef int32_t F77_INT4;
307 typedef octave_f77_int_type F77_LOGICAL;
308 
309 #define F77_CMPLX_ARG(x) \
310  reinterpret_cast<float _Complex *> (x)
311 
312 #define F77_CONST_CMPLX_ARG(x) \
313  reinterpret_cast<const float _Complex *> (x)
314 
315 #define F77_DBLE_CMPLX_ARG(x) \
316  reinterpret_cast<double _Complex *> (x)
317 
318 #define F77_CONST_DBLE_CMPLX_ARG(x) \
319  reinterpret_cast<const double _Complex *> (x)
320 
321 /* Build a C string local variable CS from the Fortran string parameter S
322  declared as F77_CHAR_ARG_DEF(s, len) or F77_CONST_CHAR_ARG_DEF(s, len).
323  The string will be cleaned up at the end of the current block.
324  Needs to include <cstring> and <vector>. */
325 
326 #define F77_CSTRING(s, len, cs) \
327  OCTAVE_LOCAL_BUFFER (char, cs, F77_CHAR_ARG_LEN_USE (s, len) + 1); \
328  memcpy (cs, F77_CHAR_ARG_USE (s), F77_CHAR_ARG_LEN_USE (s, len)); \
329  cs[F77_CHAR_ARG_LEN_USE(s, len)] = '\0'
330 
331 OCTAVE_NORETURN OCTAVE_API extern
332 F77_RET_T
333 F77_FUNC (xstopx, XSTOPX) (F77_CONST_CHAR_ARG_DECL
335 
336 #if defined (__cplusplus)
337 
338 namespace octave
339 {
340  inline F77_INT
341  to_f77_int (octave_idx_type x)
342  {
345  (*current_liboctave_error_handler)
346  ("integer dimension or index out of range for Fortran INTEGER type");
347 
348  return static_cast<F77_INT> (x);
349  }
350 }
351 
352 #endif
353 
354 #if defined (__cplusplus)
355 }
356 #endif
357 
358 #endif
charNDArray max(char d, const charNDArray &m)
Definition: chNDArray.cc:230
charNDArray min(char d, const charNDArray &m)
Definition: chNDArray.cc:207
OCTAVE_NORETURN OCTAVE_API F77_RET_T F77_FUNC(xstopx, XSTOPX)(F77_CONST_CHAR_ARG_DECL F77_CHAR_ARG_LEN_DECL)
Definition: f77-fcn.c:46
float F77_REAL
Definition: f77-fcn.h:302
double F77_DBLE
Definition: f77-fcn.h:301
int32_t F77_INT4
Definition: f77-fcn.h:306
octave_f77_int_type F77_LOGICAL
Definition: f77-fcn.h:307
double _Complex F77_DBLE_CMPLX
Definition: f77-fcn.h:303
octave_f77_int_type F77_INT
Definition: f77-fcn.h:305
float _Complex F77_CMPLX
Definition: f77-fcn.h:304
F77_RET_T F77_CONST_CHAR_ARG_DECL
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, F77_CONST_CHAR_ARG_DECL, F77_CONST_CHAR_ARG_DECL, const F77_INT &, const F77_INT &, const F77_INT &, F77_INT &, F77_INT &, F77_DBLE *, const F77_INT &, F77_DBLE *, const F77_INT &, F77_DBLE *, F77_DBLE *, F77_DBLE *, const F77_INT &, F77_DBLE *, const F77_INT &, F77_DBLE *, const F77_INT &, F77_DBLE *, F77_INT *, F77_INT &F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL F77_CHAR_ARG_LEN_DECL)
F77_RET_T const F77_DBLE * x
F77_RET_T len
Definition: xerbla.cc:61