2544
|
1 /* |
|
2 |
2847
|
3 Copyright (C) 1996, 1997 John W. Eaton |
2544
|
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 |
7016
|
9 Free Software Foundation; either version 3 of the License, or (at your |
|
10 option) any later version. |
2544
|
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 |
7016
|
18 along with Octave; see the file COPYING. If not, see |
|
19 <http://www.gnu.org/licenses/>. |
2544
|
20 |
|
21 */ |
|
22 |
|
23 #if !defined (octave_f77_fcn_h) |
|
24 #define octave_f77_fcn_h 1 |
|
25 |
4268
|
26 #include "quit.h" |
|
27 |
2544
|
28 #ifdef __cplusplus |
|
29 extern "C" { |
|
30 #endif |
|
31 |
4153
|
32 /* Hack to stringize macro results. */ |
3887
|
33 #define xSTRINGIZE(x) #x |
|
34 #define STRINGIZE(x) xSTRINGIZE(x) |
2544
|
35 |
|
36 /* How to print an error for the F77_XFCN macro. */ |
|
37 |
|
38 #define F77_XFCN_ERROR(f, F) \ |
|
39 (*current_liboctave_error_handler) \ |
3887
|
40 ("exception encountered in Fortran subroutine %s", \ |
|
41 STRINGIZE (F77_FUNC (f, F))) |
2544
|
42 |
|
43 /* This can be used to call a Fortran subroutine that might call |
4153
|
44 XSTOPX. XSTOPX will call lonjmp with current_context. Once back |
|
45 here, we'll restore the previous context and return. We may also |
|
46 end up here if an interrupt is processed when the Fortran |
|
47 subroutine is called. In that case, we resotre the context and go |
|
48 to the top level. The error_state should be checked immediately |
|
49 after this macro is used. */ |
2544
|
50 |
|
51 #define F77_XFCN(f, F, args) \ |
|
52 do \ |
|
53 { \ |
4182
|
54 octave_jmp_buf saved_context; \ |
5767
|
55 sig_atomic_t saved_octave_interrupt_immediately = octave_interrupt_immediately; \ |
2544
|
56 f77_exception_encountered = 0; \ |
5760
|
57 octave_save_current_context (saved_context); \ |
4153
|
58 if (octave_set_current_context) \ |
2544
|
59 { \ |
5701
|
60 octave_interrupt_immediately = saved_octave_interrupt_immediately; \ |
5760
|
61 octave_restore_current_context (saved_context); \ |
4153
|
62 if (f77_exception_encountered) \ |
|
63 F77_XFCN_ERROR (f, F); \ |
4180
|
64 else if (octave_allocation_error) \ |
4182
|
65 octave_throw_bad_alloc (); \ |
4153
|
66 else \ |
4182
|
67 octave_throw_interrupt_exception (); \ |
2544
|
68 } \ |
|
69 else \ |
4153
|
70 { \ |
4182
|
71 octave_interrupt_immediately++; \ |
4153
|
72 F77_FUNC (f, F) args; \ |
4182
|
73 octave_interrupt_immediately--; \ |
5760
|
74 octave_restore_current_context (saved_context); \ |
4153
|
75 } \ |
2544
|
76 } \ |
|
77 while (0) |
|
78 |
|
79 /* So we can check to see if an exception has occurred. */ |
6107
|
80 CRUFT_API extern int f77_exception_encountered; |
2544
|
81 |
3938
|
82 #if !defined (F77_FCN) |
|
83 #define F77_FCN(f, F) F77_FUNC (f, F) |
|
84 #endif |
|
85 |
4552
|
86 #if defined (F77_USES_CRAY_CALLING_CONVENTION) |
|
87 |
|
88 #include <fortran.h> |
6072
|
89 |
|
90 /* Use these macros to pass character strings from C to Fortran. */ |
4552
|
91 #define F77_CHAR_ARG(x) octave_make_cray_ftn_ch_dsc (x, strlen (x)) |
|
92 #define F77_CONST_CHAR_ARG(x) \ |
|
93 octave_make_cray_const_ftn_ch_dsc (x, strlen (x)) |
4577
|
94 #define F77_CHAR_ARG2(x, l) octave_make_cray_ftn_ch_dsc (x, l) |
|
95 #define F77_CONST_CHAR_ARG2(x, l) octave_make_cray_const_ftn_ch_dsc (x, l) |
4552
|
96 #define F77_CXX_STRING_ARG(x) \ |
|
97 octave_make_cray_const_ftn_ch_dsc (x.c_str (), x.length ()) |
|
98 #define F77_CHAR_ARG_LEN(l) |
4577
|
99 #define F77_CHAR_ARG_DECL octave_cray_ftn_ch_dsc |
|
100 #define F77_CONST_CHAR_ARG_DECL octave_cray_ftn_ch_dsc |
4552
|
101 #define F77_CHAR_ARG_LEN_DECL |
6072
|
102 |
|
103 /* Use these macros to write C-language functions that accept |
|
104 Fortran-style character strings. */ |
|
105 #define F77_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s |
|
106 #define F77_CONST_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s |
|
107 #define F77_CHAR_ARG_LEN_DEF(len) |
|
108 #define F77_CHAR_ARG_USE(s) s.ptr |
|
109 #define F77_CHAR_ARG_LEN_USE(s, len) (s.mask.len>>3) |
|
110 |
4552
|
111 #define F77_RET_T int |
|
112 #define F77_RETURN(retval) return retval; |
|
113 |
5775
|
114 /* FIXME -- these should work for SV1 or Y-MP systems but will |
4572
|
115 need to be changed for others. */ |
4552
|
116 |
4558
|
117 typedef union |
4552
|
118 { |
4558
|
119 const char *const_ptr; |
|
120 char *ptr; |
4552
|
121 struct |
|
122 { |
|
123 unsigned off : 6; |
|
124 unsigned len : 26; |
|
125 unsigned add : 32; |
|
126 } mask; |
4558
|
127 } octave_cray_descriptor; |
4552
|
128 |
|
129 typedef void *octave_cray_ftn_ch_dsc; |
|
130 |
4555
|
131 #ifdef __cplusplus |
|
132 #define OCTAVE_F77_FCN_INLINE inline |
4558
|
133 #else |
|
134 #define OCTAVE_F77_FCN_INLINE |
4555
|
135 #endif |
|
136 |
|
137 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc |
4552
|
138 octave_make_cray_ftn_ch_dsc (char *ptr_arg, unsigned long len_arg) |
|
139 { |
|
140 octave_cray_descriptor desc; |
|
141 desc.ptr = ptr_arg; |
|
142 desc.mask.len = len_arg << 3; |
4558
|
143 return *((octave_cray_ftn_ch_dsc *) &desc); |
4552
|
144 } |
|
145 |
4555
|
146 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc |
4552
|
147 octave_make_cray_const_ftn_ch_dsc (const char *ptr_arg, unsigned long len_arg) |
|
148 { |
|
149 octave_cray_descriptor desc; |
|
150 desc.const_ptr = ptr_arg; |
|
151 desc.mask.len = len_arg << 3; |
4558
|
152 return *((octave_cray_ftn_ch_dsc *) &desc); |
4552
|
153 } |
|
154 |
4555
|
155 #ifdef __cplusplus |
|
156 #undef OCTAVE_F77_FCN_INLINE |
|
157 #endif |
|
158 |
4552
|
159 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION) |
|
160 |
6072
|
161 /* Use these macros to pass character strings from C to Fortran. */ |
4552
|
162 #define F77_CHAR_ARG(x) x, strlen (x) |
|
163 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) |
|
164 #define F77_CHAR_ARG2(x, l) x, l |
|
165 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) |
|
166 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) |
|
167 #define F77_CHAR_ARG_LEN(l) |
|
168 #define F77_CHAR_ARG_DECL char *, int |
|
169 #define F77_CONST_CHAR_ARG_DECL const char *, int |
|
170 #define F77_CHAR_ARG_LEN_DECL |
6072
|
171 |
|
172 /* Use these macros to write C-language functions that accept |
|
173 Fortran-style character strings. */ |
|
174 #define F77_CHAR_ARG_DEF(s, len) char *s, int len |
|
175 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s, int len |
|
176 #define F77_CHAR_ARG_LEN_DEF(len) |
|
177 #define F77_CHAR_ARG_USE(s) s |
|
178 #define F77_CHAR_ARG_LEN_USE(s, len) len |
|
179 |
4552
|
180 #define F77_RET_T void |
|
181 #define F77_RETURN(retval) |
|
182 |
|
183 #else |
|
184 |
4572
|
185 /* Assume f2c-compatible calling convention. */ |
4552
|
186 |
6072
|
187 /* Use these macros to pass character strings from C to Fortran. */ |
4552
|
188 #define F77_CHAR_ARG(x) x |
|
189 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) |
|
190 #define F77_CHAR_ARG2(x, l) x |
|
191 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) |
|
192 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) |
5760
|
193 #define F77_CHAR_ARG_LEN(l) , l |
4552
|
194 #define F77_CHAR_ARG_DECL char * |
|
195 #define F77_CONST_CHAR_ARG_DECL const char * |
|
196 #define F77_CHAR_ARG_LEN_DECL , long |
6072
|
197 |
|
198 /* Use these macros to write C-language functions that accept |
|
199 Fortran-style character strings. */ |
|
200 #define F77_CHAR_ARG_DEF(s, len) char *s |
|
201 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s |
|
202 #define F77_CHAR_ARG_LEN_DEF(len) , long len |
|
203 #define F77_CHAR_ARG_USE(s) s |
|
204 #define F77_CHAR_ARG_LEN_USE(s, len) len |
|
205 |
4552
|
206 #define F77_RET_T int |
|
207 #define F77_RETURN(retval) return retval; |
|
208 |
|
209 #endif |
|
210 |
6072
|
211 |
|
212 /* Build a C string local variable CS from the Fortran string parameter S |
|
213 declared as F77_CHAR_ARG_DEF(s, len) or F77_CONST_CHAR_ARG_DEF(s, len). |
|
214 The string will be cleaned up at the end of the current block. |
|
215 Needs to include <cstring> and <vector>. */ |
|
216 |
|
217 #define F77_CSTRING(s, len, cs) \ |
6253
|
218 OCTAVE_LOCAL_BUFFER (char, cs, F77_CHAR_ARG_LEN_USE (s, len) + 1); \ |
6072
|
219 memcpy (cs, F77_CHAR_ARG_USE (s), F77_CHAR_ARG_LEN_USE (s, len)); \ |
|
220 cs[F77_CHAR_ARG_LEN_USE(s, len)] = '\0' |
|
221 |
|
222 |
6107
|
223 extern CRUFT_API F77_RET_T |
4801
|
224 F77_FUNC (xstopx, XSTOPX) (F77_CONST_CHAR_ARG_DECL |
|
225 F77_CHAR_ARG_LEN_DECL) GCC_ATTR_NORETURN; |
4552
|
226 |
2544
|
227 #ifdef __cplusplus |
|
228 } |
|
229 #endif |
|
230 |
|
231 #endif |
|
232 |
|
233 /* |
|
234 ;;; Local Variables: *** |
|
235 ;;; mode: C++ *** |
|
236 ;;; End: *** |
|
237 */ |