Mercurial > octave-nkf
view libcruft/misc/f77-fcn.c @ 4801:b022780ac0b4
[project @ 2004-02-25 04:40:54 by jwe]
author | jwe |
---|---|
date | Wed, 25 Feb 2004 04:40:54 +0000 |
parents | 6f3382e08a52 |
children | 4c8a2e4e0717 |
line wrap: on
line source
/* Copyright (C) 1996, 1997 John W. Eaton This file is part of Octave. Octave is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Octave is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with Octave; see the file COPYING. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef HAVE_CONFIG_H #include <config.h> #endif #include <stdlib.h> #include <string.h> #include "f77-fcn.h" #include "quit.h" #include "lo-error.h" /* All the STOP statements in the Fortran routines have been replaced with a call to XSTOPX. XSTOPX jumps back to the entry point for the Fortran function that called us. Then the calling function should do whatever cleanup is necessary. */ F77_RET_T #if defined (F77_USES_CRAY_CALLING_CONVENTION) F77_FUNC (xstopx, XSTOPX) (octave_cray_ftn_ch_dsc desc) #elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION) F77_FUNC (xstopx, XSTOPX) (const char *s, int slen) #else F77_FUNC (xstopx, XSTOPX) (const char *s, long slen) #endif { #if defined (F77_USES_CRAY_CALLING_CONVENTION) const char *s = desc.const_ptr = ptr_arg; unsigned long slen = desc.mask.len; #endif f77_exception_encountered = 1; /* Skip printing message if it is just a single blank character. */ if (s && slen > 0 && ! (slen == 1 && *s == ' ')) (*current_liboctave_error_handler) ("%.*s", slen, s); octave_jump_to_enclosing_context (); F77_RETURN (0) } /* ;;; Local Variables: *** ;;; mode: C++ *** ;;; End: *** */