# HG changeset patch # User jwe # Date 863750574 0 # Node ID 38365813950d6053a1485839209ef226cd1a85f8 # Parent cd5ad3fd80494aa3678f9c740adff4873e1c4bd6 [project @ 1997-05-16 02:42:53 by jwe] diff -r cd5ad3fd8049 -r 38365813950d src/oct-builtin.cc --- a/src/oct-builtin.cc Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ -/* - -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 -#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: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-builtin.h --- a/src/oct-builtin.h Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,72 +0,0 @@ -/* - -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 - -#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: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-fcn.cc --- a/src/oct-fcn.cc Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,64 +0,0 @@ -/* - -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 -#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: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-fcn.h --- a/src/oct-fcn.h Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -/* - -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 - -#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: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-mapper.cc --- a/src/oct-mapper.cc Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,261 +0,0 @@ -/* - -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 -#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: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-mapper.h --- a/src/oct-mapper.h Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -/* - -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 - -#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: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-sym.h --- a/src/oct-sym.h Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -/* - -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 - -#include - -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: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-usr-fcn.cc --- a/src/oct-usr-fcn.cc Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,566 +0,0 @@ -/* - -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 -#endif - -#include "str-vec.h" - -#include -#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; - -// 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), argn_sr (0), nargin_sr (0), - nargout_sr (0) -{ - install_automatic_vars (); - - 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 (table); - tmp->pop_context (); -} - -static void -delete_vr_list (void *list) -{ - tree_va_return_list *tmp = static_cast (list); - tmp->clear (); - delete tmp; -} - -static void -clear_symbol_table (void *table) -{ - symbol_table *tmp = static_cast (table); - tmp->clear (); -} - -static void -unprotect_function (void *sr_arg) -{ - symbol_record *sr = static_cast (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; - - string_vector arg_names = args.name_tags (); - - 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_automatic_vars (arg_names, 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. - - octave_value last_computed_value = cmd_list->eval (); - - 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_automatic_vars (void) -{ - argn_sr = sym_tab->lookup ("argn", true); - nargin_sr = sym_tab->lookup ("nargin", true); - nargout_sr = sym_tab->lookup ("nargout", true); -} - -void -octave_user_function::bind_automatic_vars - (const string_vector& arg_names, int nargin, int nargout) -{ - if (! arg_names.empty ()) - argn_sr->define (arg_names); - - nargin_sr->define (static_cast (nargin)); - nargout_sr->define (static_cast (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; -} - -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"); -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; End: *** -*/ diff -r cd5ad3fd8049 -r 38365813950d src/oct-usr-fcn.h --- a/src/oct-usr-fcn.h Fri May 16 01:13:19 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -/* - -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 - -#include - -#include "oct-fcn.h" -#include "oct-obj.h" - -class string_vector; - -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 argn in the local symbol table. - symbol_record *argn_sr; - - // 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_automatic_vars (void); - - void bind_automatic_vars (const string_vector& arg_names, int nargin, - int nargout); -}; - -#endif - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; End: *** -*/