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