|
2544
|
1 /* |
|
|
2 |
|
7017
|
3 Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004, 2005, 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 #ifdef HAVE_CONFIG_H |
|
|
25 #include <config.h> |
|
|
26 #endif |
|
|
27 |
|
3808
|
28 #include <stdlib.h> |
|
2544
|
29 #include <string.h> |
|
|
30 |
|
|
31 #include "f77-fcn.h" |
|
4153
|
32 #include "quit.h" |
|
3808
|
33 #include "lo-error.h" |
|
2544
|
34 |
|
3808
|
35 /* All the STOP statements in the Fortran routines have been replaced |
|
|
36 with a call to XSTOPX. |
|
|
37 |
|
|
38 XSTOPX jumps back to the entry point for the Fortran function that |
|
|
39 called us. Then the calling function should do whatever cleanup |
|
3809
|
40 is necessary. */ |
|
3808
|
41 |
|
4552
|
42 F77_RET_T |
|
4801
|
43 #if defined (F77_USES_CRAY_CALLING_CONVENTION) |
|
|
44 F77_FUNC (xstopx, XSTOPX) (octave_cray_ftn_ch_dsc desc) |
|
|
45 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION) |
|
|
46 F77_FUNC (xstopx, XSTOPX) (const char *s, int slen) |
|
|
47 #else |
|
|
48 F77_FUNC (xstopx, XSTOPX) (const char *s, long slen) |
|
|
49 #endif |
|
3808
|
50 { |
|
4801
|
51 #if defined (F77_USES_CRAY_CALLING_CONVENTION) |
|
|
52 const char *s = desc.const_ptr = ptr_arg; |
|
|
53 unsigned long slen = desc.mask.len; |
|
|
54 #endif |
|
|
55 |
|
4153
|
56 f77_exception_encountered = 1; |
|
|
57 |
|
3809
|
58 /* Skip printing message if it is just a single blank character. */ |
|
|
59 if (s && slen > 0 && ! (slen == 1 && *s == ' ')) |
|
3963
|
60 (*current_liboctave_error_handler) ("%.*s", slen, s); |
|
3808
|
61 |
|
4153
|
62 octave_jump_to_enclosing_context (); |
|
4552
|
63 |
|
|
64 F77_RETURN (0) |
|
3808
|
65 } |
|
|
66 |
|
2544
|
67 /* |
|
|
68 ;;; Local Variables: *** |
|
|
69 ;;; mode: C++ *** |
|
|
70 ;;; End: *** |
|
|
71 */ |
