GNU Octave  3.8.0
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Properties Friends Macros Pages
f77-fcn.c
Go to the documentation of this file.
1 /*
2 
3 Copyright (C) 1996-2013 John W. Eaton
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
9 Free Software Foundation; either version 3 of the License, or (at your
10 option) any later version.
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
18 along with Octave; see the file COPYING. If not, see
19 <http://www.gnu.org/licenses/>.
20 
21 */
22 
23 #ifdef HAVE_CONFIG_H
24 #include <config.h>
25 #endif
26 
27 #include <stdlib.h>
28 #include <string.h>
29 
30 #include "f77-fcn.h"
31 #include "quit.h"
32 #include "lo-error.h"
33 
34 /* All the STOP statements in the Fortran routines have been replaced
35  with a call to XSTOPX.
36 
37  XSTOPX jumps back to the entry point for the Fortran function that
38  called us. Then the calling function should do whatever cleanup
39  is necessary. */
40 
42 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
43 F77_FUNC (xstopx, XSTOPX) (octave_cray_ftn_ch_dsc desc)
44 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION)
45 F77_FUNC (xstopx, XSTOPX) (const char *s, int slen)
46 #else
47 F77_FUNC (xstopx, XSTOPX) (const char *s, long slen)
48 #endif
49 {
50 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
51  const char *s = desc.const_ptr = ptr_arg;
52  unsigned long slen = desc.mask.len;
53 #endif
54 
56 
57  /* Skip printing message if it is just a single blank character. */
58  if (s && slen > 0 && ! (slen == 1 && *s == ' '))
59  (*current_liboctave_error_handler) ("%.*s", slen, s);
60 
62 
63  F77_NORETURN (0)
64 }