Mercurial > hg > octave-lyh
changeset 2888:e78978eff91d
[project @ 1997-04-28 01:24:58 by jwe]
author | jwe |
---|---|
date | Mon, 28 Apr 1997 01:27:28 +0000 |
parents | 4b71bb90c388 |
children | 8aa189b811d0 |
files | src/dassl.cc src/fsolve.cc src/lsode.cc src/npsol.cc src/oct-builtin.cc src/oct-builtin.h src/oct-fcn.cc src/oct-fcn.h src/oct-mapper.cc src/oct-mapper.h src/oct-sym.h src/oct-usr-fcn.cc src/oct-usr-fcn.h src/qpsol.cc src/quad.cc |
diffstat | 15 files changed, 1567 insertions(+), 24 deletions(-) [+] |
line wrap: on
line diff
--- a/src/dassl.cc +++ b/src/dassl.cc @@ -35,13 +35,13 @@ #include "gripes.h" #include "help.h" #include "oct-obj.h" +#include "oct-sym.h" #include "pager.h" -#include "pt-fvc.h" #include "utils.h" #include "variables.h" // Global pointer for user defined function required by dassl. -static tree_fvc *dassl_fcn; +static octave_symbol *dassl_fcn; static DASSL_options dassl_opts; @@ -83,7 +83,7 @@ if (dassl_fcn) { - octave_value_list tmp = dassl_fcn->eval (false, 1, args); + octave_value_list tmp = dassl_fcn->eval (1, args); if (error_state) {
--- a/src/fsolve.cc +++ b/src/fsolve.cc @@ -34,14 +34,14 @@ #include "error.h" #include "gripes.h" #include "help.h" +#include "oct-sym.h" +#include "oct-obj.h" #include "pager.h" -#include "pt-fvc.h" -#include "oct-obj.h" #include "utils.h" #include "variables.h" // Global pointer for user defined function required by hybrd1. -static tree_fvc *fsolve_fcn; +static octave_symbol *fsolve_fcn; static NLEqn_options fsolve_opts; @@ -106,7 +106,7 @@ if (fsolve_fcn) { - octave_value_list tmp = fsolve_fcn->eval (false, 1, args); + octave_value_list tmp = fsolve_fcn->eval (1, args); if (tmp.length () > 0 && tmp(0).is_defined ()) { retval = tmp(0).vector_value ();
--- a/src/lsode.cc +++ b/src/lsode.cc @@ -29,22 +29,23 @@ #include <iostream.h> #include "LSODE.h" +#include "lo-mappers.h" #include "defun-dld.h" #include "error.h" #include "gripes.h" #include "help.h" #include "oct-obj.h" +#include "oct-sym.h" #include "pager.h" -#include "pt-fvc.h" #include "utils.h" #include "variables.h" // Global pointer for user defined function required by lsode. -static tree_fvc *lsode_fcn; +static octave_symbol *lsode_fcn; // Global pointer for optional user defined jacobian function used by lsode. -static tree_fvc *lsode_jac; +static octave_symbol *lsode_jac; static LSODE_options lsode_opts; @@ -66,7 +67,7 @@ if (lsode_fcn) { - octave_value_list tmp = lsode_fcn->eval (false, 1, args); + octave_value_list tmp = lsode_fcn->eval (1, args); if (error_state) { @@ -106,7 +107,7 @@ if (lsode_jac) { - octave_value_list tmp = lsode_jac->eval (false, 1, args); + octave_value_list tmp = lsode_jac->eval (1, args); if (error_state) {
--- a/src/npsol.cc +++ b/src/npsol.cc @@ -29,23 +29,23 @@ #include <iostream.h> #include "NPSOL.h" +#include "lo-mappers.h" #include "defun-dld.h" #include "error.h" #include "gripes.h" #include "help.h" -#include "mappers.h" #include "oct-obj.h" +#include "oct-sym.h" #include "pager.h" -#include "pt-fvc.h" #include "utils.h" #include "variables.h" #ifndef NPSOL_MISSING // Global pointers for user defined functions required by npsol. -static tree_fvc *npsol_objective; -static tree_fvc *npsol_constraints; +static octave_symbol *npsol_objective; +static octave_symbol *npsol_constraints; static NPSOL_options npsol_opts; @@ -77,7 +77,7 @@ octave_value objective_value; if (npsol_objective) { - octave_value_list tmp = npsol_objective->eval (false, 1, args); + octave_value_list tmp = npsol_objective->eval (1, args); if (error_state) { @@ -146,7 +146,7 @@ if (npsol_constraints) { - octave_value_list tmp = npsol_constraints->eval (false, 1, args); + octave_value_list tmp = npsol_constraints->eval (1, args); if (error_state) {
new file mode 100644 --- /dev/null +++ b/src/oct-builtin.cc @@ -0,0 +1,88 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if defined (__GNUG__) +#pragma implementation +#endif + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "error.h" +#include "oct-obj.h" +#include "oct-builtin.h" +#include "ov.h" + +octave_value +octave_builtin::eval (void) +{ + octave_value retval; + + if (error_state) + return retval; + + octave_value_list args; + + octave_value_list tmp = (*f) (args, 0); + + if (tmp.length () > 0) + retval = tmp(0); + + return retval; +} + +// Are any of the arguments `:'? + +static bool +any_arg_is_magic_colon (const octave_value_list& args) +{ + int nargin = args.length (); + + for (int i = 0; i < nargin; i++) + if (args(i).is_magic_colon ()) + return true; + + return false; +} + +octave_value_list +octave_builtin::eval (int nargout, const octave_value_list& args) +{ + octave_value_list retval; + + if (error_state) + return retval; + + if (any_arg_is_magic_colon (args)) + ::error ("invalid use of colon in function argument list"); + else + retval = (*f) (args, nargout); + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-builtin.h @@ -0,0 +1,72 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_builtin_h) +#define octave_builtin_h 1 + +#if defined (__GNUG__) +#pragma interface +#endif + +#include <string> + +#include "oct-fcn.h" + +class octave_value; +class octave_value_list; + +// Builtin functions. + +class +octave_builtin : public octave_function +{ +public: + + typedef octave_value_list (*fcn) (const octave_value_list&, int); + + octave_builtin (fcn ff, const string& nm = string (), + const string& ds = string ()) + : octave_function (nm, ds), f (ff) { } + + ~octave_builtin (void) { } + + octave_value eval (void); + + octave_value_list eval (int nargout, const octave_value_list& args); + +private: + + octave_builtin (void); + + octave_builtin (const octave_builtin& m); + + // A pointer to the actual function. + fcn f; +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-fcn.cc @@ -0,0 +1,64 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if defined (__GNUG__) +#pragma implementation +#endif + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "error.h" +#include "oct-fcn.h" + +octave_function::octave_function (octave_function *new_rep) + : rep (new_rep) +{ + rep->count = 1; +} + +octave_function::~octave_function (void) +{ +#if defined (MDEBUG) + cerr << "~octave_function: rep: " << rep + << " rep->count: " << rep->count << "\n"; +#endif + + if (rep && --rep->count == 0) + { + delete rep; + rep = 0; + } +} + +octave_function * +octave_function::clone (void) +{ + panic_impossible (); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-fcn.h @@ -0,0 +1,128 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_function_h) +#define octave_function_h 1 + +#if defined (__GNUG__) +#pragma interface +#endif + +#include <string> + +#include "oct-sym.h" + +// Functions. + +// This just provides a way to avoid infinite recursion when building +// octave_function objects. + +class octave_function; + +class +octave_function : public octave_symbol +{ +public: + + octave_function (octave_function *new_rep); + + // Copy constructor. + + octave_function (const octave_function& a) + { + rep = a.rep; + rep->count++; + } + + // Delete the representation of this constant if the count drops to + // zero. + + virtual ~octave_function (void); + + // This should only be called for derived types. + + virtual octave_function *clone (void); + + void make_unique (void) + { + if (rep->count > 1) + { + --rep->count; + rep = rep->clone (); + rep->count = 1; + } + } + + // Simple assignment. + + octave_function& operator = (const octave_function& a) + { + if (rep != a.rep) + { + if (--rep->count == 0) + delete rep; + + rep = a.rep; + rep->count++; + } + + return *this; + } + + string name (void) const + { return my_name; } + + string doc_string (void) const + { return doc; } + + bool is_constant (void) const + { return false; } + +protected: + + octave_function (const string& nm, const string& ds) + : rep (0), my_name (nm), doc (ds) { } + +private: + + octave_function (void); + + union + { + octave_function *rep; // The real representation. + int count; // A reference count. + }; + + // The name of this function. + string my_name; + + // The help text for this function. + string doc; +}; + +#endif + +/* +;; Local Variables: *** +;; mode: C++ *** +;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-mapper.cc @@ -0,0 +1,261 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if defined (__GNUG__) +#pragma implementation +#endif + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include "error.h" +#include "gripes.h" +#include "oct-obj.h" +#include "oct-mapper.h" +#include "ov.h" + +octave_value +octave_mapper::eval (void) +{ + octave_value retval; + + if (error_state) + return retval; + + ::error ("%s: too few arguments", name().c_str ()); + + return retval; +} + +static bool +any_element_less_than (const Matrix& a, double val) +{ + int nr = a.rows (); + int nc = a.columns (); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + if (a (i, j) < val) + return true; + + return false; +} + +static bool +any_element_greater_than (const Matrix& a, double val) +{ + int nr = a.rows (); + int nc = a.columns (); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + if (a (i, j) > val) + return true; + + return false; +} + +octave_value +octave_mapper::apply (const octave_value& arg) const +{ + octave_value retval; + + if (ch_map_fcn) + { + // XXX FIXME XXX -- this could be done in a better way... + + octave_value tmp = arg.convert_to_str (); + + if (! error_state) + { + charMatrix chm = tmp.char_matrix_value (); + + if (! error_state) + { + int nr = chm.rows (); + int nc = chm.cols (); + + switch (flag) + { + case 0: + { + Matrix result (nr, nc); + + // islapha and friends can return any nonzero value + // to mean true, but we want to return 1 or 0 only. + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result (i, j) = ch_map_fcn (chm (i, j)) ? 1 : 0; + + retval = result; + } + break; + + case 1: + { + Matrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result (i, j) = ch_map_fcn (chm (i, j)); + + retval = result; + } + break; + + case 2: + { + charMatrix result (nr, nc); + + for (int j = 0; j < nc; j++) + for (int i = 0; i < nr; i++) + result (i, j) = ch_map_fcn (chm (i, j)); + + retval = octave_value (result, true); + } + break; + + default: + panic_impossible (); + break; + } + } + } + } + else + { + if (arg.is_real_type ()) + { + if (arg.is_scalar_type ()) + { + double d = arg.double_value (); + + if (flag && (d < lower_limit || d > upper_limit)) + { + if (c_c_map_fcn) + retval = c_c_map_fcn (Complex (d)); + else + error ("%s: unable to handle real arguments", + name().c_str ()); + } + else if (d_d_map_fcn) + retval = d_d_map_fcn (d); + else + error ("%s: unable to handle real arguments", + name().c_str ()); + } + else + { + Matrix m = arg.matrix_value (); + + if (error_state) + return retval; + + if (flag + && (any_element_less_than (m, lower_limit) + || any_element_greater_than (m, upper_limit))) + { + if (c_c_map_fcn) + { + ComplexMatrix cm (m); + retval = cm.map (c_c_map_fcn); + } + else + error ("%s: unable to handle real arguments", + name().c_str ()); + } + else if (d_d_map_fcn) + retval = m.map (d_d_map_fcn); + else + error ("%s: unable to handle real arguments", + name().c_str ()); + } + } + else if (arg.is_complex_type ()) + { + if (arg.is_scalar_type ()) + { + Complex c = arg.complex_value (); + + if (d_c_map_fcn) + retval = d_c_map_fcn (c); + else if (c_c_map_fcn) + retval = c_c_map_fcn (c); + else + error ("%s: unable to handle complex arguments", + name().c_str ()); + } + else + { + ComplexMatrix cm = arg.complex_matrix_value (); + + if (error_state) + return retval; + + if (d_c_map_fcn) + retval = cm.map (d_c_map_fcn); + else if (c_c_map_fcn) + retval = cm.map (c_c_map_fcn); + else + error ("%s: unable to handle complex arguments", + name().c_str ()); + } + } + else + gripe_wrong_type_arg ("mapper", arg); + } + + return retval; +} + +octave_value_list +octave_mapper::eval (int, const octave_value_list& args) +{ + octave_value retval; + + if (error_state) + return retval; + + int nargin = args.length (); + + if (nargin > 1) + ::error ("%s: too many arguments", name().c_str ()); + else if (nargin < 1) + ::error ("%s: too few arguments", name().c_str ()); + else + { + if (args(0).is_defined ()) + retval = apply (args(0)); + else + ::error ("%s: argument undefined", name().c_str ()); + } + + return retval; +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-mapper.h @@ -0,0 +1,104 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_mapper_h) +#define octave_mapper_h 1 + +#if defined (__GNUG__) +#pragma interface +#endif + +#include <string> + +#include "oct-fcn.h" + +class octave_value; +class octave_value_list; + +// Builtin mapper functions. + +class +octave_mapper : public octave_function +{ +public: + + typedef int (*ch_mapper) (int); + typedef double (*d_d_mapper) (double); + typedef double (*d_c_mapper) (const Complex&); + typedef Complex (*c_c_mapper) (const Complex&); + + octave_mapper (ch_mapper ch, d_d_mapper dd, d_c_mapper dc, + c_c_mapper cc, double ll, double ul, int f, + const string& nm = string (), + const string& ds = string ()) + : octave_function (nm, ds), ch_map_fcn (ch), d_d_map_fcn (dd), + d_c_map_fcn (dc), c_c_map_fcn (cc), + lower_limit (ll), upper_limit (ul), flag (f) { } + + ~octave_mapper (void) { } + + octave_value eval (void); + + octave_value_list eval (int nargout, const octave_value_list& args); + +private: + + octave_mapper (void); + + octave_mapper (const octave_mapper& m); + + octave_value apply (const octave_value& arg) const; + + // ch_map_fcn is a kluge. + + ch_mapper ch_map_fcn; + d_d_mapper d_d_map_fcn; + d_c_mapper d_c_map_fcn; + c_c_mapper c_c_map_fcn; + + // If flag is nonzero and we are not calling ch_map_fcn, lower_limit + // and upper_limit specify the range of values for which a real arg + // returns a real value. Outside that range, we have to convert args + // to complex, and call the complex valued function. + + double lower_limit; + double upper_limit; + + // For ch_map_fcn, flag has the following meanings: + // + // 0 => this function returns a matrix of ones and zeros + // 1 => this function returns a numeric matrix (any values) + // 2 => this function returns a string array + // + // For other mappers, nonzero means that this function can return a + // complex value for some real arguments. + + int flag; +}; + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-sym.h @@ -0,0 +1,60 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_symbol_h) +#define octave_symbol_h 1 + +#include <ctime> + +#include <string> + +class tree_walker; +class octave_value; +class octave_value_list; + +class +octave_symbol +{ +public: + + virtual ~octave_symbol (void) { } + + virtual octave_value eval (void) = 0; + + virtual octave_value_list eval (int, const octave_value_list&) = 0; + + virtual bool is_constant (void) const = 0; + + virtual bool is_system_fcn_file (void) { return false; } + + virtual string fcn_file_name (void) const { return string (); } + + virtual time_t time_parsed (void) const { return 0; } +}; + +#endif + +/* +;; Local Variables: *** +;; mode: C++ *** +;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-usr-fcn.cc @@ -0,0 +1,572 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if defined (__GNUG__) +#pragma implementation +#endif + +#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <defaults.h> +#include "defun.h" +#include "error.h" +#include "help.h" +#include "input.h" +#include "oct-obj.h" +#include "oct-usr-fcn.h" +#include "ov.h" +#include "pager.h" +#include "pt-misc.h" +#include "pt-pr-code.h" +#include "pt-walk.h" +#include "symtab.h" +#include "toplev.h" +#include "unwind-prot.h" +#include "utils.h" +#include "variables.h" + +// If TRUE, variables returned from functions have default values even +// if they are not explicitly initialized. +static bool Vdefine_all_return_values; + +// If TRUE, the last computed value is returned from functions that +// don't actually define any return variables. +static bool Vreturn_last_computed_value; + +// If TRUE, turn off printing of results in functions (as if a +// semicolon has been appended to each statement). +static bool Vsilent_functions; + +// Nonzero means we're breaking out of a loop or function body. +extern int breaking; + +// Nonzero means we're returning from a function. +extern int returning; + +// User defined functions. + +// Ugh. This really needs to be simplified (code/data? +// extrinsic/intrinsic state?). + +octave_user_function::octave_user_function + (tree_parameter_list *pl, tree_parameter_list *rl, + tree_statement_list *cl, symbol_table *st) + : octave_function (string (), string ()), + param_list (pl), ret_list (rl), cmd_list (cl), + sym_tab (st), file_name (), fcn_name (), t_parsed (0), + system_fcn_file (false), call_depth (0), num_named_args (0), + args_passed (), num_args_passed (0), curr_va_arg_number (0), + vr_list (0), symtab_entry (0), nargin_sr (0), nargout_sr (0) +{ + install_nargin_and_nargout (); + + if (param_list) + { + num_named_args = param_list->length (); + curr_va_arg_number = num_named_args; + } +} + +octave_user_function::~octave_user_function (void) +{ + delete param_list; + delete ret_list; + delete sym_tab; + delete cmd_list; + delete vr_list; +} + +octave_user_function * +octave_user_function::define_ret_list (tree_parameter_list *t) +{ + ret_list = t; + + if (ret_list && ret_list->takes_varargs ()) + vr_list = new tree_va_return_list; + + return this; +} + +void +octave_user_function::stash_fcn_file_name (void) +{ + if (fcn_name.empty ()) + file_name = ""; + else + file_name = fcn_file_in_path (fcn_name); +} + +void +octave_user_function::mark_as_system_fcn_file (void) +{ + if (! file_name.empty ()) + { + // We really should stash the whole path to the file we found, + // when we looked it up, to avoid possible race conditions... + // XXX FIXME XXX + // + // We probably also don't need to get the library directory + // every time, but since this function is only called when the + // function file is parsed, it probably doesn't matter that + // much. + + string ff_name = fcn_file_in_path (file_name); + + if (Vfcn_file_dir.compare (ff_name, 0, Vfcn_file_dir.length ()) == 0) + system_fcn_file = 1; + } + else + system_fcn_file = 0; +} + +bool +octave_user_function::takes_varargs (void) const +{ + return (param_list && param_list->takes_varargs ()); +} + +octave_value +octave_user_function::octave_va_arg (void) +{ + octave_value retval; + + if (curr_va_arg_number < num_args_passed) + retval = args_passed (curr_va_arg_number++); + else + ::error ("va_arg: error getting arg number %d -- only %d provided", + curr_va_arg_number + 1, num_args_passed); + + return retval; +} + +octave_value_list +octave_user_function::octave_all_va_args (void) +{ + octave_value_list retval; + + retval.resize (num_args_passed - num_named_args); + + int k = 0; + for (int i = num_named_args; i < num_args_passed; i++) + retval(k++) = args_passed(i); + + return retval; +} + +bool +octave_user_function::takes_var_return (void) const +{ + return (ret_list && ret_list->takes_varargs ()); +} + +void +octave_user_function::octave_vr_val (const octave_value& val) +{ + assert (vr_list); + + vr_list->append (val); +} + +void +octave_user_function::stash_function_name (const string& s) +{ + fcn_name = s; +} + +octave_value +octave_user_function::eval (void) +{ + octave_value retval; + + if (error_state || ! cmd_list) + return retval; + + octave_value_list tmp_args; + octave_value_list tmp = eval (0, tmp_args); + + if (! error_state && tmp.length () > 0) + retval = tmp(0); + + return retval; +} + +// For unwind protect. + +static void +pop_symbol_table_context (void *table) +{ + symbol_table *tmp = static_cast<symbol_table *> (table); + tmp->pop_context (); +} + +static void +delete_vr_list (void *list) +{ + tree_va_return_list *tmp = static_cast<tree_va_return_list *> (list); + tmp->clear (); + delete tmp; +} + +static void +clear_symbol_table (void *table) +{ + symbol_table *tmp = static_cast<symbol_table *> (table); + tmp->clear (); +} + +static void +unprotect_function (void *sr_arg) +{ + symbol_record *sr = static_cast<symbol_record *> (sr_arg); + sr->unprotect (); +} + +octave_value_list +octave_user_function::eval (int nargout, const octave_value_list& args) +{ + octave_value_list retval; + + if (error_state) + return retval; + + if (! cmd_list) + return retval; + + int nargin = args.length (); + + begin_unwind_frame ("func_eval"); + + unwind_protect_int (call_depth); + call_depth++; + + if (symtab_entry && ! symtab_entry->is_read_only ()) + { + symtab_entry->protect (); + add_unwind_protect (unprotect_function, symtab_entry); + } + + if (call_depth > 1) + { + sym_tab->push_context (); + add_unwind_protect (pop_symbol_table_context, sym_tab); + + if (vr_list) + { + // Push new vr_list. + + unwind_protect_ptr (vr_list); + vr_list = new tree_va_return_list; + + // Clear and delete the new one before restoring the old + // one. + + add_unwind_protect (delete_vr_list, vr_list); + } + } + + if (vr_list) + vr_list->clear (); + + // Force symbols to be undefined again when this function exits. + + add_unwind_protect (clear_symbol_table, sym_tab); + + // Save old and set current symbol table context, for + // eval_undefined_error(). + + unwind_protect_ptr (curr_sym_tab); + curr_sym_tab = sym_tab; + + unwind_protect_ptr (curr_function); + curr_function = this; + + // XXX FIXME XXX -- ??? + // unwind_protect_ptr (args_passed); + + args_passed = args; + + unwind_protect_int (num_args_passed); + num_args_passed = nargin; + + unwind_protect_int (num_named_args); + unwind_protect_int (curr_va_arg_number); + + if (param_list && ! param_list->varargs_only ()) + { + param_list->define_from_arg_vector (args); + if (error_state) + goto abort; + } + + if (ret_list && Vdefine_all_return_values) + { + octave_value tmp = builtin_any_variable ("default_return_value"); + + if (tmp.is_defined ()) + ret_list->initialize_undefined_elements (tmp); + } + + // The following code is in a separate scope to avoid warnings from + // G++ about `goto abort' crossing the initialization of some + // variables. + + { + bind_nargin_and_nargout (nargin, nargout); + + bool echo_commands = (Vecho_executing_commands & ECHO_FUNCTIONS); + + if (echo_commands) + print_code_function_header (); + + // Evaluate the commands that make up the function. + + bool pf = ! Vsilent_functions; + octave_value last_computed_value = cmd_list->eval (pf); + + if (echo_commands) + print_code_function_trailer (); + + if (returning) + returning = 0; + + if (breaking) + breaking--; + + if (error_state) + { + traceback_error (); + goto abort; + } + + // Copy return values out. + + if (ret_list) + retval = ret_list->convert_to_const_vector (vr_list); + else if (Vreturn_last_computed_value) + retval(0) = last_computed_value; + } + + abort: + run_unwind_frame ("func_eval"); + + return retval; +} + +void +octave_user_function::traceback_error (void) +{ + if (error_state >= 0) + error_state = -1; + + if (fcn_name.empty ()) + { + if (file_name.empty ()) + ::error ("called from `?unknown?'"); + else + ::error ("called from file `%s'", file_name.c_str ()); + } + else + { + if (file_name.empty ()) + ::error ("called from `%s'", fcn_name.c_str ()); + else + ::error ("called from `%s' in file `%s'", + fcn_name.c_str (), file_name.c_str ()); + } +} + +void +octave_user_function::accept (tree_walker& tw) +{ + tw.visit_octave_user_function (*this); +} + +void +octave_user_function::print_code_function_header (void) +{ + tree_print_code tpc (octave_stdout, Vps4); + + tpc.visit_octave_user_function_header (*this); +} + +void +octave_user_function::print_code_function_trailer (void) +{ + tree_print_code tpc (octave_stdout, Vps4); + + tpc.visit_octave_user_function_trailer (*this); +} + +void +octave_user_function::install_nargin_and_nargout (void) +{ + nargin_sr = sym_tab->lookup ("nargin", true); + nargout_sr = sym_tab->lookup ("nargout", true); +} + +void +octave_user_function::bind_nargin_and_nargout (int nargin, int nargout) +{ + nargin_sr->define (static_cast<double> (nargin)); + nargout_sr->define (static_cast<double> (nargout)); +} + +DEFUN (va_arg, args, , + "va_arg (): return next argument in a function that takes a\n\ +variable number of parameters") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin == 0) + { + if (curr_function) + { + if (curr_function->takes_varargs ()) + retval = curr_function->octave_va_arg (); + else + { + ::error ("va_arg only valid within function taking variable"); + ::error ("number of arguments"); + } + } + else + ::error ("va_arg only valid within function body"); + } + else + print_usage ("va_arg"); + + return retval; +} + +DEFUN (va_start, args, , + "va_start (): reset the pointer to the list of optional arguments\n\ +to the beginning") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin == 0) + { + if (curr_function) + { + if (curr_function->takes_varargs ()) + curr_function->octave_va_start (); + else + { + ::error ("va_start only valid within function taking variable"); + ::error ("number of arguments"); + } + } + else + ::error ("va_start only valid within function body"); + } + else + print_usage ("va_start"); + + return retval; +} + +DEFUN (vr_val, args, , + "vr_val (X): append X to the list of optional return values for a\n\ +function that allows a variable number of return values") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin == 1) + { + if (curr_function) + { + if (curr_function->takes_var_return ()) + curr_function->octave_vr_val (args(0)); + else + { + ::error ("vr_val only valid within function declared to"); + ::error ("produce a variable number of values"); + } + } + else + ::error ("vr_val only valid within function body"); + } + else + print_usage ("vr_val"); + + return retval; +} + +static int +define_all_return_values (void) +{ + Vdefine_all_return_values = check_preference ("define_all_return_values"); + + return 0; +} + +static int +return_last_computed_value (void) +{ + Vreturn_last_computed_value + = check_preference ("return_last_computed_value"); + + return 0; +} + +static int +silent_functions (void) +{ + Vsilent_functions = check_preference ("silent_functions"); + + return 0; +} + +void +symbols_of_oct_usr_fcn (void) +{ + DEFVAR (default_return_value, Matrix (), 0, 0, + "the default for value for unitialized variables returned from\n\ +functions. Only used if the variable initialize_return_values is\n\ +set to \"true\"."); + + DEFVAR (define_all_return_values, 0.0, 0, define_all_return_values, + "control whether values returned from functions should have a\n\ +value even if one has not been explicitly assigned. See also\n\ +default_return_value"); + + DEFVAR (return_last_computed_value, 0.0, 0, return_last_computed_value, + "if a function does not return any values explicitly, return the\n\ + last computed value"); + + DEFVAR (silent_functions, 0.0, 0, silent_functions, + "suppress printing results in called functions"); +} + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
new file mode 100644 --- /dev/null +++ b/src/oct-usr-fcn.h @@ -0,0 +1,193 @@ +/* + +Copyright (C) 1996, 1997 John W. Eaton + +This file is part of Octave. + +Octave is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +Octave is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with Octave; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +*/ + +#if !defined (octave_user_function_h) +#define octave_user_function_h 1 + +#if defined (__GNUG__) +#pragma interface +#endif + +#include <ctime> + +#include <string> + +#include "oct-fcn.h" +#include "oct-obj.h" + +class octave_value; +class tree_parameter_list; +class tree_statement_list; +class tree_va_return_list; +class tree_walker; +class symbol_table; +class symbol_record; + +// Builtin functions. + +class +octave_user_function : public octave_function +{ +public: + + octave_user_function (tree_parameter_list *pl = 0, + tree_parameter_list *rl = 0, + tree_statement_list *cl = 0, + symbol_table *st = 0); + + ~octave_user_function (void); + + octave_user_function *define_param_list (tree_parameter_list *t); + + octave_user_function *define_ret_list (tree_parameter_list *t); + + void stash_fcn_file_name (void); + + void stash_fcn_file_time (time_t t) + { t_parsed = t; } + + void stash_symtab_ptr (symbol_record *sr) + { symtab_entry = sr; } + + string fcn_file_name (void) const + { return file_name; } + + time_t time_parsed (void) const + { return t_parsed; } + + void mark_as_system_fcn_file (void); + + bool is_system_fcn_file (void) const + { return system_fcn_file; } + + bool takes_varargs (void) const; + + void octave_va_start (void) + { curr_va_arg_number = num_named_args; } + + octave_value octave_va_arg (void); + + octave_value_list octave_all_va_args (void); + + bool takes_var_return (void) const; + + void octave_vr_val (const octave_value& val); + + void stash_function_name (const string& s); + + string function_name (void) + { return fcn_name; } + + octave_value eval (void); + + octave_value_list eval (int nargout, const octave_value_list& args); + + void traceback_error (void); + + tree_parameter_list *parameter_list (void) { return param_list; } + + tree_parameter_list *return_list (void) { return ret_list; } + + tree_statement_list *body (void) { return cmd_list; } + + void accept (tree_walker& tw); + + +private: + + octave_user_function (void); + + octave_user_function (const octave_user_function& m); + + // List of arguments for this function. These are local variables. + tree_parameter_list *param_list; + + // List of parameters we return. These are also local variables in + // this function. + tree_parameter_list *ret_list; + + // The list of commands that make up the body of this function. + tree_statement_list *cmd_list; + + // The local symbol table for this function. + symbol_table *sym_tab; + + // The name of the file we parsed + string file_name; + + // The name of the function. + string fcn_name; + + // The time the file was parsed. + time_t t_parsed; + + // True if this function came from a file that is considered to be a + // system function. This affects whether we check the time stamp + // on the file to see if it has changed. + bool system_fcn_file; + + // Used to keep track of recursion depth. + int call_depth; + + // The number of arguments that have names. + int num_named_args; + + // The values that were passed as arguments. + octave_value_list args_passed; + + // The number of arguments passed in. + int num_args_passed; + + // Used to keep track of the current offset into the list of va_args. + int curr_va_arg_number; + + // The list of return values when an unspecified number can be + // returned. + tree_va_return_list *vr_list; + + // The symbol record for this function. + symbol_record *symtab_entry; + + // The symbol record for nargin in the local symbol table. + symbol_record *nargin_sr; + + // The symbol record for nargout in the local symbol table. + symbol_record *nargout_sr; + + void print_code_function_header (void); + + void print_code_function_trailer (void); + + void install_nargin_and_nargout (void); + + void bind_nargin_and_nargout (int nargin, int nargout); +}; + +extern void symbols_of_oct_usr_fcn (void); + +#endif + +/* +;;; Local Variables: *** +;;; mode: C++ *** +;;; End: *** +*/
--- a/src/qpsol.cc +++ b/src/qpsol.cc @@ -29,15 +29,15 @@ #include <iostream.h> #include "QPSOL.h" +#include "lo-mappers.h" #include "defun-dld.h" #include "error.h" #include "gripes.h" #include "help.h" -#include "mappers.h" #include "oct-obj.h" +#include "oct-sym.h" #include "pager.h" -#include "pt-fvc.h" #include "utils.h" #include "variables.h"
--- a/src/quad.cc +++ b/src/quad.cc @@ -29,14 +29,14 @@ #include <iostream.h> #include "Quad.h" +#include "lo-mappers.h" #include "defun-dld.h" #include "error.h" #include "gripes.h" #include "help.h" -#include "mappers.h" +#include "oct-sym.h" #include "pager.h" -#include "pt-fvc.h" #include "oct-obj.h" #include "utils.h" #include "variables.h" @@ -46,7 +46,7 @@ #endif // Global pointer for user defined function required by quadrature functions. -static tree_fvc *quad_fcn; +static octave_symbol *quad_fcn; static Quad_options quad_opts; @@ -60,7 +60,7 @@ if (quad_fcn) { - octave_value_list tmp = quad_fcn->eval (false, 1, args); + octave_value_list tmp = quad_fcn->eval (1, args); if (error_state) {