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