libcruft/misc/f77-fcn.c

Go to the documentation of this file.
00001 /*
00002 
00003 Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2007
00004               John W. Eaton
00005 
00006 This file is part of Octave.
00007 
00008 Octave is free software; you can redistribute it and/or modify it
00009 under the terms of the GNU General Public License as published by the
00010 Free Software Foundation; either version 3 of the License, or (at your
00011 option) any later version.
00012 
00013 Octave is distributed in the hope that it will be useful, but WITHOUT
00014 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
00015 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
00016 for more details.
00017 
00018 You should have received a copy of the GNU General Public License
00019 along with Octave; see the file COPYING.  If not, see
00020 <http://www.gnu.org/licenses/>.
00021 
00022 */
00023 
00024 #ifdef HAVE_CONFIG_H
00025 #include <config.h>
00026 #endif
00027 
00028 #include <stdlib.h>
00029 #include <string.h>
00030 
00031 #include "f77-fcn.h"
00032 #include "quit.h"
00033 #include "lo-error.h"
00034 
00035 /* All the STOP statements in the Fortran routines have been replaced
00036    with a call to XSTOPX.
00037 
00038    XSTOPX jumps back to the entry point for the Fortran function that
00039    called us.  Then the calling function should do whatever cleanup
00040    is necessary.  */
00041 
00042 F77_RET_T
00043 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
00044 F77_FUNC (xstopx, XSTOPX) (octave_cray_ftn_ch_dsc desc)
00045 #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION)
00046 F77_FUNC (xstopx, XSTOPX) (const char *s, int slen)
00047 #else
00048 F77_FUNC (xstopx, XSTOPX) (const char *s, long slen)
00049 #endif
00050 {
00051 #if defined (F77_USES_CRAY_CALLING_CONVENTION)
00052   const char *s = desc.const_ptr = ptr_arg;
00053   unsigned long slen = desc.mask.len;
00054 #endif
00055 
00056   f77_exception_encountered = 1;
00057 
00058   /* Skip printing message if it is just a single blank character.  */
00059   if (s && slen > 0 && ! (slen == 1 && *s == ' '))
00060     (*current_liboctave_error_handler) ("%.*s", slen, s);
00061 
00062   octave_jump_to_enclosing_context ();
00063 
00064   F77_RETURN (0)
00065 }
00066 
00067 /*
00068 ;;; Local Variables: ***
00069 ;;; mode: C++ ***
00070 ;;; End: ***
00071 */
	Octave-Forge - Extra packages for GNU Octave
	Home · Packages · Developers · Documentation · Function Reference · FAQ · Bugs · Mailing Lists · Links · SVN