# HG changeset patch # User jwe # Date 862190254 0 # Node ID 969032befa3d0e37d3b17b0060e06a688167a81d # Parent a65b62d2f6302ac4cccbfc77f1f66c0b7753daec [project @ 1997-04-28 01:17:34 by jwe] diff -r a65b62d2f630 -r 969032befa3d src/pt-fcn.cc --- a/src/pt-fcn.cc Sat Apr 26 18:56:11 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,568 +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 - -#include -#include "defun.h" -#include "error.h" -#include "gripes.h" -#include "help.h" -#include "input.h" -#include "pager.h" -#include "symtab.h" -#include "toplev.h" -#include "pt-exp.h" -#include "pt-fcn.h" -#include "pt-misc.h" -#include "pt-pr-code.h" -#include "pt-walk.h" -#include "unwind-prot.h" -#include "utils.h" -#include "ov.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. - -void -tree_function::install_nargin_and_nargout (void) -{ - nargin_sr = sym_tab->lookup ("nargin", true); - nargout_sr = sym_tab->lookup ("nargout", true); -} - -void -tree_function::bind_nargin_and_nargout (int nargin, int nargout) -{ - nargin_sr->define (static_cast (nargin)); - nargout_sr->define (static_cast (nargout)); -} - -tree_function::~tree_function (void) -{ - delete param_list; - delete ret_list; - delete sym_tab; - delete cmd_list; - delete vr_list; -} - -tree_function * -tree_function::define_param_list (tree_parameter_list *t) -{ - param_list = t; - - if (param_list) - { - num_named_args = param_list->length (); - curr_va_arg_number = num_named_args; - } - - return this; -} - -tree_function * -tree_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 -tree_function::stash_fcn_file_name (void) -{ - if (fcn_name.empty ()) - file_name = ""; - else - file_name = fcn_file_in_path (fcn_name); -} - -void -tree_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 -tree_function::takes_varargs (void) const -{ - return (param_list && param_list->takes_varargs ()); -} - -octave_value -tree_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 -tree_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 -tree_function::takes_var_return (void) const -{ - return (ret_list && ret_list->takes_varargs ()); -} - -void -tree_function::octave_vr_val (const octave_value& val) -{ - assert (vr_list); - - vr_list->append (val); -} - -void -tree_function::stash_function_name (const string& s) -{ - fcn_name = s; -} - -octave_value -tree_function::eval (bool print) -{ - octave_value retval; - - if (error_state || ! cmd_list) - return retval; - - octave_value_list tmp_args; - octave_value_list tmp = eval (print, 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 -tree_function::eval (bool /* print */, 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 -tree_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 -tree_function::print_code_function_header (void) -{ - tree_print_code tpc (octave_stdout, Vps4); - - tpc.visit_function_header (*this); -} - -void -tree_function::print_code_function_trailer (void) -{ - tree_print_code tpc (octave_stdout, Vps4); - - tpc.visit_function_trailer (*this); -} - -void -tree_function::accept (tree_walker& tw) -{ - tw.visit_function (*this); -} - -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_pt_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: *** -*/ diff -r a65b62d2f630 -r 969032befa3d src/pt-fcn.h --- a/src/pt-fcn.h Sat Apr 26 18:56:11 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,213 +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_tree_fcn_h) -#define octave_tree_fcn_h 1 - -#if defined (__GNUG__) -#pragma interface -#endif - -#include - -class ostream; - -#include - -class symbol_table; -class tree_parameter_list; -class tree_statement_list; -class tree_va_return_list; - -class tree_walker; - -#include "oct-obj.h" -#include "pt-fvc.h" - -// User defined functions. - -class -tree_function : public tree_fvc -{ -public: - - tree_function (int l = -1, int c = -1) : tree_fvc (l, c) - { init (); } - - tree_function (tree_statement_list *cl, symbol_table *st, - int l = -1, int c = -1) - : tree_fvc (l, c) - { - init (); - sym_tab = st; - cmd_list = cl; - install_nargin_and_nargout (); - } - - ~tree_function (void); - -// tree_function *define (tree_statement_list *t); - tree_function *define_param_list (tree_parameter_list *t); - tree_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) - { return file_name; } - - time_t time_parsed (void) - { 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 (bool print = false); - - octave_value_list eval (bool print, 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: - - // 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; - - // Used to keep track of recursion depth. - int call_depth; - - // 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; - - // 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); - - void init (void) - { - call_depth = 0; - param_list = 0; - ret_list = 0; - sym_tab = 0; - cmd_list = 0; - t_parsed = 0; - system_fcn_file = 0; - num_named_args = 0; - num_args_passed = 0; - curr_va_arg_number = 0; - vr_list = 0; - symtab_entry = 0; - } -}; - -extern void symbols_of_pt_fcn (void); - -#endif - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; End: *** -*/ diff -r a65b62d2f630 -r 969032befa3d src/pt-fvc-base.cc --- a/src/pt-fvc-base.cc Sat Apr 26 18:56:11 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,68 +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 - -#include - -#include "error.h" -#include "oct-obj.h" -#include "ov.h" -#include "pt-fvc-base.h" - -// A base class for objects that can be evaluated with argument lists. - -string -tree_fvc::name (void) const -{ - string retval; - panic_impossible (); - return retval; -} - -time_t -tree_fvc::time_parsed (void) -{ - panic_impossible (); - return 0; -} - -int -tree_fvc::save (ostream&, bool, int) -{ - panic_impossible (); - return 0; -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; End: *** -*/ diff -r a65b62d2f630 -r 969032befa3d src/pt-fvc-base.h --- a/src/pt-fvc-base.h Sat Apr 26 18:56:11 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +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_tree_fvc_h) -#define octave_tree_fvc_h 1 - -#if defined (__GNUG__) -#pragma interface -#endif - -#include - -class ostream; - -#include - -#include - -class octave_value; -class octave_value_list; - -#include "pt-mvr-base.h" - -// A base class for objects that can be evaluated with argument lists. - -class -tree_fvc : public tree_multi_val_ret -{ -public: - - tree_fvc (int l = -1, int c = -1) - : tree_multi_val_ret (l, c) { } - - ~tree_fvc (void) { } - - virtual string name (void) const; - - virtual string fcn_file_name (void) - { return string (); } - - virtual time_t time_parsed (void); - - virtual bool is_system_fcn_file (void) const - { return false; } - - virtual int save (ostream& /* os */, bool /* mark_as_global */ = false, - int /* precision */ = 17); -}; - -#endif - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; End: *** -*/ diff -r a65b62d2f630 -r 969032befa3d src/pt-fvc.cc --- a/src/pt-fvc.cc Sat Apr 26 18:56:11 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,814 +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 -#include - -#include - -#include "dynamic-ld.h" -#include "error.h" -#include "gripes.h" -#include "oct-map.h" -#include "oct-obj.h" -#include "pager.h" -#include "symtab.h" -#include "pt-const.h" -#include "pt-fvc.h" -#include "pt-walk.h" -#include "utils.h" - -// But first, some extra functions used by the tree classes. - -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; -} - -// Make sure that all arguments have values. - -// 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; -} - -// Symbols from the symbol table. - -string -tree_identifier::name (void) const -{ - string retval; - if (sym) - retval = sym->name (); - return retval; -} - -tree_identifier * -tree_identifier::define (tree_constant *t) -{ - int status = sym->define (t); - return status ? this : 0; -} - -tree_identifier * -tree_identifier::define (tree_function *t) -{ - int status = sym->define (t); - return status ? this : 0; -} - -void -tree_identifier::document (const string& s) -{ - if (sym) - sym->document (s); -} - -octave_value -tree_identifier::assign (octave_value::assign_op op, const octave_value& rhs) -{ - octave_value retval; - - if (rhs.is_defined ()) - { - if (! sym->is_defined ()) - { - if (! (sym->is_formal_parameter () - || sym->is_linked_to_global ())) - { - link_to_builtin_variable (sym); - } - } - else if (sym->is_function ()) - { - sym->clear (); - } - - // XXX FIXME XXX -- make this work for ops other than `='. - - tree_constant *tmp = new tree_constant (rhs); - - if (sym->define (tmp)) - retval = rhs; - else - delete tmp; - } - - return retval; -} - -octave_value -tree_identifier::assign (octave_value::assign_op op, - const octave_value_list& args, - const octave_value& rhs) -{ - octave_value retval; - - if (rhs.is_defined ()) - { - if (! sym->is_defined ()) - { - if (! (sym->is_formal_parameter () - || sym->is_linked_to_global ())) - { - link_to_builtin_variable (sym); - } - } - else if (sym->is_function ()) - { - sym->clear (); - } - - if (sym->is_variable () && sym->is_defined ()) - { - tree_constant *tmp = static_cast (sym->def ()); - retval = tmp->assign (op, args, rhs); - } - else - { - assert (! sym->is_defined ()); - - if (! Vresize_on_range_error) - { - ::error ("indexed assignment to previously undefined variables"); - ::error ("is only possible when resize_on_range_error is true"); - } - else - { - tree_constant *tmp = new tree_constant (); - retval = tmp->assign (op, args, rhs); - if (retval.is_defined ()) - sym->define (tmp); - } - } - } - - return retval; -} - -bool -tree_identifier::is_defined (void) -{ - return (sym && sym->is_defined ()); -} - -void -tree_identifier::increment (void) -{ - if (sym) - { - if (sym->is_read_only ()) - ::error ("can't redefined read-only variable `%s'", name ().c_str ()); - else if (sym->is_defined () && sym->is_variable ()) - reference () . increment (); - else - ::error ("can only increment variables"); - } -} - -void -tree_identifier::decrement (void) -{ - if (sym) - { - if (sym->is_read_only ()) - ::error ("can't redefined read-only variable `%s'", name ().c_str ()); - else if (sym->is_defined () && sym->is_variable ()) - reference () . decrement (); - else - ::error ("can only decrement variables"); - } -} - -void -tree_identifier::eval_undefined_error (void) -{ - int l = line (); - int c = column (); - - if (l == -1 && c == -1) - ::error ("`%s' undefined", name ().c_str ()); - else - ::error ("`%s' undefined near line %d column %d", - name ().c_str (), l, c); -} - -// Try to find a definition for an identifier. Here's how: -// -// * If the identifier is already defined and is a function defined -// in an function file that has been modified since the last time -// we parsed it, parse it again. -// -// * If the identifier is not defined, try to find a builtin -// variable or an already compiled function with the same name. -// -// * If the identifier is still undefined, try looking for an -// function file to parse. -// -// * On systems that support dynamic linking, we prefer .oct files -// over .m files. - -tree_fvc * -tree_identifier::do_lookup (bool& script_file_executed, bool exec_script) -{ - script_file_executed = lookup (sym, exec_script); - - tree_fvc *retval = 0; - - if (! script_file_executed) - retval = sym->def (); - - return retval; -} - -void -tree_identifier::link_to_global (void) -{ - if (sym) - link_to_global_variable (sym); -} - -void -tree_identifier::mark_as_static (void) -{ - if (sym) - sym->mark_as_static (); -} - -void -tree_identifier::mark_as_formal_parameter (void) -{ - if (sym) - sym->mark_as_formal_parameter (); -} - -octave_value -tree_identifier::eval (bool print) -{ - octave_value retval; - - if (error_state) - return retval; - - bool script_file_executed = false; - - tree_fvc *object_to_eval = do_lookup (script_file_executed); - - if (! script_file_executed) - { - if (object_to_eval) - { - int nargout = maybe_do_ans_assign ? 0 : 1; - - if (nargout) - { - octave_value_list tmp_args; - octave_value_list tmp - = object_to_eval->eval (false, nargout, tmp_args); - - if (tmp.length () > 0) - retval = tmp(0); - } - else - retval = object_to_eval->eval (); - } - else - eval_undefined_error (); - } - - if (! error_state) - { - if (retval.is_defined ()) - { - if (maybe_do_ans_assign && ! object_to_eval->is_constant ()) - bind_ans (retval, print); - else if (print) - retval.print_with_name (name ()); - } - else if (object_to_eval && object_to_eval->is_constant ()) - eval_undefined_error (); - } - - return retval; -} - -octave_value_list -tree_identifier::eval (bool print, int nargout, const octave_value_list& args) -{ - octave_value_list retval; - - if (error_state) - return retval; - - bool script_file_executed = false; - - tree_fvc *object_to_eval = do_lookup (script_file_executed); - - if (! script_file_executed) - { - if (object_to_eval) - { - if (maybe_do_ans_assign && nargout == 1) - { - - // Don't count the output arguments that we create - // automatically. - - nargout = 0; - - retval = object_to_eval->eval (false, nargout, args); - - if (retval.length () > 0 && retval(0).is_defined ()) - bind_ans (retval(0), print); - } - else - retval = object_to_eval->eval (print, nargout, args); - } - else - eval_undefined_error (); - } - - return retval; -} - -void -tree_identifier::accept (tree_walker& tw) -{ - tw.visit_identifier (*this); -} - -octave_value -tree_identifier::value (void) const -{ - return sym->variable_value (); -} - -octave_value& -tree_identifier::reference (void) -{ - return sym->variable_reference (); -} - -// Indirect references to values (structure elements). - -tree_indirect_ref::~tree_indirect_ref (void) -{ - if (! preserve_ident) - delete id; - - if (! preserve_indir) - delete indir; -} - -string -tree_indirect_ref::name (void) const -{ - string retval; - - if (is_identifier_only ()) - retval = id->name (); - else - { - if (id) - retval = id->name (); - else if (indir) - retval = indir->name (); - else - panic_impossible (); - - retval.append ("."); - retval.append (nm); - } - - return retval; -} - -octave_value -tree_indirect_ref::eval (bool print) -{ - octave_value retval; - - if (is_identifier_only ()) - retval = id->eval (print); - else - { - retval = value (); - - if (! error_state && retval.is_defined ()) - { - if (maybe_do_ans_assign) - bind_ans (retval, print); - else if (print) - retval.print_with_name (name ()); - } - } - - return retval; -} - -octave_value_list -tree_indirect_ref::eval (bool print, int nargout, - const octave_value_list& args) -{ - octave_value_list retval; - - if (is_identifier_only ()) - retval = id->eval (print, nargout, args); - else - { - octave_value tmp = value (); - - if (! error_state && tmp.is_defined ()) - { - retval = tmp.index (args); - - if (! error_state) - { - if (maybe_do_ans_assign && nargout == 1 - && retval.length () > 0 && retval(0).is_defined ()) - bind_ans (retval(0), print); - } - } - } - - return retval; -} - -void -tree_indirect_ref::accept (tree_walker& tw) -{ - tw.visit_indirect_ref (*this); -} - -octave_value -tree_indirect_ref::value (void) const -{ - octave_value retval; - - if (is_identifier_only ()) - retval = id->value (); - else - { - if (id) - retval = id->value (); - else if (indir) - retval = indir->value (); - else - panic_impossible (); - - if (! error_state) - retval = retval.struct_elt_val (nm); - } - - return retval; -} - -octave_value& -tree_indirect_ref::reference (void) -{ - if (is_identifier_only ()) - return id->reference (); - else - { - if (id) - { - octave_value& tmp = id->reference (); - if (tmp.is_undefined () || ! tmp.is_map ()) - tmp = Octave_map (); - return tmp.struct_elt_ref (nm); - } - else if (indir) - { - octave_value& tmp = indir->reference (); - if (tmp.is_undefined () || ! tmp.is_map ()) - tmp = Octave_map (); - return tmp.struct_elt_ref (nm); - } - else - { - static octave_value foo; - panic_impossible (); - return foo; - } - } -} - -// Builtin functions. - -tree_builtin::tree_builtin (const string& nm) -{ - is_mapper = 0; - fcn = 0; - my_name = nm; -} - -tree_builtin::tree_builtin (const builtin_mapper_function& m_fcn, - const string &nm) -{ - mapper_fcn = m_fcn; - is_mapper = 1; - fcn = 0; - my_name = nm; -} - -tree_builtin::tree_builtin (Octave_builtin_fcn g_fcn, const string& nm) -{ - is_mapper = 0; - fcn = g_fcn; - my_name = nm; -} - -octave_value -tree_builtin::eval (bool /* print */) -{ - octave_value retval; - - if (error_state) - return retval; - - if (fcn) - { - octave_value_list args; - octave_value_list tmp = (*fcn) (args, 0); - if (tmp.length () > 0) - retval = tmp(0); - } - else if (is_mapper) - { - ::error ("%s: too few arguments", my_name.c_str ()); - } - else - panic_impossible (); - - return retval; -} - -static octave_value -apply_mapper_fcn (const octave_value& arg, builtin_mapper_function& m_fcn, - bool /* print */) -{ - octave_value retval; - - if (m_fcn.ch_mapper) - { - // 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 (m_fcn.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) - = (*m_fcn.ch_mapper) (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) - = (*m_fcn.ch_mapper) (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) - = (*m_fcn.ch_mapper) (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 (m_fcn.flag - && (d < m_fcn.lower_limit || d > m_fcn.upper_limit)) - { - if (m_fcn.c_c_mapper) - retval = m_fcn.c_c_mapper (Complex (d)); - else - error ("%s: unable to handle real arguments", - m_fcn.name.c_str ()); - } - else if (m_fcn.d_d_mapper) - retval = m_fcn.d_d_mapper (d); - else - error ("%s: unable to handle real arguments", - m_fcn.name.c_str ()); - } - else - { - Matrix m = arg.matrix_value (); - - if (error_state) - return retval; - - if (m_fcn.flag - && (any_element_less_than (m, m_fcn.lower_limit) - || any_element_greater_than (m, m_fcn.upper_limit))) - { - if (m_fcn.c_c_mapper) - { - ComplexMatrix cm (m); - retval = cm.map (m_fcn.c_c_mapper); - } - else - error ("%s: unable to handle real arguments", - m_fcn.name.c_str ()); - } - else if (m_fcn.d_d_mapper) - retval = m.map (m_fcn.d_d_mapper); - else - error ("%s: unable to handle real arguments", - m_fcn.name.c_str ()); - } - } - else if (arg.is_complex_type ()) - { - if (arg.is_scalar_type ()) - { - Complex c = arg.complex_value (); - - if (m_fcn.d_c_mapper) - retval = m_fcn.d_c_mapper (c); - else if (m_fcn.c_c_mapper) - retval = m_fcn.c_c_mapper (c); - else - error ("%s: unable to handle complex arguments", - m_fcn.name.c_str ()); - } - else - { - ComplexMatrix cm = arg.complex_matrix_value (); - - if (error_state) - return retval; - - if (m_fcn.d_c_mapper) - retval = cm.map (m_fcn.d_c_mapper); - else if (m_fcn.c_c_mapper) - retval = cm.map (m_fcn.c_c_mapper); - else - error ("%s: unable to handle complex arguments", - m_fcn.name.c_str ()); - } - } - else - gripe_wrong_type_arg ("mapper", arg); - } - - return retval; -} - -octave_value_list -tree_builtin::eval (bool /* print */, int nargout, const octave_value_list& args) -{ - octave_value_list retval; - - if (error_state) - return retval; - - int nargin = args.length (); - - if (fcn) - { - if (any_arg_is_magic_colon (args)) - ::error ("invalid use of colon in function argument list"); - else - retval = (*fcn) (args, nargout); - } - else if (is_mapper) - { - if (nargin > 1) - ::error ("%s: too many arguments", my_name.c_str ()); - else if (nargin < 1) - ::error ("%s: too few arguments", my_name.c_str ()); - else - { - if (args(0).is_defined ()) - { - octave_value tmp = apply_mapper_fcn (args(0), mapper_fcn, 0); - retval(0) = tmp; - } - else - ::error ("%s: argument undefined", my_name.c_str ()); - } - } - else - panic_impossible (); - - return retval; -} - -void -tree_builtin::accept (tree_walker& tw) -{ - tw.visit_builtin (*this); -} - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; End: *** -*/ diff -r a65b62d2f630 -r 969032befa3d src/pt-fvc.h --- a/src/pt-fvc.h Sat Apr 26 18:56:11 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,260 +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_tree_fvc2_h) -#define octave_tree_fvc2_h 1 - -#if defined (__GNUG__) -#pragma interface -#endif - -class ostream; - -#include - -#include - -class symbol_record; -class tree_constant; -class tree_function; - -class tree_walker; - -#include "mappers.h" -#include "pt-fvc-base.h" -#include "variables.h" - -// Symbols from the symbol table. - -class -tree_identifier : public tree_fvc -{ - friend class tree_index_expression; - -public: - - tree_identifier (int l = -1, int c = -1) - : tree_fvc (l, c), sym (0), maybe_do_ans_assign (false) { } - - tree_identifier (symbol_record *s, int l = -1, int c = -1) - : tree_fvc (l, c), sym (s), maybe_do_ans_assign (false) { } - - ~tree_identifier (void) { } - - bool is_identifier (void) const - { return true; } - - string name (void) const; - - tree_identifier *define (tree_constant *t); - tree_identifier *define (tree_function *t); - - void document (const string& s); - - octave_value assign (octave_value::assign_op op, - const octave_value& t); - - octave_value assign (octave_value::assign_op op, - const octave_value_list& args, - const octave_value& t); - - bool is_defined (void); - - void increment (void); - - void decrement (void); - - tree_fvc *do_lookup (bool& script_file_executed, bool exec_script = true); - - void link_to_global (void); - - void mark_as_static (void); - - void mark_as_formal_parameter (void); - - void mark_for_possible_ans_assign (void) - { maybe_do_ans_assign = true; } - - octave_value eval (bool print = false); - - octave_value_list eval (bool print, int nargout, - const octave_value_list& args); - - void eval_undefined_error (void); - - void accept (tree_walker& tw); - - octave_value value (void) const; - - octave_value& reference (void); - -private: - - // The symbol record that this identifier references. - symbol_record *sym; - - // True if we should consider assigning the result of evaluating - // this identifier to the built-in variable ans. - bool maybe_do_ans_assign; -}; - -// Indirect references to values (structure references). - -class -tree_indirect_ref : public tree_fvc -{ -public: - - tree_indirect_ref (int l = -1, int c = -1) - : tree_fvc (l, c), id (0), indir (0), nm (), - preserve_ident (false), preserve_indir (false), - maybe_do_ans_assign (false) { } - - tree_indirect_ref (tree_identifier *i, int l = -1, int c = -1) - : tree_fvc (l, c), id (i), indir (0), nm (), - preserve_ident (false), preserve_indir (false), - maybe_do_ans_assign (false) { } - - tree_indirect_ref (tree_indirect_ref *i, const string& n, - int l = -1, int c = -1) - : tree_fvc (l, c), id (0), indir (i), nm (n), - preserve_ident (false), preserve_indir (false), - maybe_do_ans_assign (false) { } - - ~tree_indirect_ref (void); - - bool is_indirect_ref (void) const - { return true; } - - bool is_identifier_only (void) const - { return (id && nm.empty ()); } - - tree_identifier *ident (void) - { return id; } - - tree_indirect_ref *indirect (void) - { return indir; } - - void preserve_identifier (void) - { preserve_ident = true; } - - void preserve_indirect (void) - { preserve_indir = true; } - - void mark_for_possible_ans_assign (void) - { - maybe_do_ans_assign = true; - - if (is_identifier_only ()) - id->mark_for_possible_ans_assign (); - } - - string name (void) const; - - octave_value eval (bool print = false); - - octave_value_list eval (bool print, int nargout, - const octave_value_list& args); - - octave_value value (void) const; - octave_value& reference (void); - - string elt_name (void) - { return nm; } - - void accept (tree_walker& tw); - -private: - - // The identifier for this structure reference. For example, in - // a.b.c, a is the id. - tree_identifier *id; - - // This element just points to another indirect reference. - tree_indirect_ref *indir; - - // The sub-element name. - string nm; - - // True if we should not delete the identifier. - bool preserve_ident; - - // True if we should not delete the indirect reference. - bool preserve_indir; - - // True if we should consider assigning the result of evaluating - // this identifier to the built-in variable ans. - bool maybe_do_ans_assign; -}; - -// Builtin functions. - -class -tree_builtin : public tree_fvc -{ -public: - - tree_builtin (const string& nm = string ()); - - tree_builtin (const builtin_mapper_function& m_fcn, - const string& nm = string ()); - - tree_builtin (Octave_builtin_fcn f, const string& nm = string ()); - - ~tree_builtin (void) { } // XXX ?? XXX - -// int is_builtin (void) const; - - bool is_mapper_function (void) const - { return is_mapper; } - - octave_value eval (bool print = false); - - octave_value_list eval (bool print, int nargout, const octave_value_list& args); - - string name (void) const - { return my_name; } - - void accept (tree_walker& tw); - -private: - - // True if this is a mapper function. - bool is_mapper; - - // A structure describing the mapper function. - builtin_mapper_function mapper_fcn; - - // The actual function, if it is not a mapper. - Octave_builtin_fcn fcn; - - // The name of this function. - string my_name; -}; - -#endif - -/* -;;; Local Variables: *** -;;; mode: C++ *** -;;; End: *** -*/