diff libcruft/misc/f77-fcn.h @ 2544:a33bbd3fadd7

[project @ 1996-11-20 05:09:29 by jwe]
author jwe
date Wed, 20 Nov 1996 05:09:46 +0000
parents
children 8b262e771614
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/libcruft/misc/f77-fcn.h	Wed Nov 20 05:09:46 1996 +0000
@@ -0,0 +1,106 @@
+/*
+
+Copyright (C) 1996 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.
+
+*/
+
+#if !defined (octave_f77_fcn_h)
+#define octave_f77_fcn_h 1
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <setjmp.h>
+
+/* Some Fortran compilers append underscores or generate uppercase
+   external names. */
+
+#if defined (F77_APPEND_UNDERSCORE)
+#if defined (F77_UPPERCASE_NAMES)
+#define F77_FCN(f, F) F##_
+#else
+#define F77_FCN(f, F) f##_
+#endif
+#else
+#if defined (F77_UPPERCASE_NAMES)
+#define F77_FCN(f, F) F
+#else
+#define F77_FCN(f, F) f
+#endif
+#endif
+
+/* How to print an error for the F77_XFCN macro. */
+
+#if defined (F77_UPPERCASE_NAMES)
+#define F77_XFCN_ERROR(f, F) \
+  (*current_liboctave_error_handler) \
+    ("exception encountered in Fortran subroutine %s", #F)
+#else
+#define F77_XFCN_ERROR(f, F) \
+  (*current_liboctave_error_handler) \
+    ("exception encountered in Fortran subroutine %s", #f)
+#endif
+
+/* This can be used to call a Fortran subroutine that might call
+   XSTOPX.  XSTOPX will call lonjmp with f77_context and we'll return,
+   call the error function, restore the previous context.  After using
+   this macro, error_state should be checked. */
+
+#define F77_XFCN(f, F, args) \
+  do \
+    { \
+      jmp_buf saved_f77_context; \
+      f77_exception_encountered = 0; \
+      copy_f77_context ((char *) f77_context, (char *) saved_f77_context, \
+			sizeof (jmp_buf)); \
+      if (setjmp (f77_context)) \
+	{ \
+	  f77_exception_encountered = 1; \
+	  F77_XFCN_ERROR (f, F); \
+	} \
+      else \
+	F77_FCN (f, F) args; \
+      copy_f77_context ((char *) saved_f77_context, (char *) f77_context, \
+			sizeof (jmp_buf)); \
+    } \
+  while (0)
+
+/* So we can check to see if an exception has occurred. */
+extern int f77_exception_encountered;
+
+/* For setjmp/longjmp. */
+extern jmp_buf f77_context;
+
+/* Defining this as a separate function allows us to avoid having to
+   include string.h in this file. */
+
+extern void copy_f77_context (void *, void *, unsigned int);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+/*
+;;; Local Variables: ***
+;;; mode: C++ ***
+;;; End: ***
+*/