Mercurial > octave
annotate libcruft/misc/f77-fcn.h @ 9930:1ddc25c3623a
libcruft/misc: untabify sources
author | John W. Eaton <jwe@octave.org> |
---|---|
date | Mon, 07 Dec 2009 13:17:13 -0500 |
parents | eb63fbe60fab |
children | ac4b97c6bf8b |
rev | line source |
---|---|
2544 | 1 /* |
2 | |
9930
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
3 Copyright (C) 1996, 1997, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 |
7017 | 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) \ |
9930
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
60 { \ |
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
61 octave_interrupt_immediately = saved_octave_interrupt_immediately; \ |
5760 | 62 octave_restore_current_context (saved_context); \ |
9930
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
63 if (f77_exception_encountered) \ |
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
64 F77_XFCN_ERROR (f, F); \ |
4153 | 65 else \ |
9930
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
66 octave_rethrow_exception (); \ |
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
67 } \ |
2544 | 68 else \ |
4153 | 69 { \ |
9930
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
70 octave_interrupt_immediately++; \ |
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
71 F77_FUNC (f, F) args; \ |
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
72 octave_interrupt_immediately--; \ |
5760 | 73 octave_restore_current_context (saved_context); \ |
4153 | 74 } \ |
2544 | 75 } \ |
76 while (0) | |
77 | |
78 /* So we can check to see if an exception has occurred. */ | |
6107 | 79 CRUFT_API extern int f77_exception_encountered; |
2544 | 80 |
3938 | 81 #if !defined (F77_FCN) |
82 #define F77_FCN(f, F) F77_FUNC (f, F) | |
83 #endif | |
84 | |
4552 | 85 #if defined (F77_USES_CRAY_CALLING_CONVENTION) |
86 | |
87 #include <fortran.h> | |
6072 | 88 |
89 /* Use these macros to pass character strings from C to Fortran. */ | |
4552 | 90 #define F77_CHAR_ARG(x) octave_make_cray_ftn_ch_dsc (x, strlen (x)) |
91 #define F77_CONST_CHAR_ARG(x) \ | |
92 octave_make_cray_const_ftn_ch_dsc (x, strlen (x)) | |
4577 | 93 #define F77_CHAR_ARG2(x, l) octave_make_cray_ftn_ch_dsc (x, l) |
94 #define F77_CONST_CHAR_ARG2(x, l) octave_make_cray_const_ftn_ch_dsc (x, l) | |
4552 | 95 #define F77_CXX_STRING_ARG(x) \ |
96 octave_make_cray_const_ftn_ch_dsc (x.c_str (), x.length ()) | |
97 #define F77_CHAR_ARG_LEN(l) | |
4577 | 98 #define F77_CHAR_ARG_DECL octave_cray_ftn_ch_dsc |
99 #define F77_CONST_CHAR_ARG_DECL octave_cray_ftn_ch_dsc | |
4552 | 100 #define F77_CHAR_ARG_LEN_DECL |
6072 | 101 |
102 /* Use these macros to write C-language functions that accept | |
103 Fortran-style character strings. */ | |
104 #define F77_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s | |
105 #define F77_CONST_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s | |
106 #define F77_CHAR_ARG_LEN_DEF(len) | |
107 #define F77_CHAR_ARG_USE(s) s.ptr | |
108 #define F77_CHAR_ARG_LEN_USE(s, len) (s.mask.len>>3) | |
109 | |
4552 | 110 #define F77_RET_T int |
111 #define F77_RETURN(retval) return retval; | |
112 | |
5775 | 113 /* FIXME -- these should work for SV1 or Y-MP systems but will |
4572 | 114 need to be changed for others. */ |
4552 | 115 |
4558 | 116 typedef union |
4552 | 117 { |
4558 | 118 const char *const_ptr; |
119 char *ptr; | |
4552 | 120 struct |
121 { | |
122 unsigned off : 6; | |
123 unsigned len : 26; | |
124 unsigned add : 32; | |
125 } mask; | |
4558 | 126 } octave_cray_descriptor; |
4552 | 127 |
128 typedef void *octave_cray_ftn_ch_dsc; | |
129 | |
4555 | 130 #ifdef __cplusplus |
131 #define OCTAVE_F77_FCN_INLINE inline | |
4558 | 132 #else |
133 #define OCTAVE_F77_FCN_INLINE | |
4555 | 134 #endif |
135 | |
136 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc | |
4552 | 137 octave_make_cray_ftn_ch_dsc (char *ptr_arg, unsigned long len_arg) |
138 { | |
139 octave_cray_descriptor desc; | |
140 desc.ptr = ptr_arg; | |
141 desc.mask.len = len_arg << 3; | |
4558 | 142 return *((octave_cray_ftn_ch_dsc *) &desc); |
4552 | 143 } |
144 | |
4555 | 145 static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc |
4552 | 146 octave_make_cray_const_ftn_ch_dsc (const char *ptr_arg, unsigned long len_arg) |
147 { | |
148 octave_cray_descriptor desc; | |
149 desc.const_ptr = ptr_arg; | |
150 desc.mask.len = len_arg << 3; | |
4558 | 151 return *((octave_cray_ftn_ch_dsc *) &desc); |
4552 | 152 } |
153 | |
4555 | 154 #ifdef __cplusplus |
155 #undef OCTAVE_F77_FCN_INLINE | |
156 #endif | |
157 | |
4552 | 158 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION) |
159 | |
6072 | 160 /* Use these macros to pass character strings from C to Fortran. */ |
4552 | 161 #define F77_CHAR_ARG(x) x, strlen (x) |
162 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) | |
163 #define F77_CHAR_ARG2(x, l) x, l | |
164 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) | |
165 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) | |
166 #define F77_CHAR_ARG_LEN(l) | |
167 #define F77_CHAR_ARG_DECL char *, int | |
168 #define F77_CONST_CHAR_ARG_DECL const char *, int | |
169 #define F77_CHAR_ARG_LEN_DECL | |
6072 | 170 |
171 /* Use these macros to write C-language functions that accept | |
172 Fortran-style character strings. */ | |
173 #define F77_CHAR_ARG_DEF(s, len) char *s, int len | |
174 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s, int len | |
175 #define F77_CHAR_ARG_LEN_DEF(len) | |
176 #define F77_CHAR_ARG_USE(s) s | |
177 #define F77_CHAR_ARG_LEN_USE(s, len) len | |
178 | |
4552 | 179 #define F77_RET_T void |
180 #define F77_RETURN(retval) | |
181 | |
182 #else | |
183 | |
4572 | 184 /* Assume f2c-compatible calling convention. */ |
4552 | 185 |
6072 | 186 /* Use these macros to pass character strings from C to Fortran. */ |
4552 | 187 #define F77_CHAR_ARG(x) x |
188 #define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) | |
189 #define F77_CHAR_ARG2(x, l) x | |
190 #define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) | |
191 #define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) | |
5760 | 192 #define F77_CHAR_ARG_LEN(l) , l |
4552 | 193 #define F77_CHAR_ARG_DECL char * |
194 #define F77_CONST_CHAR_ARG_DECL const char * | |
195 #define F77_CHAR_ARG_LEN_DECL , long | |
6072 | 196 |
197 /* Use these macros to write C-language functions that accept | |
198 Fortran-style character strings. */ | |
199 #define F77_CHAR_ARG_DEF(s, len) char *s | |
200 #define F77_CONST_CHAR_ARG_DEF(s, len) const char *s | |
201 #define F77_CHAR_ARG_LEN_DEF(len) , long len | |
202 #define F77_CHAR_ARG_USE(s) s | |
203 #define F77_CHAR_ARG_LEN_USE(s, len) len | |
204 | |
4552 | 205 #define F77_RET_T int |
206 #define F77_RETURN(retval) return retval; | |
207 | |
208 #endif | |
209 | |
6072 | 210 |
211 /* Build a C string local variable CS from the Fortran string parameter S | |
212 declared as F77_CHAR_ARG_DEF(s, len) or F77_CONST_CHAR_ARG_DEF(s, len). | |
213 The string will be cleaned up at the end of the current block. | |
214 Needs to include <cstring> and <vector>. */ | |
215 | |
216 #define F77_CSTRING(s, len, cs) \ | |
6253 | 217 OCTAVE_LOCAL_BUFFER (char, cs, F77_CHAR_ARG_LEN_USE (s, len) + 1); \ |
6072 | 218 memcpy (cs, F77_CHAR_ARG_USE (s), F77_CHAR_ARG_LEN_USE (s, len)); \ |
219 cs[F77_CHAR_ARG_LEN_USE(s, len)] = '\0' | |
220 | |
221 | |
6107 | 222 extern CRUFT_API F77_RET_T |
4801 | 223 F77_FUNC (xstopx, XSTOPX) (F77_CONST_CHAR_ARG_DECL |
9930
1ddc25c3623a
libcruft/misc: untabify sources
John W. Eaton <jwe@octave.org>
parents:
8920
diff
changeset
|
224 F77_CHAR_ARG_LEN_DECL) GCC_ATTR_NORETURN; |
4552 | 225 |
2544 | 226 #ifdef __cplusplus |
227 } | |
228 #endif | |
229 | |
230 #endif | |
231 | |
232 /* | |
233 ;;; Local Variables: *** | |
234 ;;; mode: C++ *** | |
235 ;;; End: *** | |
236 */ |