# HG changeset patch # User John W. Eaton # Date 1492863174 14400 # Node ID 58d56f52d50ae8757a21655c6af44a044b4cca15 # Parent 7dfa3bc8e3d53ebf323d3beaf5fc087b8b4633b2 move contents of liboctave/cruft/misc to liboctave/util * blaswrap.c, cquit.c, d1mach-tst.for, d1mach.f, f77-extern.cc, f77-fcn.c, f77-fcn.h, i1mach.f, lo-error.c, lo-error.h, quit.cc, quit.h, r1mach.f: Move from liboctave/cruft/misc to liboctave/util. * configure.ac, etc/HACKING, libgui/graphics/module.mk, libgui/src/module.mk, libinterp/module.mk, liboctave/module.mk, liboctave/cruft/module.mk, liboctave/util/module.mk, src/module.mk: Update. * liboctave/cruft/misc/module.mk: Delete. diff -r 7dfa3bc8e3d5 -r 58d56f52d50a configure.ac --- a/configure.ac Thu Apr 20 12:34:40 2017 -0400 +++ b/configure.ac Sat Apr 22 08:12:54 2017 -0400 @@ -997,7 +997,7 @@ CFLAGS="$CFLAGS -DUSE_BLASWRAP" AC_LANG_PUSH(C) AC_COMPILE_IFELSE([AC_LANG_SOURCE([[ - #include "liboctave/cruft/misc/blaswrap.c" + #include "liboctave/util/blaswrap.c" ]])], [mv conftest.$ac_objext blaswrap.$ac_objext octave_blaswrap_save_BLAS_LIBS="$BLAS_LIBS" @@ -1014,14 +1014,14 @@ ## remove temp file rm -f blaswrap.$ac_objext], - [AC_MSG_FAILURE([cannot compile liboctave/cruft/misc/blaswrap.c])]) + [AC_MSG_FAILURE([cannot compile liboctave/util/blaswrap.c])]) AC_LANG_POP(C) CFLAGS="$octave_blaswrap_save_CFLAGS" if test $ax_blas_ok = no; then BLAS_LIBS="$octave_blaswrap_save_BLAS_LIBS" else - ## wrapper in cruft, remove from BLAS_LIBS + ## wrapper in liboctave/util, remove from BLAS_LIBS BLAS_LIBS=`echo $BLAS_LIBS | $SED -e 's/blaswrap.[[^ ]]* //g'` AC_DEFINE(USE_BLASWRAP, 1, [Define to 1 if BLAS functions need to be wrapped (potentially needed for 64-bit OSX only).]) diff -r 7dfa3bc8e3d5 -r 58d56f52d50a etc/HACKING --- a/etc/HACKING Thu Apr 20 12:34:40 2017 -0400 +++ b/etc/HACKING Sat Apr 22 08:12:54 2017 -0400 @@ -185,8 +185,6 @@ lapack-xtra wrappers for lapack functions used in Octave - misc miscellaneous utilities - odepack ordinary differential equation solver ordered-qz code for ordering eigenvalues for QZ factorization diff -r 7dfa3bc8e3d5 -r 58d56f52d50a libgui/graphics/module.mk --- a/libgui/graphics/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ b/libgui/graphics/module.mk Sat Apr 22 08:12:54 2017 -0400 @@ -135,7 +135,6 @@ @QT_CPPFLAGS@ \ -Ilibgui/graphics -I$(srcdir)/libgui/graphics \ -Isrc -I$(srcdir)/libgui/src \ - -I$(srcdir)/liboctave/cruft/misc \ -I$(srcdir)/liboctave/array \ -Iliboctave/numeric -I$(srcdir)/liboctave/numeric \ -Iliboctave/operators -I$(srcdir)/liboctave/operators \ diff -r 7dfa3bc8e3d5 -r 58d56f52d50a libgui/src/module.mk --- a/libgui/src/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ b/libgui/src/module.mk Sat Apr 22 08:12:54 2017 -0400 @@ -220,7 +220,6 @@ -I$(srcdir)/libgui/src/m-editor \ -I$(srcdir)/libgui/src/qtinfo \ -I$(srcdir)/libgui/graphics \ - -I$(srcdir)/liboctave/cruft/misc \ -I$(srcdir)/liboctave/array \ -Iliboctave/numeric -I$(srcdir)/liboctave/numeric \ -Iliboctave/operators -I$(srcdir)/liboctave/operators \ diff -r 7dfa3bc8e3d5 -r 58d56f52d50a libinterp/module.mk --- a/libinterp/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ b/libinterp/module.mk Sat Apr 22 08:12:54 2017 -0400 @@ -8,7 +8,6 @@ libinterp_liboctinterp_la_CPPFLAGS = \ @OCTINTERP_DLL_DEFS@ \ -Iliboctave -I$(srcdir)/liboctave \ - -I$(srcdir)/liboctave/cruft/misc \ -I$(srcdir)/liboctave/array \ -Iliboctave/numeric -I$(srcdir)/liboctave/numeric \ -Iliboctave/operators -I$(srcdir)/liboctave/operators \ diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/blaswrap.c --- a/liboctave/cruft/misc/blaswrap.c Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,294 +0,0 @@ -/* - -Copyright (C) 2012-2017 Jarno Rajahalme - -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 3 of the License, 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, see -. - -*/ - -/* - -Wrapper for Apple libBLAS.dylib and libLAPACK.dylib - -At least on the versions of OSX 10.6 so far (up and including 10.6.6) -these libraries are incompatible with 64 bit builds, as some functions -in libBLAS.dylib are not conforming to F2C calling conventions, as -they should. This breaks them in 64-bit builds on the x86_64 -architecture. - -Newer gfortran compoilers no longer default to the F2C calling -convention. These wrappers map the F2C conformant functions in -libBLAS and libLAPACK to the native gfortran calling convention, so -that the libraries can be used with software built for x86_64 -architecture. - -*/ - -#if defined (HAVE_CONFIG_H) -# include "config.h" /* USE_BLASWRAP ? */ -#endif - -#if defined (USE_BLASWRAP) - -/* - * vecLib is an Apple framework (collection of libraries) containing - * libBLAS and libLAPACK. The fortran stubs in these libraries are - * (mostly, but not completely) in the F2C calling convention. - * We access the libraries via the vecLib framework to make sure we - * get the Apple versions, rather than some other blas/lapack with the - * same name. - */ -#if ! defined (VECLIB_FILE) -# define VECLIB_FILE "/System/Library/Frameworks/vecLib.framework/Versions/A/vecLib" -#endif - -/* - * Since this is a wrapper for fortran functions, - * we do not have prototypes for them. - */ -#pragma GCC diagnostic ignored "-Wmissing-prototypes" - -#include -#include - -/* - * Apple LAPACK follows F2C calling convention, - * Convert to normal gfortran calling convention - */ - -static void (*f2c_blas_func[]) (void); /* forward declaration for wrapper */ -static void (*f2c_lapack_func[]) (void); /* forward declaration for wrapper */ - -/* - * LAPACK Wrappers, only need to convert the return value from double to float - */ - -typedef double (*F2C_CALL_0) (void); -typedef double (*F2C_CALL_1) (void *a1); -typedef double (*F2C_CALL_2) (void *a1, void *a2); -typedef double (*F2C_CALL_3) (void *a1, void *a2, void *a3); -typedef double (*F2C_CALL_4) (void *a1, void *a2, void *a3, void *a4); -typedef double (*F2C_CALL_5) (void *a1, void *a2, void *a3, void *a4, void *a5); -typedef double (*F2C_CALL_6) (void *a1, void *a2, void *a3, void *a4, void *a5, - void *a6); -typedef double (*F2C_CALL_7) (void *a1, void *a2, void *a3, void *a4, void *a5, - void *a6, void *a7); -typedef double (*F2C_CALL_8) (void *a1, void *a2, void *a3, void *a4, void *a5, - void *a6, void *a7, void *a8); - -#define F2C_LAPACK_CALL_8(name) \ - float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6, void *a7, void *a8) \ - { \ - return ((F2C_CALL_8)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6, a7, a8); \ - } - -#define F2C_LAPACK_CALL_7(name) \ - float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6, void *a7) \ - { \ - return ((F2C_CALL_7)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6, a7); \ - } - -#define F2C_LAPACK_CALL_6(name) \ - float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6) \ - { \ - return ((F2C_CALL_6)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6); \ - } - -#define F2C_LAPACK_CALL_5(name) \ - float name (void *a1, void *a2, void *a3, void *a4, void *a5) \ - { \ - return ((F2C_CALL_5)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5); \ - } - -#define F2C_LAPACK_CALL_4(name) \ - float name (void *a1, void *a2, void *a3, void *a4) \ - { \ - return ((F2C_CALL_4)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4); \ - } - -#define F2C_LAPACK_CALL_3(name) \ - float name (void *a1, void *a2, void *a3) \ - { \ - return ((F2C_CALL_3)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3); \ - } - -#define F2C_LAPACK_CALL_2(name) \ - float name (void *a1, void *a2) \ - { \ - return ((F2C_CALL_2)f2c_lapack_func[f2c_ ## name]) (a1, a2); \ - } - -#define F2C_LAPACK_CALL_1(name) \ - float name (void *a1) \ - { \ - return ((F2C_CALL_1)f2c_lapack_func[f2c_ ## name]) (a1); \ - } - -#define F2C_LAPACK_CALL_0(name) \ - float name (void) \ - { \ - return ((F2C_CALL_0)f2c_lapack_func[f2c_ ## name]) (); \ - } - -#define F2C_LAPACK_CALL_NONE(name) - -#define F2C_LAPACK_CALL(name, args) F2C_LAPACK_CALL_ ## args (name) - -#define ENUM_ITEM(name, args) \ - f2c_ ## name, - -#define NAME_TO_STRING_CASE(name, args) \ - case f2c_ ## name: return #name; - -#define DEFINE_LAPACK_ENUM(name, list) \ - typedef enum { \ - list(ENUM_ITEM) \ - } name; \ - static const char* \ - f2c_ ## name ## _name (name n) { \ - switch (n) { \ - list(NAME_TO_STRING_CASE) \ - default: return ""; \ - } \ - } \ - list(F2C_LAPACK_CALL) - -#define DEFINE_BLAS_ENUM(name, list) \ - typedef enum { \ - list(ENUM_ITEM) \ - } name; \ - static const char* \ - f2c_ ## name ## _name(name n) { \ - switch (n) { \ - list(NAME_TO_STRING_CASE) \ - default: return ""; \ - } \ - } - -/* - * Lapack functions (with argument count) that need the return value - * converted from double to float - */ -#define LAPACK_LIST(_) \ - _(clangb_,7) \ - _(clange_,6) \ - _(clangt_,5) \ - _(clanhb_,7) \ - _(clanhe_,6) \ - _(clanhp_,5) \ - _(clanhs_,5) \ - _(clanht_,4) \ - _(clansb_,7) \ - _(clansp_,5) \ - _(clansy_,6) \ - _(clantb_,8) \ - _(clantp_,6) \ - _(clantr_,8) \ - _(scsum1_,3) \ - _(second_,0) \ - _(slamc3_,2) \ - _(slamch_,1) \ - _(slangb_,7) \ - _(slange_,6) \ - _(slangt_,5) \ - _(slanhs_,5) \ - _(slansb_,7) \ - _(slansp_,5) \ - _(slanst_,4) \ - _(slansy_,6) \ - _(slantb_,8) \ - _(slantp_,6) \ - _(slantr_,8) \ - _(slapy2_,2) \ - _(slapy3_,3) \ - _(LAPACK_COUNT,NONE) - -/* - * These need a bit more complex wrappers - */ -#define BLAS_LIST(_) \ - _(cdotu_,6) \ - _(zdotu_,6) \ - _(cdotc_,6) \ - _(zdotc_,6) \ - _(BLAS_COUNT,NONE) - -DEFINE_BLAS_ENUM(blas, BLAS_LIST) - -DEFINE_LAPACK_ENUM(lapack, LAPACK_LIST) - -/* - * BLAS wrappers, F2C convention passes retuned complex as an extra first - * argument - */ -typedef struct { float r, i; } complex; -typedef struct { double r, i; } doublecomplex; - -typedef void (*F2C_BLAS_CALL_6) (void *c, void *a1, void *a2, void *a3, - void *a4, void *a5); - -#define F2C_BLAS_CALL(type, name) \ -type name (void *a1, void *a2, void *a3, void *a4, void *a5) \ -{ \ - type cplx; \ - ((F2C_BLAS_CALL_6)f2c_blas_func[f2c_ ## name]) (&cplx, a1, a2, a3, a4, a5); \ - return cplx; \ -} - -F2C_BLAS_CALL(complex, cdotu_) -F2C_BLAS_CALL(doublecomplex, zdotu_) -F2C_BLAS_CALL(complex, cdotc_) -F2C_BLAS_CALL(doublecomplex, zdotc_) - -/* - * Function pointer arrays, indexed by the enums - */ -static void (*f2c_blas_func[f2c_BLAS_COUNT]) (void) = { 0 }; -static void (*f2c_lapack_func[f2c_LAPACK_COUNT]) (void) = { 0 }; - -/* - * Initialization: This is called before main (). - * Get the function pointers to the wrapped functions in Apple vecLib - */ - -static void * apple_vecLib = 0; - -__attribute__((constructor)) -static void initVecLibWrappers (void) -{ - apple_vecLib = dlopen (VECLIB_FILE, RTLD_LOCAL | RTLD_NOLOAD | RTLD_FIRST); - if (0 == apple_vecLib) - abort (); - - int i; - for (i = 0; i < f2c_LAPACK_COUNT; i++) - if (0 == (f2c_lapack_func[i] = dlsym (apple_vecLib, f2c_lapack_name(i)))) - abort (); - for (i = 0; i < f2c_BLAS_COUNT; i++) - if (0 == (f2c_blas_func[i] = dlsym (apple_vecLib, f2c_blas_name(i)))) - abort (); -} - -__attribute__((destructor)) -static void finiVecLibWrappers (void) -{ - if (apple_vecLib) - dlclose (apple_vecLib); - apple_vecLib = 0; -} - -#endif /* USE_BLASWRAP */ diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/cquit.c --- a/liboctave/cruft/misc/cquit.c Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,66 +0,0 @@ -/* - -Copyright (C) 2003-2017 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 3 of the License, 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, see -. - -*/ - -#if defined (HAVE_CONFIG_H) -# include "config.h" -#endif - -#include -#include - -#include "quit.h" - -octave_jmp_buf current_context; - -void -octave_save_current_context (void *save_buf) -{ - memcpy (save_buf, current_context, sizeof (octave_jmp_buf)); -} - -void -octave_restore_current_context (void *save_buf) -{ - memcpy (current_context, save_buf, sizeof (octave_jmp_buf)); -} - -void -octave_jump_to_enclosing_context (void) -{ -#if defined (OCTAVE_HAVE_SIG_JUMP) - siglongjmp (current_context, 1); -#else - longjmp (current_context, 1); -#endif -} - -sig_atomic_t octave_interrupt_immediately = 0; - -sig_atomic_t octave_interrupt_state = 0; - -sig_atomic_t octave_exception_state = 0; - -sig_atomic_t octave_exit_exception_status = 0; - -sig_atomic_t octave_exit_exception_safe_to_return = 0; - -volatile sig_atomic_t octave_signal_caught = 0; diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/d1mach-tst.for --- a/liboctave/cruft/misc/d1mach-tst.for Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ - program main - integer i - double precision d1mach - double precision t1, t2 - do 10 i = 1, 5 - print *, d1mach (i) - 10 continue - end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/d1mach.f --- a/liboctave/cruft/misc/d1mach.f Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ - double precision function d1mach (i) - integer i - logical init - double precision dmach(5) - double precision dlamch - external dlamch - save init, dmach - data init /.false./ - if (.not. init) then - dmach(1) = dlamch ('u') - dmach(2) = dlamch ('o') - dmach(3) = dlamch ('e') - dmach(4) = dlamch ('p') - dmach(5) = log10 (dlamch ('b')) - init = .true. - endif - if (i .lt. 1 .or. i .gt. 5) goto 999 - d1mach = dmach(i) - return - 999 write (*, 1999) i - 1999 format (' d1mach - i out of bounds', i10) - call xstopx (' ') - d1mach = 0 - end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/f77-extern.cc --- a/liboctave/cruft/misc/f77-extern.cc Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,35 +0,0 @@ -// misc-extern.cc -*- C++ -*- -/* - -Copyright (C) 1996-2017 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 3 of the License, 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, see -. - -*/ - -#if defined (HAVE_CONFIG_H) -# include "config.h" -#endif - -#include "f77-fcn.h" -#include "lo-error.h" - -// This whole file is a kluge just to avoid unresolved symbol errors -// when creating shared versions of libcruft. - -// So we can check to see if an exception has occurred. -int f77_exception_encountered = 0; diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/f77-fcn.c --- a/liboctave/cruft/misc/f77-fcn.c Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -/* - -Copyright (C) 1996-2017 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 3 of the License, 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, see -. - -*/ - -#if defined (HAVE_CONFIG_H) -# include "config.h" -#endif - -#include -#include - -#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. - - Note that the order of arguments for the Visual Fortran function - signature is the same as for gfortran and f2c only becuase there is - a single assumed size character string argument. Visual Fortran - inserts the length after each character string argument, f2c appends - all length arguments at the end of the parameter list, and gfortran - appends length arguments for assumed size character strings to the - end of the list (ignoring others). */ - -F77_RET_T -#if defined (F77_USES_CRAY_CALLING_CONVENTION) -F77_FUNC (xstopx, XSTOPX) (octave_cray_ftn_ch_dsc desc) -#else -F77_FUNC (xstopx, XSTOPX) (const char *s, F77_CHAR_ARG_LEN_TYPE 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_NORETURN (0) -} diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/f77-fcn.h --- a/liboctave/cruft/misc/f77-fcn.h Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -/* - -Copyright (C) 1996-2017 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 3 of the License, 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, see -. - -*/ - -#if ! defined (octave_f77_fcn_h) -#define octave_f77_fcn_h 1 - -#include "octave-config.h" - -#include "lo-error.h" -#include "quit.h" - -#if defined (__cplusplus) -# include -#endif - -#if defined (__cplusplus) -extern "C" { -#endif - -/* Hack to stringize macro results. */ -#define xSTRINGIZE(x) #x -#define STRINGIZE(x) xSTRINGIZE(x) - -/* How to print an error for the F77_XFCN macro. */ - -#define F77_XFCN_ERROR(f, F) \ - (*current_liboctave_error_handler) \ - ("exception encountered in Fortran subroutine %s", \ - STRINGIZE (F77_FUNC (f, F))) - -/* This can be used to call a Fortran subroutine that might call - XSTOPX. XSTOPX will call lonjmp with current_context. Once back - here, we'll restore the previous context and return. We may also - end up here if an interrupt is processed when the Fortran - subroutine is called. In that case, we resotre the context and go - to the top level. */ - -#define F77_XFCN(f, F, args) \ - do \ - { \ - octave_jmp_buf saved_context; \ - sig_atomic_t saved_octave_interrupt_immediately = octave_interrupt_immediately; \ - f77_exception_encountered = 0; \ - octave_save_current_context (saved_context); \ - if (octave_set_current_context) \ - { \ - octave_interrupt_immediately = saved_octave_interrupt_immediately; \ - octave_restore_current_context (saved_context); \ - if (f77_exception_encountered) \ - F77_XFCN_ERROR (f, F); \ - else \ - octave_rethrow_exception (); \ - } \ - else \ - { \ - octave_interrupt_immediately++; \ - F77_FUNC (f, F) args; \ - octave_interrupt_immediately--; \ - octave_restore_current_context (saved_context); \ - } \ - } \ - while (0) - -/* So we can check to see if an exception has occurred. */ -OCTAVE_API extern int f77_exception_encountered; - -#if ! defined (F77_FCN) -#define F77_FCN(f, F) F77_FUNC (f, F) -#endif - -/* - -The following macros are used for handling Fortran <-> C calling -conventions. They are defined below for three different types of -systems, Cray (possibly now obsolete), Visual Fortran, and gfortran. -Note that we don't attempt to handle Fortran functions, we always use -subroutine wrappers for them and pass the return value as an extra -argument. - -Use these macros to pass character strings from C to Fortran: - - F77_CHAR_ARG(x) - F77_CONST_CHAR_ARG(x) - F77_CXX_STRING_ARG(x) - F77_CHAR_ARG_LEN(l) - F77_CHAR_ARG_DECL - F77_CONST_CHAR_ARG_DECL - F77_CHAR_ARG_LEN_DECL - -Use these macros to write C-language functions that accept -Fortran-style character strings: - - F77_CHAR_ARG_DEF(s, len) - F77_CONST_CHAR_ARG_DEF(s, len) - F77_CHAR_ARG_LEN_DEF(len) - F77_CHAR_ARG_USE(s) - F77_CHAR_ARG_LEN_USE(s, len) - -Use these macros for C++ code - - F77_INT Equivalent to Fortran INTEGER type - F77_INT4 Equivalent to Fortran INTEGER*4 type - F77_DBLE Equivalent to Fortran DOUBLE PRECISION type - F77_REAL Equivalent to Fortran REAL type - F77_CMPLX Equivalent to Fortran COMPLEX type - F77_DBLE_CMPLX Equivalent to Fortran DOUBLE COMPLEX type - F77_LOGICAL Equivalent to Fortran LOGICAL type - F77_RET_T Return type of a C++ function that acts like a - Fortran subroutine. - -Use these macros to return from C-language functions that are supposed -to act like Fortran subroutines. F77_NORETURN is intended to be used -as the last statement of such a function that has been tagged with a -"noreturn" attribute. If the compiler supports the "noreturn" -attribute or if F77_RET_T is void, then it should expand to nothing so -that we avoid warnings about functions tagged as "noreturn" -containing a return statement. Otherwise, it should expand to a -statement that returns the given value so that we avoid warnings about -not returning a value from a function declared to return something. - - F77_RETURN(retval) - F77_NORETURN(retval) - -*/ - -#if defined (F77_USES_CRAY_CALLING_CONVENTION) - -#include - -/* Use these macros to pass character strings from C to Fortran. Cray - Fortran uses a descriptor structure to pass a pointer to the string - and the length in a single argument. */ - -#define F77_CHAR_ARG(x) octave_make_cray_ftn_ch_dsc (x, strlen (x)) -#define F77_CONST_CHAR_ARG(x) \ - octave_make_cray_const_ftn_ch_dsc (x, strlen (x)) -#define F77_CHAR_ARG2(x, l) octave_make_cray_ftn_ch_dsc (x, l) -#define F77_CONST_CHAR_ARG2(x, l) octave_make_cray_const_ftn_ch_dsc (x, l) -#define F77_CXX_STRING_ARG(x) \ - octave_make_cray_const_ftn_ch_dsc (x.c_str (), x.length ()) -#define F77_CHAR_ARG_LEN(l) -#define F77_CHAR_ARG_LEN_TYPE -#define F77_CHAR_ARG_LEN_DECL -#define F77_CHAR_ARG_DECL octave_cray_ftn_ch_dsc -#define F77_CONST_CHAR_ARG_DECL octave_cray_ftn_ch_dsc - -/* Use these macros to write C-language functions that accept - Fortran-style character strings. */ -#define F77_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s -#define F77_CONST_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s -#define F77_CHAR_ARG_LEN_DEF(len) -#define F77_CHAR_ARG_USE(s) s.ptr -#define F77_CHAR_ARG_LEN_USE(s, len) (s.mask.len >> 3) - -#define F77_RET_T int - -/* Use these macros to return from C-language functions that are - supposed to act like Fortran subroutines. F77_NORETURN is intended - to be used as the last statement of such a function that has been - tagged with a "noreturn" attribute. */ - -#define F77_RETURN(retval) return retval; -#if defined (HAVE_OCTAVE_NORETURN_ATTR) -# define F77_NORETURN(retval) -#else -# define F77_NORETURN(retval) return retval; -#endif - -/* FIXME: These should work for SV1 or Y-MP systems but will - need to be changed for others. */ - -typedef union -{ - const char *const_ptr; - char *ptr; - struct - { - unsigned off : 6; - unsigned len : 26; - unsigned add : 32; - } mask; -} octave_cray_descriptor; - -typedef void *octave_cray_ftn_ch_dsc; - - #if defined (__cplusplus) -# define OCTAVE_F77_FCN_INLINE inline -#else -# define OCTAVE_F77_FCN_INLINE -#endif - -static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc -octave_make_cray_ftn_ch_dsc (char *ptr_arg, unsigned long len_arg) -{ - octave_cray_descriptor desc; - desc.ptr = ptr_arg; - desc.mask.len = len_arg << 3; - return *((octave_cray_ftn_ch_dsc *) &desc); -} - -static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc -octave_make_cray_const_ftn_ch_dsc (const char *ptr_arg, unsigned long len_arg) -{ - octave_cray_descriptor desc; - desc.const_ptr = ptr_arg; - desc.mask.len = len_arg << 3; - return *((octave_cray_ftn_ch_dsc *) &desc); -} - -#undef OCTAVE_F77_FCN_INLINE - -#elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION) - -/* Use these macros to pass character strings from C to Fortran. - Visual Fortran inserts the length after each character string - argument. */ - -#define F77_CHAR_ARG(x) x, strlen (x) -#define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) -#define F77_CHAR_ARG2(x, l) x, l -#define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) -#define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) -#define F77_CHAR_ARG_LEN(l) -#define F77_CHAR_ARG_LEN_TYPE int -#define F77_CHAR_ARG_LEN_DECL -#define F77_CHAR_ARG_DECL char *, F77_CHAR_ARG_LEN_TYPE -#define F77_CONST_CHAR_ARG_DECL const char *, F77_CHAR_ARG_LEN_TYPE - -#define F77_CHAR_ARG_DEF(s, len) char *s, F77_CHAR_ARG_LEN_TYPE len -#define F77_CONST_CHAR_ARG_DEF(s, len) const char *s, F77_CHAR_ARG_LEN_TYPE len -#define F77_CHAR_ARG_LEN_DEF(len) -#define F77_CHAR_ARG_USE(s) s -#define F77_CHAR_ARG_LEN_USE(s, len) len - -#define F77_RET_T void - -#define F77_RETURN(retval) return; -#define F77_NORETURN(retval) - -#elif defined (F77_USES_GFORTRAN_CALLING_CONVENTION) - -/* Use these macros to pass character strings from C to Fortran. - gfortran appends length arguments for assumed size character - strings to the and ignores others. - - FIXME: I don't think we correctly handle the case of mixing some - fixed-length and some assumed-length character string arguments as - we don't handle each case separately, so it seems there could be - mismatch? However, I don't think we currently have to handle this - case in Octave. */ - -#define F77_CHAR_ARG(x) x -#define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) -#define F77_CHAR_ARG2(x, l) x -#define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) -#define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) -#define F77_CHAR_ARG_LEN(l) , l -#define F77_CHAR_ARG_LEN_TYPE int -#define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE -#define F77_CHAR_ARG_DECL char * -#define F77_CONST_CHAR_ARG_DECL const char * - -#define F77_CHAR_ARG_DEF(s, len) char *s -#define F77_CONST_CHAR_ARG_DEF(s, len) const char *s -#define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len -#define F77_CHAR_ARG_USE(s) s -#define F77_CHAR_ARG_LEN_USE(s, len) len - -#define F77_RET_T void - -#define F77_RETURN(retval) return; -#if defined (HAVE_OCTAVE_NORETURN_ATTR) -# define F77_NORETURN(retval) -#else -# define F77_NORETURN(retval) return retval; -#endif - -#elif defined (F77_USES_F2C_CALLING_CONVENTION) - -/* Assume f2c-compatible calling convention. */ - -/* Use these macros to pass character strings from C to Fortran. f2c - appends all length arguments at the end of the parameter list. */ - -#define F77_CHAR_ARG(x) x -#define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) -#define F77_CHAR_ARG2(x, l) x -#define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) -#define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) -#define F77_CHAR_ARG_LEN(l) , l -#define F77_CHAR_ARG_LEN_TYPE long -#define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE -#define F77_CHAR_ARG_DECL char * -#define F77_CONST_CHAR_ARG_DECL const char * - -#define F77_CHAR_ARG_DEF(s, len) char *s -#define F77_CONST_CHAR_ARG_DEF(s, len) const char *s -#define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len -#define F77_CHAR_ARG_USE(s) s -#define F77_CHAR_ARG_LEN_USE(s, len) len - -#define F77_RET_T int - -#define F77_RETURN(retval) return retval; -#if defined (HAVE_OCTAVE_NORETURN_ATTR) -# define F77_NORETURN(retval) -#else -# define F77_NORETURN(retval) return retval; -#endif - -#else - -#error "unknown C++ to Fortran calling convention" - -#endif - -typedef double F77_DBLE; -typedef float F77_REAL; -typedef double _Complex F77_DBLE_CMPLX; -typedef float _Complex F77_CMPLX; -typedef octave_f77_int_type F77_INT; -typedef int32_t F77_INT4; -typedef octave_f77_int_type F77_LOGICAL; - -#define F77_CMPLX_ARG(x) \ - reinterpret_cast (x) - -#define F77_CONST_CMPLX_ARG(x) \ - reinterpret_cast (x) - -#define F77_DBLE_CMPLX_ARG(x) \ - reinterpret_cast (x) - -#define F77_CONST_DBLE_CMPLX_ARG(x) \ - reinterpret_cast (x) - -/* Build a C string local variable CS from the Fortran string parameter S - declared as F77_CHAR_ARG_DEF(s, len) or F77_CONST_CHAR_ARG_DEF(s, len). - The string will be cleaned up at the end of the current block. - Needs to include and . */ - -#define F77_CSTRING(s, len, cs) \ - OCTAVE_LOCAL_BUFFER (char, cs, F77_CHAR_ARG_LEN_USE (s, len) + 1); \ - memcpy (cs, F77_CHAR_ARG_USE (s), F77_CHAR_ARG_LEN_USE (s, len)); \ - cs[F77_CHAR_ARG_LEN_USE(s, len)] = '\0' - -OCTAVE_NORETURN OCTAVE_API extern -F77_RET_T -F77_FUNC (xstopx, XSTOPX) (F77_CONST_CHAR_ARG_DECL - F77_CHAR_ARG_LEN_DECL); - -#if defined (__cplusplus) - -namespace octave -{ - inline F77_INT - to_f77_int (octave_idx_type x) - { - if (x < std::numeric_limits::min () - || x > std::numeric_limits::max ()) - (*current_liboctave_error_handler) - ("integer dimension or index out of range for Fortran INTEGER type"); - - return static_cast (x); - } -} - -#endif - -#if defined (__cplusplus) -} -#endif - -#endif diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/i1mach.f --- a/liboctave/cruft/misc/i1mach.f Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ - integer function i1mach (i) - integer i, imach(16) - logical init - double precision dlamch - real slamch - external dlamch, slamch - save imach, init - data imach / 5, 6, 0, 6, 32, 4, 2, 31, 2147483647, - $ 2, 0, 0, 0, 0, 0, 0 / - data init /.false./ - if (.not. init) then - imach(11) = slamch ('n') - imach(12) = slamch ('m') - imach(13) = slamch ('l') - imach(14) = dlamch ('n') - imach(15) = dlamch ('m') - imach(16) = dlamch ('l') - init = .true. - endif - if (i .lt. 1 .or. i .gt. 16) goto 999 - i1mach = imach(i) - return - 999 write (*, 1999) i - 1999 format (' i1mach - i out of bounds', i10) - call xstopx (' ') - i1mach = 0 - end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/lo-error.c --- a/liboctave/cruft/misc/lo-error.c Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -/* - -Copyright (C) 1996-2017 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 3 of the License, 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, see -. - -*/ - -#if defined (HAVE_CONFIG_H) -# include "config.h" -#endif - -#include -#include -#include - -#include "lo-error.h" - -/* Having this file in this directory is a kluge to avoid unresolved - symbol errors when creating shared versions of libcruft. */ - -/* Pointer to the current error handling function. */ -OCTAVE_NORETURN liboctave_error_handler - current_liboctave_error_handler = liboctave_fatal; - -/* Pointer to the current error_with_id handling function. */ -OCTAVE_NORETURN liboctave_error_with_id_handler - current_liboctave_error_with_id_handler = liboctave_fatal_with_id; - -/* Pointer to the current warning handler. */ -liboctave_warning_handler - current_liboctave_warning_handler = liboctave_warning; - -/* Pointer to the current warning_with_id handler. */ -liboctave_warning_with_id_handler - current_liboctave_warning_with_id_handler = liboctave_warning_with_id; - -static void -verror (const char *name, const char *fmt, va_list args) -{ - if (name) - fprintf (stderr, "%s: ", name); - - vfprintf (stderr, fmt, args); - fprintf (stderr, "\n"); - fflush (stderr); -} - -void -set_liboctave_error_handler (OCTAVE_NORETURN liboctave_error_handler f) -{ - if (f) - current_liboctave_error_handler = f; - else - current_liboctave_error_handler = liboctave_fatal; -} - -void -set_liboctave_error_with_id_handler (OCTAVE_NORETURN - liboctave_error_with_id_handler f) -{ - if (f) - current_liboctave_error_with_id_handler = f; - else - current_liboctave_error_with_id_handler = liboctave_fatal_with_id; -} - -void -set_liboctave_warning_handler (liboctave_warning_handler f) -{ - if (f) - current_liboctave_warning_handler = f; - else - current_liboctave_warning_handler = liboctave_warning; -} - -void -set_liboctave_warning_with_id_handler (liboctave_warning_with_id_handler f) -{ - if (f) - current_liboctave_warning_with_id_handler = f; - else - current_liboctave_warning_with_id_handler = liboctave_warning_with_id; -} - -void -liboctave_fatal (const char *fmt, ...) -{ - va_list args; - va_start (args, fmt); - verror ("fatal", fmt, args); - va_end (args); - - exit (1); -} - -void -liboctave_fatal_with_id (const char *id, const char *fmt, ...) -{ - octave_unused_parameter (id); - - va_list args; - va_start (args, fmt); - verror ("fatal", fmt, args); - va_end (args); - - exit (1); -} - -void -liboctave_warning (const char *fmt, ...) -{ - va_list args; - va_start (args, fmt); - verror ("warning", fmt, args); - va_end (args); -} - -void -liboctave_warning_with_id (const char *id, const char *fmt, ...) -{ - octave_unused_parameter (id); - - va_list args; - va_start (args, fmt); - verror ("warning", fmt, args); - va_end (args); -} diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/lo-error.h --- a/liboctave/cruft/misc/lo-error.h Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -/* - -Copyright (C) 1996-2017 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 3 of the License, 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, see -. - -*/ - -#if ! defined (octave_lo_error_h) -#define octave_lo_error_h 1 - -#include "octave-config.h" - -#if defined (__cplusplus) -extern "C" { -#endif - -OCTAVE_NORETURN extern void -liboctave_fatal (const char *fmt, ...); - -OCTAVE_NORETURN extern -void liboctave_fatal_with_id (const char *id, const char *fmt, ...); - -extern void -liboctave_warning (const char *fmt, ...); - -extern void -liboctave_warning_with_id (const char *id, const char *fmt, ...); - -typedef void (*liboctave_error_handler) (const char *, ...); - -typedef void (*liboctave_error_with_id_handler) (const char *, const char *, - ...); - -typedef void (*liboctave_warning_handler) (const char *, ...); - -typedef void (*liboctave_warning_with_id_handler) (const char *, const char *, - ...); - -/* Would be nice to make these pointers private, but we want to share - them among all the liboctave classes. */ -OCTAVE_NORETURN OCTAVE_API extern liboctave_error_handler - current_liboctave_error_handler; - -OCTAVE_NORETURN OCTAVE_API extern liboctave_error_with_id_handler - current_liboctave_error_with_id_handler; - -OCTAVE_API extern liboctave_warning_handler current_liboctave_warning_handler; - -OCTAVE_API extern liboctave_warning_with_id_handler - current_liboctave_warning_with_id_handler; - -OCTAVE_API extern void -set_liboctave_error_handler (OCTAVE_NORETURN liboctave_error_handler f); - -OCTAVE_API extern void -set_liboctave_error_with_id_handler (OCTAVE_NORETURN liboctave_error_with_id_handler f); - -OCTAVE_API extern void -set_liboctave_warning_handler (liboctave_warning_handler f); - -OCTAVE_API extern void -set_liboctave_warning_with_id_handler (liboctave_warning_with_id_handler f); - -#if defined (__cplusplus) -} -#endif - -#endif diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/module.mk --- a/liboctave/cruft/misc/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -CRUFT_SOURCES += \ - liboctave/cruft/misc/blaswrap.c \ - liboctave/cruft/misc/cquit.c \ - liboctave/cruft/misc/d1mach.f \ - liboctave/cruft/misc/f77-extern.cc \ - liboctave/cruft/misc/f77-fcn.c \ - liboctave/cruft/misc/i1mach.f \ - liboctave/cruft/misc/lo-error.c \ - liboctave/cruft/misc/quit.cc \ - liboctave/cruft/misc/r1mach.f - -CRUFT_INC += \ - liboctave/cruft/misc/f77-fcn.h \ - liboctave/cruft/misc/lo-error.h \ - liboctave/cruft/misc/quit.h - -liboctave_EXTRA_DIST += \ - liboctave/cruft/misc/d1mach-tst.for diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/quit.cc --- a/liboctave/cruft/misc/quit.cc Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -/* - -Copyright (C) 2002-2017 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 3 of the License, 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, see -. - -*/ - -#if defined (HAVE_CONFIG_H) -# include "config.h" -#endif - -#include - -#include -#include - -#include "quit.h" - -void (*octave_signal_hook) (void) = 0; -void (*octave_interrupt_hook) (void) = 0; -void (*octave_bad_alloc_hook) (void) = 0; - -void -octave_handle_signal (void) -{ - if (octave_signal_hook) - octave_signal_hook (); - - if (octave_interrupt_state > 0) - { - octave_interrupt_state = -1; - octave_throw_interrupt_exception (); - } -} - -void -clean_up_and_exit (int exit_status, bool /* safe_to_return */) -{ - exit (exit_status); -} - -void -octave_throw_interrupt_exception (void) -{ - if (octave_interrupt_hook) - octave_interrupt_hook (); - - throw octave::interrupt_exception (); -} - -void -octave_throw_execution_exception (void) -{ - // FIXME: would a hook function be useful here? - - octave_exception_state = octave_exec_exception; - - throw octave::execution_exception (); -} - -void -octave_throw_bad_alloc (void) -{ - if (octave_bad_alloc_hook) - octave_bad_alloc_hook (); - - octave_exception_state = octave_alloc_exception; - - throw std::bad_alloc (); -} - -void -octave_throw_exit_exception (int exit_status, int safe_to_return) -{ - octave_exception_state = octave_quit_exception; - -#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif - - throw octave_exit_exception (exit_status, safe_to_return); - -#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) -#pragma GCC diagnostic pop -#endif -} - -void -octave_rethrow_exception (void) -{ - if (octave_interrupt_state) - { - octave_interrupt_state = -1; - octave_throw_interrupt_exception (); - } - else - { - switch (octave_exception_state) - { - case octave_exec_exception: - octave_throw_execution_exception (); - break; - - case octave_alloc_exception: - octave_throw_bad_alloc (); - break; - -#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif - - case octave_quit_exception: - octave_throw_exit_exception (octave_exit_exception_status, - octave_exit_exception_safe_to_return); - break; - -#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) -#pragma GCC diagnostic pop -#endif - - default: - break; - } - } -} diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/quit.h --- a/liboctave/cruft/misc/quit.h Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,327 +0,0 @@ -/* - -Copyright (C) 2002-2017 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 3 of the License, 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, see -. - -*/ - -#if ! defined (octave_quit_h) -#define octave_quit_h 1 - -#include "octave-config.h" - -#include - -/* The signal header is just needed for the sig_atomic_t type. */ -#if defined (__cplusplus) -# include -# include -extern "C" { -#else -# include -#endif - -#if defined (OCTAVE_HAVE_SIG_JUMP) - -typedef sigjmp_buf octave_jmp_buf; - -#define octave_set_current_context sigsetjmp (current_context, 1) - -#else - -typedef jmp_buf octave_jmp_buf; - -#define octave_set_current_context setjmp (current_context) - -#endif - -OCTAVE_API extern octave_jmp_buf current_context; - -OCTAVE_API extern void octave_save_current_context (void *); - -OCTAVE_API extern void octave_restore_current_context (void *); - -OCTAVE_NORETURN OCTAVE_API extern void octave_jump_to_enclosing_context (void); - -#if defined (__cplusplus) - -namespace octave -{ - class - execution_exception - { - public: - - execution_exception (void) : m_stack_trace () { } - - execution_exception (const execution_exception& x) - : m_stack_trace (x.m_stack_trace) { } - - execution_exception& operator = (const execution_exception& x) - { - if (&x != this) - m_stack_trace = x.m_stack_trace; - - return *this; - } - - ~execution_exception (void) = default; - - virtual void set_stack_trace (const std::string& st) - { - m_stack_trace = st; - } - - virtual void set_stack_trace (void) - { - m_stack_trace = ""; - } - - virtual std::string info (void) const - { - return m_stack_trace; - } - - private: - - std::string m_stack_trace; - }; - - class - exit_exception - { - public: - - exit_exception (int exit_status = 0, bool safe_to_return = false) - : m_exit_status (exit_status), m_safe_to_return (safe_to_return) - { } - - exit_exception (const exit_exception& ex) - : m_exit_status (ex.m_exit_status), m_safe_to_return (ex.m_safe_to_return) - { } - - exit_exception& operator = (exit_exception& ex) - { - if (this != &ex) - { - m_exit_status = ex.m_exit_status; - m_safe_to_return = ex.m_safe_to_return; - } - - return *this; - } - - ~exit_exception (void) = default; - - int exit_status (void) const { return m_exit_status; } - - bool safe_to_return (void) const { return m_safe_to_return; } - - private: - - int m_exit_status; - - bool m_safe_to_return; - }; - - class - interrupt_exception - { - }; -} - -OCTAVE_DEPRECATED ("use 'octave::execution_exception' instead") -typedef octave::execution_exception octave_execution_exception; - -OCTAVE_DEPRECATED ("use 'octave::exit_exception' instead") -typedef octave::exit_exception octave_exit_exception; - -OCTAVE_DEPRECATED ("use 'octave::interrupt_exception' instead") -typedef octave::interrupt_exception octave_interrupt_exception; - -#endif - -enum octave_exception -{ - octave_no_exception = 0, - octave_exec_exception = 1, - octave_alloc_exception = 3, - octave_quit_exception = 4 -}; - -OCTAVE_API extern sig_atomic_t octave_interrupt_immediately; - -/* - > 0: interrupt pending - 0: no interrupt pending - < 0: handling interrupt -*/ -OCTAVE_API extern sig_atomic_t octave_interrupt_state; - -OCTAVE_API extern sig_atomic_t octave_exception_state; - -OCTAVE_API extern sig_atomic_t octave_exit_exception_status; - -OCTAVE_API extern sig_atomic_t octave_exit_exception_safe_to_return; - -OCTAVE_API extern volatile sig_atomic_t octave_signal_caught; - -OCTAVE_API extern void octave_handle_signal (void); - -OCTAVE_NORETURN OCTAVE_API extern void octave_throw_interrupt_exception (void); - -OCTAVE_NORETURN OCTAVE_API extern void octave_throw_execution_exception (void); - -OCTAVE_NORETURN OCTAVE_API extern void octave_throw_bad_alloc (void); - -OCTAVE_DEPRECATED ("see the Octave documentation for other options") -OCTAVE_NORETURN OCTAVE_API extern void -octave_throw_exit_exception (int exit_status, int safe_to_return); - -OCTAVE_API extern void octave_rethrow_exception (void); - -#if defined (__cplusplus) - -OCTAVE_DEPRECATED ("see the Octave documentation for other options") -extern OCTAVE_API void -clean_up_and_exit (int exit_status, bool safe_to_return = false); - -inline void octave_quit (void) -{ - if (octave_signal_caught) - { - octave_signal_caught = 0; - octave_handle_signal (); - } -}; - -#define OCTAVE_QUIT octave_quit () - -#else - -#define OCTAVE_QUIT \ - do \ - { \ - if (octave_signal_caught) \ - { \ - octave_signal_caught = 0; \ - octave_handle_signal (); \ - } \ - } \ - while (0) -#endif - -/* Normally, you just want to use - - BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; - ... some code that calls a "foreign" function ... - END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; - - but sometimes it is useful to do something like - - BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_1; - ... custom code here, normally ending in a call to - octave_rethrow_exception ... - BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_2; - - so that you can perform extra clean up operations before throwing - the interrupt exception. */ - -#define BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE \ - BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_1; \ - octave_rethrow_exception (); \ - BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_2 - -#define BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_1 \ - do \ - { \ - octave_jmp_buf saved_context; \ - \ - octave_save_current_context (saved_context); \ - \ - if (octave_set_current_context) \ - { \ - octave_restore_current_context (saved_context) - -#define BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_2 \ - } \ - else \ - { \ - octave_interrupt_immediately++ - -#define END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE \ - octave_interrupt_immediately--; \ - octave_restore_current_context (saved_context); \ - octave_quit (); \ - } \ - } \ - while (0) - -#if defined (__cplusplus) - -#define BEGIN_INTERRUPT_WITH_EXCEPTIONS \ - sig_atomic_t saved_octave_interrupt_immediately = octave_interrupt_immediately; \ - \ - try \ - { \ - octave_interrupt_immediately = 0; - -#define END_INTERRUPT_WITH_EXCEPTIONS \ - } \ - catch (const octave::interrupt_exception&) \ - { \ - octave_interrupt_immediately = saved_octave_interrupt_immediately; \ - octave_jump_to_enclosing_context (); \ - } \ - catch (const octave::execution_exception&) \ - { \ - octave_interrupt_immediately = saved_octave_interrupt_immediately; \ - octave_exception_state = octave_exec_exception; \ - octave_jump_to_enclosing_context (); \ - } \ - catch (const std::bad_alloc&) \ - { \ - octave_interrupt_immediately = saved_octave_interrupt_immediately; \ - octave_exception_state = octave_alloc_exception; \ - octave_jump_to_enclosing_context (); \ - } \ - catch (const octave::exit_exception& ex) \ - { \ - octave_interrupt_immediately = saved_octave_interrupt_immediately; \ - octave_exception_state = octave_quit_exception; \ - octave_exit_exception_status = ex.exit_status (); \ - octave_exit_exception_safe_to_return = ex.safe_to_return (); \ - octave_jump_to_enclosing_context (); \ - } \ - \ - octave_interrupt_immediately = saved_octave_interrupt_immediately -#endif - -#if defined (__cplusplus) -} - -/* These should only be declared for C++ code, and should also be - outside of any extern "C" block. */ - -extern OCTAVE_API void (*octave_signal_hook) (void); -extern OCTAVE_API void (*octave_interrupt_hook) (void); -extern OCTAVE_API void (*octave_bad_alloc_hook) (void); - -#endif - -#endif diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/misc/r1mach.f --- a/liboctave/cruft/misc/r1mach.f Thu Apr 20 12:34:40 2017 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ - real function r1mach (i) - integer i - logical init - real rmach(5) - real slamch - external slamch - save init, rmach - data init /.false./ - if (.not. init) then - rmach(1) = slamch ('u') - rmach(2) = slamch ('o') - rmach(3) = slamch ('e') - rmach(4) = slamch ('p') - rmach(5) = log10 (slamch ('b')) - init = .true. - endif - if (i .lt. 1 .or. i .gt. 5) goto 999 - r1mach = rmach(i) - return - 999 write (*, 1999) i - 1999 format (' r1mach - i out of bounds', i10) - call xstopx (' ') - r1mach = 0 - end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/cruft/module.mk --- a/liboctave/cruft/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ b/liboctave/cruft/module.mk Sat Apr 22 08:12:54 2017 -0400 @@ -16,7 +16,6 @@ include liboctave/cruft/Faddeeva/module.mk include liboctave/cruft/fftpack/module.mk include liboctave/cruft/lapack-xtra/module.mk -include liboctave/cruft/misc/module.mk include liboctave/cruft/odepack/module.mk include liboctave/cruft/ordered-qz/module.mk include liboctave/cruft/quadpack/module.mk diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/module.mk --- a/liboctave/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ b/liboctave/module.mk Sat Apr 22 08:12:54 2017 -0400 @@ -11,7 +11,6 @@ @CRUFT_DLL_DEFS@ \ -Iliboctave -I$(srcdir)/liboctave \ -I$(srcdir)/liboctave/array \ - -I$(srcdir)/liboctave/cruft/misc \ -Iliboctave/numeric -I$(srcdir)/liboctave/numeric \ -Iliboctave/operators -I$(srcdir)/liboctave/operators \ -I$(srcdir)/liboctave/system \ diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/blaswrap.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/blaswrap.c Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,294 @@ +/* + +Copyright (C) 2012-2017 Jarno Rajahalme + +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 3 of the License, 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, see +. + +*/ + +/* + +Wrapper for Apple libBLAS.dylib and libLAPACK.dylib + +At least on the versions of OSX 10.6 so far (up and including 10.6.6) +these libraries are incompatible with 64 bit builds, as some functions +in libBLAS.dylib are not conforming to F2C calling conventions, as +they should. This breaks them in 64-bit builds on the x86_64 +architecture. + +Newer gfortran compoilers no longer default to the F2C calling +convention. These wrappers map the F2C conformant functions in +libBLAS and libLAPACK to the native gfortran calling convention, so +that the libraries can be used with software built for x86_64 +architecture. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" /* USE_BLASWRAP ? */ +#endif + +#if defined (USE_BLASWRAP) + +/* + * vecLib is an Apple framework (collection of libraries) containing + * libBLAS and libLAPACK. The fortran stubs in these libraries are + * (mostly, but not completely) in the F2C calling convention. + * We access the libraries via the vecLib framework to make sure we + * get the Apple versions, rather than some other blas/lapack with the + * same name. + */ +#if ! defined (VECLIB_FILE) +# define VECLIB_FILE "/System/Library/Frameworks/vecLib.framework/Versions/A/vecLib" +#endif + +/* + * Since this is a wrapper for fortran functions, + * we do not have prototypes for them. + */ +#pragma GCC diagnostic ignored "-Wmissing-prototypes" + +#include +#include + +/* + * Apple LAPACK follows F2C calling convention, + * Convert to normal gfortran calling convention + */ + +static void (*f2c_blas_func[]) (void); /* forward declaration for wrapper */ +static void (*f2c_lapack_func[]) (void); /* forward declaration for wrapper */ + +/* + * LAPACK Wrappers, only need to convert the return value from double to float + */ + +typedef double (*F2C_CALL_0) (void); +typedef double (*F2C_CALL_1) (void *a1); +typedef double (*F2C_CALL_2) (void *a1, void *a2); +typedef double (*F2C_CALL_3) (void *a1, void *a2, void *a3); +typedef double (*F2C_CALL_4) (void *a1, void *a2, void *a3, void *a4); +typedef double (*F2C_CALL_5) (void *a1, void *a2, void *a3, void *a4, void *a5); +typedef double (*F2C_CALL_6) (void *a1, void *a2, void *a3, void *a4, void *a5, + void *a6); +typedef double (*F2C_CALL_7) (void *a1, void *a2, void *a3, void *a4, void *a5, + void *a6, void *a7); +typedef double (*F2C_CALL_8) (void *a1, void *a2, void *a3, void *a4, void *a5, + void *a6, void *a7, void *a8); + +#define F2C_LAPACK_CALL_8(name) \ + float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6, void *a7, void *a8) \ + { \ + return ((F2C_CALL_8)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6, a7, a8); \ + } + +#define F2C_LAPACK_CALL_7(name) \ + float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6, void *a7) \ + { \ + return ((F2C_CALL_7)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6, a7); \ + } + +#define F2C_LAPACK_CALL_6(name) \ + float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6) \ + { \ + return ((F2C_CALL_6)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6); \ + } + +#define F2C_LAPACK_CALL_5(name) \ + float name (void *a1, void *a2, void *a3, void *a4, void *a5) \ + { \ + return ((F2C_CALL_5)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5); \ + } + +#define F2C_LAPACK_CALL_4(name) \ + float name (void *a1, void *a2, void *a3, void *a4) \ + { \ + return ((F2C_CALL_4)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4); \ + } + +#define F2C_LAPACK_CALL_3(name) \ + float name (void *a1, void *a2, void *a3) \ + { \ + return ((F2C_CALL_3)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3); \ + } + +#define F2C_LAPACK_CALL_2(name) \ + float name (void *a1, void *a2) \ + { \ + return ((F2C_CALL_2)f2c_lapack_func[f2c_ ## name]) (a1, a2); \ + } + +#define F2C_LAPACK_CALL_1(name) \ + float name (void *a1) \ + { \ + return ((F2C_CALL_1)f2c_lapack_func[f2c_ ## name]) (a1); \ + } + +#define F2C_LAPACK_CALL_0(name) \ + float name (void) \ + { \ + return ((F2C_CALL_0)f2c_lapack_func[f2c_ ## name]) (); \ + } + +#define F2C_LAPACK_CALL_NONE(name) + +#define F2C_LAPACK_CALL(name, args) F2C_LAPACK_CALL_ ## args (name) + +#define ENUM_ITEM(name, args) \ + f2c_ ## name, + +#define NAME_TO_STRING_CASE(name, args) \ + case f2c_ ## name: return #name; + +#define DEFINE_LAPACK_ENUM(name, list) \ + typedef enum { \ + list(ENUM_ITEM) \ + } name; \ + static const char* \ + f2c_ ## name ## _name (name n) { \ + switch (n) { \ + list(NAME_TO_STRING_CASE) \ + default: return ""; \ + } \ + } \ + list(F2C_LAPACK_CALL) + +#define DEFINE_BLAS_ENUM(name, list) \ + typedef enum { \ + list(ENUM_ITEM) \ + } name; \ + static const char* \ + f2c_ ## name ## _name(name n) { \ + switch (n) { \ + list(NAME_TO_STRING_CASE) \ + default: return ""; \ + } \ + } + +/* + * Lapack functions (with argument count) that need the return value + * converted from double to float + */ +#define LAPACK_LIST(_) \ + _(clangb_,7) \ + _(clange_,6) \ + _(clangt_,5) \ + _(clanhb_,7) \ + _(clanhe_,6) \ + _(clanhp_,5) \ + _(clanhs_,5) \ + _(clanht_,4) \ + _(clansb_,7) \ + _(clansp_,5) \ + _(clansy_,6) \ + _(clantb_,8) \ + _(clantp_,6) \ + _(clantr_,8) \ + _(scsum1_,3) \ + _(second_,0) \ + _(slamc3_,2) \ + _(slamch_,1) \ + _(slangb_,7) \ + _(slange_,6) \ + _(slangt_,5) \ + _(slanhs_,5) \ + _(slansb_,7) \ + _(slansp_,5) \ + _(slanst_,4) \ + _(slansy_,6) \ + _(slantb_,8) \ + _(slantp_,6) \ + _(slantr_,8) \ + _(slapy2_,2) \ + _(slapy3_,3) \ + _(LAPACK_COUNT,NONE) + +/* + * These need a bit more complex wrappers + */ +#define BLAS_LIST(_) \ + _(cdotu_,6) \ + _(zdotu_,6) \ + _(cdotc_,6) \ + _(zdotc_,6) \ + _(BLAS_COUNT,NONE) + +DEFINE_BLAS_ENUM(blas, BLAS_LIST) + +DEFINE_LAPACK_ENUM(lapack, LAPACK_LIST) + +/* + * BLAS wrappers, F2C convention passes retuned complex as an extra first + * argument + */ +typedef struct { float r, i; } complex; +typedef struct { double r, i; } doublecomplex; + +typedef void (*F2C_BLAS_CALL_6) (void *c, void *a1, void *a2, void *a3, + void *a4, void *a5); + +#define F2C_BLAS_CALL(type, name) \ +type name (void *a1, void *a2, void *a3, void *a4, void *a5) \ +{ \ + type cplx; \ + ((F2C_BLAS_CALL_6)f2c_blas_func[f2c_ ## name]) (&cplx, a1, a2, a3, a4, a5); \ + return cplx; \ +} + +F2C_BLAS_CALL(complex, cdotu_) +F2C_BLAS_CALL(doublecomplex, zdotu_) +F2C_BLAS_CALL(complex, cdotc_) +F2C_BLAS_CALL(doublecomplex, zdotc_) + +/* + * Function pointer arrays, indexed by the enums + */ +static void (*f2c_blas_func[f2c_BLAS_COUNT]) (void) = { 0 }; +static void (*f2c_lapack_func[f2c_LAPACK_COUNT]) (void) = { 0 }; + +/* + * Initialization: This is called before main (). + * Get the function pointers to the wrapped functions in Apple vecLib + */ + +static void * apple_vecLib = 0; + +__attribute__((constructor)) +static void initVecLibWrappers (void) +{ + apple_vecLib = dlopen (VECLIB_FILE, RTLD_LOCAL | RTLD_NOLOAD | RTLD_FIRST); + if (0 == apple_vecLib) + abort (); + + int i; + for (i = 0; i < f2c_LAPACK_COUNT; i++) + if (0 == (f2c_lapack_func[i] = dlsym (apple_vecLib, f2c_lapack_name(i)))) + abort (); + for (i = 0; i < f2c_BLAS_COUNT; i++) + if (0 == (f2c_blas_func[i] = dlsym (apple_vecLib, f2c_blas_name(i)))) + abort (); +} + +__attribute__((destructor)) +static void finiVecLibWrappers (void) +{ + if (apple_vecLib) + dlclose (apple_vecLib); + apple_vecLib = 0; +} + +#endif /* USE_BLASWRAP */ diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/cquit.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/cquit.c Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,66 @@ +/* + +Copyright (C) 2003-2017 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 3 of the License, 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, see +. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +#include +#include + +#include "quit.h" + +octave_jmp_buf current_context; + +void +octave_save_current_context (void *save_buf) +{ + memcpy (save_buf, current_context, sizeof (octave_jmp_buf)); +} + +void +octave_restore_current_context (void *save_buf) +{ + memcpy (current_context, save_buf, sizeof (octave_jmp_buf)); +} + +void +octave_jump_to_enclosing_context (void) +{ +#if defined (OCTAVE_HAVE_SIG_JUMP) + siglongjmp (current_context, 1); +#else + longjmp (current_context, 1); +#endif +} + +sig_atomic_t octave_interrupt_immediately = 0; + +sig_atomic_t octave_interrupt_state = 0; + +sig_atomic_t octave_exception_state = 0; + +sig_atomic_t octave_exit_exception_status = 0; + +sig_atomic_t octave_exit_exception_safe_to_return = 0; + +volatile sig_atomic_t octave_signal_caught = 0; diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/d1mach-tst.for --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/d1mach-tst.for Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,8 @@ + program main + integer i + double precision d1mach + double precision t1, t2 + do 10 i = 1, 5 + print *, d1mach (i) + 10 continue + end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/d1mach.f --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/d1mach.f Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,24 @@ + double precision function d1mach (i) + integer i + logical init + double precision dmach(5) + double precision dlamch + external dlamch + save init, dmach + data init /.false./ + if (.not. init) then + dmach(1) = dlamch ('u') + dmach(2) = dlamch ('o') + dmach(3) = dlamch ('e') + dmach(4) = dlamch ('p') + dmach(5) = log10 (dlamch ('b')) + init = .true. + endif + if (i .lt. 1 .or. i .gt. 5) goto 999 + d1mach = dmach(i) + return + 999 write (*, 1999) i + 1999 format (' d1mach - i out of bounds', i10) + call xstopx (' ') + d1mach = 0 + end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/f77-extern.cc --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/f77-extern.cc Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,35 @@ +// misc-extern.cc -*- C++ -*- +/* + +Copyright (C) 1996-2017 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 3 of the License, 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, see +. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +#include "f77-fcn.h" +#include "lo-error.h" + +// This whole file is a kluge just to avoid unresolved symbol errors +// when creating shared versions of liboctave. + +// So we can check to see if an exception has occurred. +int f77_exception_encountered = 0; diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/f77-fcn.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/f77-fcn.c Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,70 @@ +/* + +Copyright (C) 1996-2017 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 3 of the License, 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, see +. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +#include +#include + +#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. + + Note that the order of arguments for the Visual Fortran function + signature is the same as for gfortran and f2c only becuase there is + a single assumed size character string argument. Visual Fortran + inserts the length after each character string argument, f2c appends + all length arguments at the end of the parameter list, and gfortran + appends length arguments for assumed size character strings to the + end of the list (ignoring others). */ + +F77_RET_T +#if defined (F77_USES_CRAY_CALLING_CONVENTION) +F77_FUNC (xstopx, XSTOPX) (octave_cray_ftn_ch_dsc desc) +#else +F77_FUNC (xstopx, XSTOPX) (const char *s, F77_CHAR_ARG_LEN_TYPE 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_NORETURN (0) +} diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/f77-fcn.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/f77-fcn.h Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,393 @@ +/* + +Copyright (C) 1996-2017 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 3 of the License, 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, see +. + +*/ + +#if ! defined (octave_f77_fcn_h) +#define octave_f77_fcn_h 1 + +#include "octave-config.h" + +#include "lo-error.h" +#include "quit.h" + +#if defined (__cplusplus) +# include +#endif + +#if defined (__cplusplus) +extern "C" { +#endif + +/* Hack to stringize macro results. */ +#define xSTRINGIZE(x) #x +#define STRINGIZE(x) xSTRINGIZE(x) + +/* How to print an error for the F77_XFCN macro. */ + +#define F77_XFCN_ERROR(f, F) \ + (*current_liboctave_error_handler) \ + ("exception encountered in Fortran subroutine %s", \ + STRINGIZE (F77_FUNC (f, F))) + +/* This can be used to call a Fortran subroutine that might call + XSTOPX. XSTOPX will call lonjmp with current_context. Once back + here, we'll restore the previous context and return. We may also + end up here if an interrupt is processed when the Fortran + subroutine is called. In that case, we resotre the context and go + to the top level. */ + +#define F77_XFCN(f, F, args) \ + do \ + { \ + octave_jmp_buf saved_context; \ + sig_atomic_t saved_octave_interrupt_immediately = octave_interrupt_immediately; \ + f77_exception_encountered = 0; \ + octave_save_current_context (saved_context); \ + if (octave_set_current_context) \ + { \ + octave_interrupt_immediately = saved_octave_interrupt_immediately; \ + octave_restore_current_context (saved_context); \ + if (f77_exception_encountered) \ + F77_XFCN_ERROR (f, F); \ + else \ + octave_rethrow_exception (); \ + } \ + else \ + { \ + octave_interrupt_immediately++; \ + F77_FUNC (f, F) args; \ + octave_interrupt_immediately--; \ + octave_restore_current_context (saved_context); \ + } \ + } \ + while (0) + +/* So we can check to see if an exception has occurred. */ +OCTAVE_API extern int f77_exception_encountered; + +#if ! defined (F77_FCN) +#define F77_FCN(f, F) F77_FUNC (f, F) +#endif + +/* + +The following macros are used for handling Fortran <-> C calling +conventions. They are defined below for three different types of +systems, Cray (possibly now obsolete), Visual Fortran, and gfortran. +Note that we don't attempt to handle Fortran functions, we always use +subroutine wrappers for them and pass the return value as an extra +argument. + +Use these macros to pass character strings from C to Fortran: + + F77_CHAR_ARG(x) + F77_CONST_CHAR_ARG(x) + F77_CXX_STRING_ARG(x) + F77_CHAR_ARG_LEN(l) + F77_CHAR_ARG_DECL + F77_CONST_CHAR_ARG_DECL + F77_CHAR_ARG_LEN_DECL + +Use these macros to write C-language functions that accept +Fortran-style character strings: + + F77_CHAR_ARG_DEF(s, len) + F77_CONST_CHAR_ARG_DEF(s, len) + F77_CHAR_ARG_LEN_DEF(len) + F77_CHAR_ARG_USE(s) + F77_CHAR_ARG_LEN_USE(s, len) + +Use these macros for C++ code + + F77_INT Equivalent to Fortran INTEGER type + F77_INT4 Equivalent to Fortran INTEGER*4 type + F77_DBLE Equivalent to Fortran DOUBLE PRECISION type + F77_REAL Equivalent to Fortran REAL type + F77_CMPLX Equivalent to Fortran COMPLEX type + F77_DBLE_CMPLX Equivalent to Fortran DOUBLE COMPLEX type + F77_LOGICAL Equivalent to Fortran LOGICAL type + F77_RET_T Return type of a C++ function that acts like a + Fortran subroutine. + +Use these macros to return from C-language functions that are supposed +to act like Fortran subroutines. F77_NORETURN is intended to be used +as the last statement of such a function that has been tagged with a +"noreturn" attribute. If the compiler supports the "noreturn" +attribute or if F77_RET_T is void, then it should expand to nothing so +that we avoid warnings about functions tagged as "noreturn" +containing a return statement. Otherwise, it should expand to a +statement that returns the given value so that we avoid warnings about +not returning a value from a function declared to return something. + + F77_RETURN(retval) + F77_NORETURN(retval) + +*/ + +#if defined (F77_USES_CRAY_CALLING_CONVENTION) + +#include + +/* Use these macros to pass character strings from C to Fortran. Cray + Fortran uses a descriptor structure to pass a pointer to the string + and the length in a single argument. */ + +#define F77_CHAR_ARG(x) octave_make_cray_ftn_ch_dsc (x, strlen (x)) +#define F77_CONST_CHAR_ARG(x) \ + octave_make_cray_const_ftn_ch_dsc (x, strlen (x)) +#define F77_CHAR_ARG2(x, l) octave_make_cray_ftn_ch_dsc (x, l) +#define F77_CONST_CHAR_ARG2(x, l) octave_make_cray_const_ftn_ch_dsc (x, l) +#define F77_CXX_STRING_ARG(x) \ + octave_make_cray_const_ftn_ch_dsc (x.c_str (), x.length ()) +#define F77_CHAR_ARG_LEN(l) +#define F77_CHAR_ARG_LEN_TYPE +#define F77_CHAR_ARG_LEN_DECL +#define F77_CHAR_ARG_DECL octave_cray_ftn_ch_dsc +#define F77_CONST_CHAR_ARG_DECL octave_cray_ftn_ch_dsc + +/* Use these macros to write C-language functions that accept + Fortran-style character strings. */ +#define F77_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s +#define F77_CONST_CHAR_ARG_DEF(s, len) octave_cray_ftn_ch_dsc s +#define F77_CHAR_ARG_LEN_DEF(len) +#define F77_CHAR_ARG_USE(s) s.ptr +#define F77_CHAR_ARG_LEN_USE(s, len) (s.mask.len >> 3) + +#define F77_RET_T int + +/* Use these macros to return from C-language functions that are + supposed to act like Fortran subroutines. F77_NORETURN is intended + to be used as the last statement of such a function that has been + tagged with a "noreturn" attribute. */ + +#define F77_RETURN(retval) return retval; +#if defined (HAVE_OCTAVE_NORETURN_ATTR) +# define F77_NORETURN(retval) +#else +# define F77_NORETURN(retval) return retval; +#endif + +/* FIXME: These should work for SV1 or Y-MP systems but will + need to be changed for others. */ + +typedef union +{ + const char *const_ptr; + char *ptr; + struct + { + unsigned off : 6; + unsigned len : 26; + unsigned add : 32; + } mask; +} octave_cray_descriptor; + +typedef void *octave_cray_ftn_ch_dsc; + + #if defined (__cplusplus) +# define OCTAVE_F77_FCN_INLINE inline +#else +# define OCTAVE_F77_FCN_INLINE +#endif + +static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc +octave_make_cray_ftn_ch_dsc (char *ptr_arg, unsigned long len_arg) +{ + octave_cray_descriptor desc; + desc.ptr = ptr_arg; + desc.mask.len = len_arg << 3; + return *((octave_cray_ftn_ch_dsc *) &desc); +} + +static OCTAVE_F77_FCN_INLINE octave_cray_ftn_ch_dsc +octave_make_cray_const_ftn_ch_dsc (const char *ptr_arg, unsigned long len_arg) +{ + octave_cray_descriptor desc; + desc.const_ptr = ptr_arg; + desc.mask.len = len_arg << 3; + return *((octave_cray_ftn_ch_dsc *) &desc); +} + +#undef OCTAVE_F77_FCN_INLINE + +#elif defined (F77_USES_VISUAL_FORTRAN_CALLING_CONVENTION) + +/* Use these macros to pass character strings from C to Fortran. + Visual Fortran inserts the length after each character string + argument. */ + +#define F77_CHAR_ARG(x) x, strlen (x) +#define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) +#define F77_CHAR_ARG2(x, l) x, l +#define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) +#define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) +#define F77_CHAR_ARG_LEN(l) +#define F77_CHAR_ARG_LEN_TYPE int +#define F77_CHAR_ARG_LEN_DECL +#define F77_CHAR_ARG_DECL char *, F77_CHAR_ARG_LEN_TYPE +#define F77_CONST_CHAR_ARG_DECL const char *, F77_CHAR_ARG_LEN_TYPE + +#define F77_CHAR_ARG_DEF(s, len) char *s, F77_CHAR_ARG_LEN_TYPE len +#define F77_CONST_CHAR_ARG_DEF(s, len) const char *s, F77_CHAR_ARG_LEN_TYPE len +#define F77_CHAR_ARG_LEN_DEF(len) +#define F77_CHAR_ARG_USE(s) s +#define F77_CHAR_ARG_LEN_USE(s, len) len + +#define F77_RET_T void + +#define F77_RETURN(retval) return; +#define F77_NORETURN(retval) + +#elif defined (F77_USES_GFORTRAN_CALLING_CONVENTION) + +/* Use these macros to pass character strings from C to Fortran. + gfortran appends length arguments for assumed size character + strings to the and ignores others. + + FIXME: I don't think we correctly handle the case of mixing some + fixed-length and some assumed-length character string arguments as + we don't handle each case separately, so it seems there could be + mismatch? However, I don't think we currently have to handle this + case in Octave. */ + +#define F77_CHAR_ARG(x) x +#define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) +#define F77_CHAR_ARG2(x, l) x +#define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) +#define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) +#define F77_CHAR_ARG_LEN(l) , l +#define F77_CHAR_ARG_LEN_TYPE int +#define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE +#define F77_CHAR_ARG_DECL char * +#define F77_CONST_CHAR_ARG_DECL const char * + +#define F77_CHAR_ARG_DEF(s, len) char *s +#define F77_CONST_CHAR_ARG_DEF(s, len) const char *s +#define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len +#define F77_CHAR_ARG_USE(s) s +#define F77_CHAR_ARG_LEN_USE(s, len) len + +#define F77_RET_T void + +#define F77_RETURN(retval) return; +#if defined (HAVE_OCTAVE_NORETURN_ATTR) +# define F77_NORETURN(retval) +#else +# define F77_NORETURN(retval) return retval; +#endif + +#elif defined (F77_USES_F2C_CALLING_CONVENTION) + +/* Assume f2c-compatible calling convention. */ + +/* Use these macros to pass character strings from C to Fortran. f2c + appends all length arguments at the end of the parameter list. */ + +#define F77_CHAR_ARG(x) x +#define F77_CONST_CHAR_ARG(x) F77_CHAR_ARG (x) +#define F77_CHAR_ARG2(x, l) x +#define F77_CONST_CHAR_ARG2(x, l) F77_CHAR_ARG2 (x, l) +#define F77_CXX_STRING_ARG(x) F77_CONST_CHAR_ARG2 (x.c_str (), x.length ()) +#define F77_CHAR_ARG_LEN(l) , l +#define F77_CHAR_ARG_LEN_TYPE long +#define F77_CHAR_ARG_LEN_DECL , F77_CHAR_ARG_LEN_TYPE +#define F77_CHAR_ARG_DECL char * +#define F77_CONST_CHAR_ARG_DECL const char * + +#define F77_CHAR_ARG_DEF(s, len) char *s +#define F77_CONST_CHAR_ARG_DEF(s, len) const char *s +#define F77_CHAR_ARG_LEN_DEF(len) , F77_CHAR_ARG_LEN_TYPE len +#define F77_CHAR_ARG_USE(s) s +#define F77_CHAR_ARG_LEN_USE(s, len) len + +#define F77_RET_T int + +#define F77_RETURN(retval) return retval; +#if defined (HAVE_OCTAVE_NORETURN_ATTR) +# define F77_NORETURN(retval) +#else +# define F77_NORETURN(retval) return retval; +#endif + +#else + +#error "unknown C++ to Fortran calling convention" + +#endif + +typedef double F77_DBLE; +typedef float F77_REAL; +typedef double _Complex F77_DBLE_CMPLX; +typedef float _Complex F77_CMPLX; +typedef octave_f77_int_type F77_INT; +typedef int32_t F77_INT4; +typedef octave_f77_int_type F77_LOGICAL; + +#define F77_CMPLX_ARG(x) \ + reinterpret_cast (x) + +#define F77_CONST_CMPLX_ARG(x) \ + reinterpret_cast (x) + +#define F77_DBLE_CMPLX_ARG(x) \ + reinterpret_cast (x) + +#define F77_CONST_DBLE_CMPLX_ARG(x) \ + reinterpret_cast (x) + +/* Build a C string local variable CS from the Fortran string parameter S + declared as F77_CHAR_ARG_DEF(s, len) or F77_CONST_CHAR_ARG_DEF(s, len). + The string will be cleaned up at the end of the current block. + Needs to include and . */ + +#define F77_CSTRING(s, len, cs) \ + OCTAVE_LOCAL_BUFFER (char, cs, F77_CHAR_ARG_LEN_USE (s, len) + 1); \ + memcpy (cs, F77_CHAR_ARG_USE (s), F77_CHAR_ARG_LEN_USE (s, len)); \ + cs[F77_CHAR_ARG_LEN_USE(s, len)] = '\0' + +OCTAVE_NORETURN OCTAVE_API extern +F77_RET_T +F77_FUNC (xstopx, XSTOPX) (F77_CONST_CHAR_ARG_DECL + F77_CHAR_ARG_LEN_DECL); + +#if defined (__cplusplus) + +namespace octave +{ + inline F77_INT + to_f77_int (octave_idx_type x) + { + if (x < std::numeric_limits::min () + || x > std::numeric_limits::max ()) + (*current_liboctave_error_handler) + ("integer dimension or index out of range for Fortran INTEGER type"); + + return static_cast (x); + } +} + +#endif + +#if defined (__cplusplus) +} +#endif + +#endif diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/i1mach.f --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/i1mach.f Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,27 @@ + integer function i1mach (i) + integer i, imach(16) + logical init + double precision dlamch + real slamch + external dlamch, slamch + save imach, init + data imach / 5, 6, 0, 6, 32, 4, 2, 31, 2147483647, + $ 2, 0, 0, 0, 0, 0, 0 / + data init /.false./ + if (.not. init) then + imach(11) = slamch ('n') + imach(12) = slamch ('m') + imach(13) = slamch ('l') + imach(14) = dlamch ('n') + imach(15) = dlamch ('m') + imach(16) = dlamch ('l') + init = .true. + endif + if (i .lt. 1 .or. i .gt. 16) goto 999 + i1mach = imach(i) + return + 999 write (*, 1999) i + 1999 format (' i1mach - i out of bounds', i10) + call xstopx (' ') + i1mach = 0 + end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/lo-error.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/lo-error.c Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,142 @@ +/* + +Copyright (C) 1996-2017 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 3 of the License, 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, see +. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +#include +#include +#include + +#include "lo-error.h" + +/* Having this file in this directory is a kluge to avoid unresolved + symbol errors when creating shared versions of liboctave. */ + +/* Pointer to the current error handling function. */ +OCTAVE_NORETURN liboctave_error_handler + current_liboctave_error_handler = liboctave_fatal; + +/* Pointer to the current error_with_id handling function. */ +OCTAVE_NORETURN liboctave_error_with_id_handler + current_liboctave_error_with_id_handler = liboctave_fatal_with_id; + +/* Pointer to the current warning handler. */ +liboctave_warning_handler + current_liboctave_warning_handler = liboctave_warning; + +/* Pointer to the current warning_with_id handler. */ +liboctave_warning_with_id_handler + current_liboctave_warning_with_id_handler = liboctave_warning_with_id; + +static void +verror (const char *name, const char *fmt, va_list args) +{ + if (name) + fprintf (stderr, "%s: ", name); + + vfprintf (stderr, fmt, args); + fprintf (stderr, "\n"); + fflush (stderr); +} + +void +set_liboctave_error_handler (OCTAVE_NORETURN liboctave_error_handler f) +{ + if (f) + current_liboctave_error_handler = f; + else + current_liboctave_error_handler = liboctave_fatal; +} + +void +set_liboctave_error_with_id_handler (OCTAVE_NORETURN + liboctave_error_with_id_handler f) +{ + if (f) + current_liboctave_error_with_id_handler = f; + else + current_liboctave_error_with_id_handler = liboctave_fatal_with_id; +} + +void +set_liboctave_warning_handler (liboctave_warning_handler f) +{ + if (f) + current_liboctave_warning_handler = f; + else + current_liboctave_warning_handler = liboctave_warning; +} + +void +set_liboctave_warning_with_id_handler (liboctave_warning_with_id_handler f) +{ + if (f) + current_liboctave_warning_with_id_handler = f; + else + current_liboctave_warning_with_id_handler = liboctave_warning_with_id; +} + +void +liboctave_fatal (const char *fmt, ...) +{ + va_list args; + va_start (args, fmt); + verror ("fatal", fmt, args); + va_end (args); + + exit (1); +} + +void +liboctave_fatal_with_id (const char *id, const char *fmt, ...) +{ + octave_unused_parameter (id); + + va_list args; + va_start (args, fmt); + verror ("fatal", fmt, args); + va_end (args); + + exit (1); +} + +void +liboctave_warning (const char *fmt, ...) +{ + va_list args; + va_start (args, fmt); + verror ("warning", fmt, args); + va_end (args); +} + +void +liboctave_warning_with_id (const char *id, const char *fmt, ...) +{ + octave_unused_parameter (id); + + va_list args; + va_start (args, fmt); + verror ("warning", fmt, args); + va_end (args); +} diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/lo-error.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/lo-error.h Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,83 @@ +/* + +Copyright (C) 1996-2017 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 3 of the License, 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, see +. + +*/ + +#if ! defined (octave_lo_error_h) +#define octave_lo_error_h 1 + +#include "octave-config.h" + +#if defined (__cplusplus) +extern "C" { +#endif + +OCTAVE_NORETURN extern void +liboctave_fatal (const char *fmt, ...); + +OCTAVE_NORETURN extern +void liboctave_fatal_with_id (const char *id, const char *fmt, ...); + +extern void +liboctave_warning (const char *fmt, ...); + +extern void +liboctave_warning_with_id (const char *id, const char *fmt, ...); + +typedef void (*liboctave_error_handler) (const char *, ...); + +typedef void (*liboctave_error_with_id_handler) (const char *, const char *, + ...); + +typedef void (*liboctave_warning_handler) (const char *, ...); + +typedef void (*liboctave_warning_with_id_handler) (const char *, const char *, + ...); + +/* Would be nice to make these pointers private, but we want to share + them among all the liboctave classes. */ +OCTAVE_NORETURN OCTAVE_API extern liboctave_error_handler + current_liboctave_error_handler; + +OCTAVE_NORETURN OCTAVE_API extern liboctave_error_with_id_handler + current_liboctave_error_with_id_handler; + +OCTAVE_API extern liboctave_warning_handler current_liboctave_warning_handler; + +OCTAVE_API extern liboctave_warning_with_id_handler + current_liboctave_warning_with_id_handler; + +OCTAVE_API extern void +set_liboctave_error_handler (OCTAVE_NORETURN liboctave_error_handler f); + +OCTAVE_API extern void +set_liboctave_error_with_id_handler (OCTAVE_NORETURN liboctave_error_with_id_handler f); + +OCTAVE_API extern void +set_liboctave_warning_handler (liboctave_warning_handler f); + +OCTAVE_API extern void +set_liboctave_warning_with_id_handler (liboctave_warning_with_id_handler f); + +#if defined (__cplusplus) +} +#endif + +#endif diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/module.mk --- a/liboctave/util/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ b/liboctave/util/module.mk Sat Apr 22 08:12:54 2017 -0400 @@ -14,24 +14,27 @@ liboctave/util/lo-hash.h \ liboctave/util/lo-ieee.h \ liboctave/util/lo-math.h \ + liboctave/util/lo-regexp.h \ liboctave/util/lo-traits.h \ liboctave/util/lo-utils.h \ + liboctave/util/f77-fcn.h \ + liboctave/util/lo-error.h \ + liboctave/util/quit.h \ liboctave/util/oct-base64.h \ liboctave/util/oct-binmap.h \ liboctave/util/oct-cmplx.h \ liboctave/util/oct-glob.h \ + liboctave/util/oct-inttypes-fwd.h \ liboctave/util/oct-inttypes.h \ - liboctave/util/oct-inttypes-fwd.h \ liboctave/util/oct-locbuf.h \ liboctave/util/oct-mutex.h \ liboctave/util/oct-refcount.h \ liboctave/util/oct-rl-edit.h \ liboctave/util/oct-rl-hist.h \ - liboctave/util/oct-string.h \ liboctave/util/oct-shlib.h \ liboctave/util/oct-sort.h \ + liboctave/util/oct-string.h \ liboctave/util/pathsearch.h \ - liboctave/util/lo-regexp.h \ liboctave/util/singleton-cleanup.h \ liboctave/util/sparse-sort.h \ liboctave/util/sparse-util.h \ @@ -44,9 +47,18 @@ liboctave/util/kpse.h \ liboctave/util/oct-sparse.h +UTIL_F77_SRC = \ + liboctave/util/d1mach.f \ + liboctave/util/i1mach.f \ + liboctave/util/r1mach.f + UTIL_C_SRC = \ liboctave/util/f2c-main.c \ liboctave/util/lo-cutils.c \ + liboctave/util/blaswrap.c \ + liboctave/util/cquit.c \ + liboctave/util/f77-fcn.c \ + liboctave/util/lo-error.c \ liboctave/util/oct-rl-edit.c \ liboctave/util/oct-rl-hist.c @@ -60,26 +72,32 @@ liboctave/util/lo-array-gripes.cc \ liboctave/util/lo-hash.cc \ liboctave/util/lo-ieee.cc \ + liboctave/util/lo-regexp.cc \ liboctave/util/lo-utils.cc \ + liboctave/util/f77-extern.cc \ + liboctave/util/quit.cc \ liboctave/util/oct-base64.cc \ liboctave/util/oct-glob.cc \ liboctave/util/oct-inttypes.cc \ liboctave/util/oct-locbuf.cc \ liboctave/util/oct-mutex.cc \ - liboctave/util/oct-string.cc \ liboctave/util/oct-shlib.cc \ liboctave/util/oct-sparse.cc \ + liboctave/util/oct-string.cc \ liboctave/util/pathsearch.cc \ - liboctave/util/lo-regexp.cc \ liboctave/util/singleton-cleanup.cc \ liboctave/util/sparse-sort.cc \ liboctave/util/sparse-util.cc \ liboctave/util/str-vec.cc \ liboctave/util/unwind-prot.cc \ liboctave/util/url-transfer.cc \ + $(UTIL_F77_SRC) \ $(UTIL_C_SRC) \ $(NOINSTALL_UTIL_INC) +liboctave_EXTRA_DIST += \ + liboctave/util/d1mach-tst.for + LIBOCTAVE_TEMPLATE_SRC += \ liboctave/util/oct-sort.cc diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/quit.cc --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/quit.cc Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,142 @@ +/* + +Copyright (C) 2002-2017 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 3 of the License, 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, see +. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +#include + +#include +#include + +#include "quit.h" + +void (*octave_signal_hook) (void) = 0; +void (*octave_interrupt_hook) (void) = 0; +void (*octave_bad_alloc_hook) (void) = 0; + +void +octave_handle_signal (void) +{ + if (octave_signal_hook) + octave_signal_hook (); + + if (octave_interrupt_state > 0) + { + octave_interrupt_state = -1; + octave_throw_interrupt_exception (); + } +} + +void +clean_up_and_exit (int exit_status, bool /* safe_to_return */) +{ + exit (exit_status); +} + +void +octave_throw_interrupt_exception (void) +{ + if (octave_interrupt_hook) + octave_interrupt_hook (); + + throw octave::interrupt_exception (); +} + +void +octave_throw_execution_exception (void) +{ + // FIXME: would a hook function be useful here? + + octave_exception_state = octave_exec_exception; + + throw octave::execution_exception (); +} + +void +octave_throw_bad_alloc (void) +{ + if (octave_bad_alloc_hook) + octave_bad_alloc_hook (); + + octave_exception_state = octave_alloc_exception; + + throw std::bad_alloc (); +} + +void +octave_throw_exit_exception (int exit_status, int safe_to_return) +{ + octave_exception_state = octave_quit_exception; + +#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + + throw octave_exit_exception (exit_status, safe_to_return); + +#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) +#pragma GCC diagnostic pop +#endif +} + +void +octave_rethrow_exception (void) +{ + if (octave_interrupt_state) + { + octave_interrupt_state = -1; + octave_throw_interrupt_exception (); + } + else + { + switch (octave_exception_state) + { + case octave_exec_exception: + octave_throw_execution_exception (); + break; + + case octave_alloc_exception: + octave_throw_bad_alloc (); + break; + +#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + + case octave_quit_exception: + octave_throw_exit_exception (octave_exit_exception_status, + octave_exit_exception_safe_to_return); + break; + +#if defined (HAVE_PRAGMA_GCC_DIAGNOSTIC) +#pragma GCC diagnostic pop +#endif + + default: + break; + } + } +} diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/quit.h --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/quit.h Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,327 @@ +/* + +Copyright (C) 2002-2017 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 3 of the License, 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, see +. + +*/ + +#if ! defined (octave_quit_h) +#define octave_quit_h 1 + +#include "octave-config.h" + +#include + +/* The signal header is just needed for the sig_atomic_t type. */ +#if defined (__cplusplus) +# include +# include +extern "C" { +#else +# include +#endif + +#if defined (OCTAVE_HAVE_SIG_JUMP) + +typedef sigjmp_buf octave_jmp_buf; + +#define octave_set_current_context sigsetjmp (current_context, 1) + +#else + +typedef jmp_buf octave_jmp_buf; + +#define octave_set_current_context setjmp (current_context) + +#endif + +OCTAVE_API extern octave_jmp_buf current_context; + +OCTAVE_API extern void octave_save_current_context (void *); + +OCTAVE_API extern void octave_restore_current_context (void *); + +OCTAVE_NORETURN OCTAVE_API extern void octave_jump_to_enclosing_context (void); + +#if defined (__cplusplus) + +namespace octave +{ + class + execution_exception + { + public: + + execution_exception (void) : m_stack_trace () { } + + execution_exception (const execution_exception& x) + : m_stack_trace (x.m_stack_trace) { } + + execution_exception& operator = (const execution_exception& x) + { + if (&x != this) + m_stack_trace = x.m_stack_trace; + + return *this; + } + + ~execution_exception (void) = default; + + virtual void set_stack_trace (const std::string& st) + { + m_stack_trace = st; + } + + virtual void set_stack_trace (void) + { + m_stack_trace = ""; + } + + virtual std::string info (void) const + { + return m_stack_trace; + } + + private: + + std::string m_stack_trace; + }; + + class + exit_exception + { + public: + + exit_exception (int exit_status = 0, bool safe_to_return = false) + : m_exit_status (exit_status), m_safe_to_return (safe_to_return) + { } + + exit_exception (const exit_exception& ex) + : m_exit_status (ex.m_exit_status), m_safe_to_return (ex.m_safe_to_return) + { } + + exit_exception& operator = (exit_exception& ex) + { + if (this != &ex) + { + m_exit_status = ex.m_exit_status; + m_safe_to_return = ex.m_safe_to_return; + } + + return *this; + } + + ~exit_exception (void) = default; + + int exit_status (void) const { return m_exit_status; } + + bool safe_to_return (void) const { return m_safe_to_return; } + + private: + + int m_exit_status; + + bool m_safe_to_return; + }; + + class + interrupt_exception + { + }; +} + +OCTAVE_DEPRECATED ("use 'octave::execution_exception' instead") +typedef octave::execution_exception octave_execution_exception; + +OCTAVE_DEPRECATED ("use 'octave::exit_exception' instead") +typedef octave::exit_exception octave_exit_exception; + +OCTAVE_DEPRECATED ("use 'octave::interrupt_exception' instead") +typedef octave::interrupt_exception octave_interrupt_exception; + +#endif + +enum octave_exception +{ + octave_no_exception = 0, + octave_exec_exception = 1, + octave_alloc_exception = 3, + octave_quit_exception = 4 +}; + +OCTAVE_API extern sig_atomic_t octave_interrupt_immediately; + +/* + > 0: interrupt pending + 0: no interrupt pending + < 0: handling interrupt +*/ +OCTAVE_API extern sig_atomic_t octave_interrupt_state; + +OCTAVE_API extern sig_atomic_t octave_exception_state; + +OCTAVE_API extern sig_atomic_t octave_exit_exception_status; + +OCTAVE_API extern sig_atomic_t octave_exit_exception_safe_to_return; + +OCTAVE_API extern volatile sig_atomic_t octave_signal_caught; + +OCTAVE_API extern void octave_handle_signal (void); + +OCTAVE_NORETURN OCTAVE_API extern void octave_throw_interrupt_exception (void); + +OCTAVE_NORETURN OCTAVE_API extern void octave_throw_execution_exception (void); + +OCTAVE_NORETURN OCTAVE_API extern void octave_throw_bad_alloc (void); + +OCTAVE_DEPRECATED ("see the Octave documentation for other options") +OCTAVE_NORETURN OCTAVE_API extern void +octave_throw_exit_exception (int exit_status, int safe_to_return); + +OCTAVE_API extern void octave_rethrow_exception (void); + +#if defined (__cplusplus) + +OCTAVE_DEPRECATED ("see the Octave documentation for other options") +extern OCTAVE_API void +clean_up_and_exit (int exit_status, bool safe_to_return = false); + +inline void octave_quit (void) +{ + if (octave_signal_caught) + { + octave_signal_caught = 0; + octave_handle_signal (); + } +}; + +#define OCTAVE_QUIT octave_quit () + +#else + +#define OCTAVE_QUIT \ + do \ + { \ + if (octave_signal_caught) \ + { \ + octave_signal_caught = 0; \ + octave_handle_signal (); \ + } \ + } \ + while (0) +#endif + +/* Normally, you just want to use + + BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; + ... some code that calls a "foreign" function ... + END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE; + + but sometimes it is useful to do something like + + BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_1; + ... custom code here, normally ending in a call to + octave_rethrow_exception ... + BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_2; + + so that you can perform extra clean up operations before throwing + the interrupt exception. */ + +#define BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE \ + BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_1; \ + octave_rethrow_exception (); \ + BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_2 + +#define BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_1 \ + do \ + { \ + octave_jmp_buf saved_context; \ + \ + octave_save_current_context (saved_context); \ + \ + if (octave_set_current_context) \ + { \ + octave_restore_current_context (saved_context) + +#define BEGIN_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE_2 \ + } \ + else \ + { \ + octave_interrupt_immediately++ + +#define END_INTERRUPT_IMMEDIATELY_IN_FOREIGN_CODE \ + octave_interrupt_immediately--; \ + octave_restore_current_context (saved_context); \ + octave_quit (); \ + } \ + } \ + while (0) + +#if defined (__cplusplus) + +#define BEGIN_INTERRUPT_WITH_EXCEPTIONS \ + sig_atomic_t saved_octave_interrupt_immediately = octave_interrupt_immediately; \ + \ + try \ + { \ + octave_interrupt_immediately = 0; + +#define END_INTERRUPT_WITH_EXCEPTIONS \ + } \ + catch (const octave::interrupt_exception&) \ + { \ + octave_interrupt_immediately = saved_octave_interrupt_immediately; \ + octave_jump_to_enclosing_context (); \ + } \ + catch (const octave::execution_exception&) \ + { \ + octave_interrupt_immediately = saved_octave_interrupt_immediately; \ + octave_exception_state = octave_exec_exception; \ + octave_jump_to_enclosing_context (); \ + } \ + catch (const std::bad_alloc&) \ + { \ + octave_interrupt_immediately = saved_octave_interrupt_immediately; \ + octave_exception_state = octave_alloc_exception; \ + octave_jump_to_enclosing_context (); \ + } \ + catch (const octave::exit_exception& ex) \ + { \ + octave_interrupt_immediately = saved_octave_interrupt_immediately; \ + octave_exception_state = octave_quit_exception; \ + octave_exit_exception_status = ex.exit_status (); \ + octave_exit_exception_safe_to_return = ex.safe_to_return (); \ + octave_jump_to_enclosing_context (); \ + } \ + \ + octave_interrupt_immediately = saved_octave_interrupt_immediately +#endif + +#if defined (__cplusplus) +} + +/* These should only be declared for C++ code, and should also be + outside of any extern "C" block. */ + +extern OCTAVE_API void (*octave_signal_hook) (void); +extern OCTAVE_API void (*octave_interrupt_hook) (void); +extern OCTAVE_API void (*octave_bad_alloc_hook) (void); + +#endif + +#endif diff -r 7dfa3bc8e3d5 -r 58d56f52d50a liboctave/util/r1mach.f --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/util/r1mach.f Sat Apr 22 08:12:54 2017 -0400 @@ -0,0 +1,24 @@ + real function r1mach (i) + integer i + logical init + real rmach(5) + real slamch + external slamch + save init, rmach + data init /.false./ + if (.not. init) then + rmach(1) = slamch ('u') + rmach(2) = slamch ('o') + rmach(3) = slamch ('e') + rmach(4) = slamch ('p') + rmach(5) = log10 (slamch ('b')) + init = .true. + endif + if (i .lt. 1 .or. i .gt. 5) goto 999 + r1mach = rmach(i) + return + 999 write (*, 1999) i + 1999 format (' r1mach - i out of bounds', i10) + call xstopx (' ') + r1mach = 0 + end diff -r 7dfa3bc8e3d5 -r 58d56f52d50a src/module.mk --- a/src/module.mk Thu Apr 20 12:34:40 2017 -0400 +++ b/src/module.mk Sat Apr 22 08:12:54 2017 -0400 @@ -9,7 +9,6 @@ SRC_DIR_CPPFLAGS = \ -Iliboctave -I$(srcdir)/liboctave \ -I$(srcdir)/liboctave/array \ - -I$(srcdir)/liboctave/cruft/misc \ -I$(srcdir)/liboctave/numeric \ -I$(srcdir)/liboctave/system \ -I$(srcdir)/liboctave/util \