Mercurial > octave
changeset 25487:fbc270aeb55d stable
* interpreter.cc (intialize_xerbla_error_handler, xerbla_abort): New functions.
(interpreter::interpreter): Call intialize_xerbla_error_handler.
* configure.ac (AMCOND_BUILD_EXTERNAL_LIBXERBLA): New conditional.
* libinterp/module.mk (%canon_reldir%_liboctinterp_la_LIBADD):
Add libxerbla.la as an additional dependency if building libxerbla as
an external library.
* liboctave/external/blas-xtra/module.mk: Update. Allow building a
separate library for xerbla.
* xerbla.c: Rename from xerbla.f and implement in C. Allow programs
to define a handler function to call.
* f77-fcn.c (xstopx): Modernize.
| author | John W. Eaton <jwe@octave.org> |
|---|---|
| date | Wed, 20 Jun 2018 15:16:05 -0400 |
| parents | 0d7a89bec20e |
| children | 3b211e9ceab1 0dc3da84ffa3 |
| files | configure.ac libinterp/corefcn/interpreter.cc libinterp/module.mk liboctave/external/blas-xtra/module.mk liboctave/external/blas-xtra/xerbla.c liboctave/external/blas-xtra/xerbla.f liboctave/util/f77-fcn.c |
| diffstat | 7 files changed, 249 insertions(+), 174 deletions(-) [+] |
line wrap: on
line diff
--- a/configure.ac Tue Jun 19 09:05:48 2018 -0400 +++ b/configure.ac Wed Jun 20 15:16:05 2018 -0400 @@ -1110,6 +1110,16 @@ AC_SUBST(F77_FLOAT_STORE_FLAG) ]) +BUILD_EXTERNAL_LIBXERBLA= +case $host_os in + msdosmsvc | mingw*) + BUILD_EXTERNAL_LIBXERBLA=ues + ;; +esac + +AM_CONDITIONAL([AMCOND_BUILD_EXTERNAL_LIBXERBLA], + [test -n "$BUILD_EXTERNAL_LIBXERBLA"]) + ### Dynamic linking is now enabled only if we are building shared ### libs and some API for dynamic linking has been detected.
--- a/libinterp/corefcn/interpreter.cc Tue Jun 19 09:05:48 2018 -0400 +++ b/libinterp/corefcn/interpreter.cc Wed Jun 20 15:16:05 2018 -0400 @@ -127,50 +127,6 @@ return retval; } -static void -initialize_version_info (void) -{ - octave_value_list args; - - args(3) = OCTAVE_RELEASE_DATE; - args(2) = octave::config::release (); - args(1) = OCTAVE_VERSION; - args(0) = "GNU Octave"; - - F__version_info__ (args, 0); -} - -OCTAVE_NORETURN static void -lo_error_handler (const char *fmt, ...) -{ - va_list args; - va_start (args, fmt); - verror_with_cfn (fmt, args); - va_end (args); - - octave_throw_execution_exception (); -} - -OCTAVE_NORETURN static void -lo_error_with_id_handler (const char *id, const char *fmt, ...) -{ - va_list args; - va_start (args, fmt); - verror_with_id_cfn (id, fmt, args); - va_end (args); - - octave_throw_execution_exception (); -} - -static void -initialize_error_handlers () -{ - set_liboctave_error_handler (lo_error_handler); - set_liboctave_error_with_id_handler (lo_error_with_id_handler); - set_liboctave_warning_handler (warning); - set_liboctave_warning_with_id_handler (warning_with_id); -} - DEFUN (quit, args, , doc: /* -*- texinfo -*- @deftypefn {} {} exit @@ -281,65 +237,140 @@ return retval; } -// Execute commands from a file and catch potential exceptions in a consistent -// way. This function should be called anywhere we might parse and execute -// commands from a file before we have entered the main loop in -// toplev.cc. - -static int -safe_source_file (const std::string& file_name, - const std::string& context = "", - bool verbose = false, bool require_file = true, - const std::string& warn_for = "") -{ - try - { - octave::source_file (file_name, context, verbose, require_file, warn_for); - } - catch (const octave::interrupt_exception&) - { - octave::interpreter::recover_from_exception (); - - return 1; - } - catch (const octave::execution_exception& e) - { - std::string stack_trace = e.info (); - - if (! stack_trace.empty ()) - std::cerr << stack_trace; - - octave::interpreter::recover_from_exception (); - - return 1; - } - - return 0; -} - -static void -execute_pkg_add (const std::string& dir) -{ - std::string file_name = octave::sys::file_ops::concat (dir, "PKG_ADD"); - - octave::load_path& lp = octave::__get_load_path__ ("execute_pkg_add"); - - try - { - lp.execute_pkg_add (dir); - } - catch (const octave::interrupt_exception&) - { - octave::interpreter::recover_from_exception (); - } - catch (const octave::execution_exception&) - { - octave::interpreter::recover_from_exception (); - } -} - namespace octave { + // Execute commands from a file and catch potential exceptions in a consistent + // way. This function should be called anywhere we might parse and execute + // commands from a file before we have entered the main loop in + // toplev.cc. + + static int safe_source_file (const std::string& file_name, + const std::string& context = "", + bool verbose = false, + bool require_file = true, + const std::string& warn_for = "") + { + try + { + source_file (file_name, context, verbose, require_file, warn_for); + } + catch (const interrupt_exception&) + { + interpreter::recover_from_exception (); + + return 1; + } + catch (const execution_exception& e) + { + std::string stack_trace = e.info (); + + if (! stack_trace.empty ()) + std::cerr << stack_trace; + + interpreter::recover_from_exception (); + + return 1; + } + + return 0; + } + + static void execute_pkg_add (const std::string& dir) + { + std::string file_name = sys::file_ops::concat (dir, "PKG_ADD"); + + load_path& lp = __get_load_path__ ("execute_pkg_add"); + + try + { + lp.execute_pkg_add (dir); + } + catch (const interrupt_exception&) + { + interpreter::recover_from_exception (); + } + catch (const execution_exception&) + { + interpreter::recover_from_exception (); + } + } + + static void initialize_version_info (void) + { + octave_value_list args; + + args(3) = OCTAVE_RELEASE_DATE; + args(2) = config::release (); + args(1) = OCTAVE_VERSION; + args(0) = "GNU Octave"; + + F__version_info__ (args, 0); + } + + static void xerbla_abort (void) + { + error ("Fortran procedure terminated by call to XERBLA"); + } + + static void initialize_xerbla_error_handler (void) + { + // The idea here is to force xerbla to be referenced so that we will + // link to our own version instead of the one provided by the BLAS + // library. But numeric_limits<double>::NaN () should never be -1, so + // we should never actually call xerbla. FIXME (again!): If this + // becomes a constant expression the test might be optimized away and + // then the reference to the function might also disappear. + + if (numeric_limits<double>::NaN () == -1) + F77_FUNC (xerbla, XERBLA) ("octave", 13 F77_CHAR_ARG_LEN (6)); + + typedef void (*xerbla_handler_ptr) (void); + + typedef void (*octave_set_xerbla_handler_ptr) (xerbla_handler_ptr); + + dynamic_library libs (""); + + if (libs) + { + octave_set_xerbla_handler_ptr octave_set_xerbla_handler + = reinterpret_cast<octave_set_xerbla_handler_ptr> + (libs.search ("octave_set_xerbla_handler")); + + if (octave_set_xerbla_handler) + octave_set_xerbla_handler (xerbla_abort); + } + } + + OCTAVE_NORETURN static void + lo_error_handler (const char *fmt, ...) + { + va_list args; + va_start (args, fmt); + verror_with_cfn (fmt, args); + va_end (args); + + octave_throw_execution_exception (); + } + + OCTAVE_NORETURN static void + lo_error_with_id_handler (const char *id, const char *fmt, ...) + { + va_list args; + va_start (args, fmt); + verror_with_id_cfn (id, fmt, args); + va_end (args); + + octave_throw_execution_exception (); + } + + static void initialize_error_handlers (void) + { + set_liboctave_error_handler (lo_error_handler); + set_liboctave_error_with_id_handler (lo_error_with_id_handler); + set_liboctave_warning_handler (warning); + set_liboctave_warning_with_id_handler (warning_with_id); + } + // Create an interpreter object and perform initialization up to the // point of setting reading command history and setting the load // path. @@ -401,15 +432,7 @@ octave_prepare_hdf5 (); - // The idea here is to force xerbla to be referenced so that we will link to - // our own version instead of the one provided by the BLAS library. But - // numeric_limits<double>::NaN () should never be -1, so we - // should never actually call xerbla. FIXME (again!): If this - // becomes a constant expression the test might be optimized away and - // then the reference to the function might also disappear. - - if (numeric_limits<double>::NaN () == -1) - F77_FUNC (xerbla, XERBLA) ("octave", 13 F77_CHAR_ARG_LEN (6)); + initialize_xerbla_error_handler (); initialize_error_handlers ();
--- a/libinterp/module.mk Tue Jun 19 09:05:48 2018 -0400 +++ b/libinterp/module.mk Wed Jun 20 15:16:05 2018 -0400 @@ -166,6 +166,11 @@ liboctave/liboctave.la \ $(LIBOCTINTERP_LINK_DEPS) +if AMCOND_BUILD_EXTERNAL_LIBXERBLA + %canon_reldir%_liboctinterp_la_LIBADD += \ + liboctave/external/blas-xtra/libxerbla.la +endif + # Increment these as needed and according to the rules in the libtool manual: %canon_reldir%_liboctinterp_current = 5 %canon_reldir%_liboctinterp_revision = 0
--- a/liboctave/external/blas-xtra/module.mk Tue Jun 19 09:05:48 2018 -0400 +++ b/liboctave/external/blas-xtra/module.mk Wed Jun 20 15:16:05 2018 -0400 @@ -17,10 +17,31 @@ %reldir%/xscnrm2.f \ %reldir%/xcdotc.f \ %reldir%/xcdotu.f \ - %reldir%/xerbla.f \ %reldir%/cconv2.f \ %reldir%/csconv2.f \ %reldir%/dconv2.f \ %reldir%/sconv2.f \ %reldir%/zconv2.f \ %reldir%/zdconv2.f + +XERBLA_SRC = \ + %reldir%/xerbla.c + +%canon_reldir%_libxerbla_la_SOURCES = $(XERBLA_SRC) + +%canon_reldir%_libxerbla_la_CPPFLAGS = \ + $(liboctave_liboctave_la_CPPFLAGS) + +if AMCOND_BUILD_EXTERNAL_LIBXERBLA + octlib_LTLIBRARIES += %reldir%/libxerbla.la + + %canon_reldir%_libxerbla_la_LDFLAGS = \ + -avoid-version \ + $(NO_UNDEFINED_LDFLAG) \ + -bindir $(bindir) \ + $(WARN_LDFLAGS) +else + noinst_LTLIBRARIES += %reldir%/libxerbla.la + + liboctave_liboctave_la_LIBADD += %reldir%/libxerbla.la +endif
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/liboctave/external/blas-xtra/xerbla.c Wed Jun 20 15:16:05 2018 -0400 @@ -0,0 +1,71 @@ +/* + +Copyright (C) 1996-2018 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 +<https://www.gnu.org/licenses/>. + +*/ + +#if defined (HAVE_CONFIG_H) +# include "config.h" +#endif + +#include <stdio.h> + +#include "f77-fcn.h" + +typedef void (*xerbla_handler_fptr) (void); + +/* Pointer to function to call to handle error. In the Octave + interpreter we set this to a function that throws an exception and + transfers control to the enclosing try/catch block. That is + typically at the top-level REPL. + + We must use a function pointer instead of simply calling error + directly here because this function is called by LAPACK and BLAS + subroutines. To build shared libraries of those packages on Windows + requires that all symbols be known when the shared library is + constructed. If we call error directly, that would mean that the + BLAS and LAPACK libraries would have to depend on Octave... */ + +static xerbla_handler_fptr xerbla_handler = NULL; + +void +octave_set_xerbla_handler (xerbla_handler_fptr fcn) +{ + xerbla_handler = fcn; +} + +/* Replacement for BLAS and LAPACK XERBLA subroutine that calls an + optionally installed handler function. */ + +F77_RET_T +F77_FUNC (xerbla, XERBLA) (F77_CONST_CHAR_ARG_DEF (s_arg, len), + const F77_INT *info + F77_CHAR_ARG_LEN_DEF (len)) +{ + const char *s = F77_CHAR_ARG_USE (s_arg); + size_t slen = F77_CHAR_ARG_LEN_USE (s_arg, len); + + fprintf (stderr, "%.*s: parameter number %ld is invalid\n", slen, s, + (long) (*info)); + + if (xerbla_handler) + (*xerbla_handler) (); + + F77_RETURN (0) +}
--- a/liboctave/external/blas-xtra/xerbla.f Tue Jun 19 09:05:48 2018 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (preliminary version) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - CALL XSTOPX (' ') -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END
--- a/liboctave/util/f77-fcn.c Tue Jun 19 09:05:48 2018 -0400 +++ b/liboctave/util/f77-fcn.c Wed Jun 20 15:16:05 2018 -0400 @@ -34,29 +34,17 @@ /* 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). */ + XSTOPX calls the liboctave error handler. In the Octave interpreter + we set this to a function that throws an exception and transfers + control to the enclosing try/catch block. That is typically at the + top-level REPL. */ 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 +F77_FUNC (xstopx, XSTOPX) (F77_CONST_CHAR_ARG_DEF (s_arg, len) + F77_CHAR_ARG_LEN_DEF (len)) { -#if defined (F77_USES_CRAY_CALLING_CONVENTION) - const char *s = desc.const_ptr = ptr_arg; - unsigned long slen = desc.mask.len; -#endif + const char *s = F77_CHAR_ARG_USE (s_arg); + size_t slen = F77_CHAR_ARG_LEN_USE (s_arg, len); /* Skip printing message if it is just a single blank character. */ if (! (s && slen > 0 && ! (slen == 1 && *s == ' ')))